fix handling of ERROR in response to REMOVE

This allows an error message from a proxied special remote to be
displayed to the client.

In the case where removal from several nodes of a cluster fails,
there can be several errors. What to do? I decided to only show
the first error to the user. Probably in this case the user is not in a
position to do anything about an error message, so best keep it simple.
If the problem with the first node is fixed, they'll see the error from
the next node.

diff --git a/Annex/Proxy.hs b/Annex/Proxy.hs
index 3a2c5a938ca3047925898983e499ffc4f42ce279..21e950dd8b824234db76a089920950a6818fe4a6 100644 (file)
--- a/Annex/Proxy.hs
+++ b/Annex/Proxy.hs
@@ -76,7 +76,6 @@ proxySpecialRemote
 proxySpecialRemote protoversion r ihdl ohdl endv = go
   where
        go = receivemessage >>= \case
-               Just (BYPASS _) -> go
                Just (CHECKPRESENT k) -> do
                        tryNonAsync (Remote.checkPresent r k) >>= \case
                                Right True -> sendmessage SUCCESS
@@ -90,10 +89,11 @@ proxySpecialRemote protoversion r ihdl ohdl endv = go
                Just (REMOVE k) -> do
                        tryNonAsync (Remote.removeKey r k) >>= \case
                                Right () -> sendmessage SUCCESS
-                               Left _ -> sendmessage FAILURE
+                               Left err -> propagateerror err
                        go
                Just (PUT af k) -> giveup "TODO PUT" -- XXX
                Just (GET offset af k) -> giveup "TODO GET" -- XXX
+               Just (BYPASS _) -> go
                Just (CONNECT _) -> 
                        -- Not supported and the protocol ends here.
                        sendmessage $ CONNECTDONE (ExitFailure 1)       

diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index 57a0b6eb414e4df2b5d56068ac77c62a304fc37e..c65e5c0cd7a3849b3fc23e2f591ca5434310c836 100644 (file)
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -378,7 +378,7 @@ lockContentWhile runproto key a = bracket setup cleanup a
        cleanup True = runproto () $ net $ sendMessage UNLOCKCONTENT
        cleanup False = return ()
 
-remove :: Key -> Proto (Bool, Maybe [UUID])
+remove :: Key -> Proto (Either String Bool, Maybe [UUID])
 remove key = do
        net $ sendMessage (REMOVE key)
        checkSuccessFailurePlus
@@ -644,28 +644,30 @@ checkSuccess' = do
 checkSuccessPlus :: Proto (Maybe [UUID])
 checkSuccessPlus =
        checkSuccessFailurePlus >>= return . \case
-               (True, v) -> v
-               (False, _) -> Nothing
+               (Right True, v) -> v
+               (Right False, _) -> Nothing
+               (Left _, _) -> Nothing
 
-checkSuccessFailurePlus :: Proto (Bool, Maybe [UUID])
+checkSuccessFailurePlus :: Proto (Either String Bool, Maybe [UUID])
 checkSuccessFailurePlus = do
        ver <- net getProtocolVersion
        if ver >= ProtocolVersion 2
                then do
                        ack <- net receiveMessage
                        case ack of
-                               Just SUCCESS -> return (True, Just [])
-                               Just (SUCCESS_PLUS l) -> return (True, Just l)
-                               Just FAILURE -> return (False, Nothing)
-                               Just (FAILURE_PLUS l) -> return (False, Just l)
+                               Just SUCCESS -> return (Right True, Just [])
+                               Just (SUCCESS_PLUS l) -> return (Right True, Just l)
+                               Just FAILURE -> return (Right False, Nothing)
+                               Just (FAILURE_PLUS l) -> return (Right False, Just l)
+                               Just (ERROR err) -> return (Left err, Nothing)
                                _ -> do
                                        net $ sendMessage (ERROR "expected SUCCESS or SUCCESS-PLUS or FAILURE or FAILURE-PLUS")
-                                       return (False, Nothing)
+                                       return (Right False, Nothing)
                else do
                        ok <- checkSuccess
                        if ok
-                               then return (True, Just [])
-                               else return (False, Nothing)
+                               then return (Right True, Just [])
+                               else return (Right False, Nothing)
 
 sendSuccess :: Bool -> Proto ()
 sendSuccess True = net $ sendMessage SUCCESS

diff --git a/P2P/Proxy.hs b/P2P/Proxy.hs
index b18fde4328d4abb5e0486f81b86d8939d1bf102e..45085f4734a702eedc4081dc23260f93062d5209 100644 (file)
--- a/P2P/Proxy.hs
+++ b/P2P/Proxy.hs
@@ -329,13 +329,15 @@ proxy proxydone proxymethods servermode (ClientSide clientrunst clientconn) remo
                                net $ sendMessage message
                                net receiveMessage >>= return . \case
                                        Just SUCCESS ->
-                                               Just (True, [Remote.uuid (remote r)])
+                                               Just ((True, Nothing), [Remote.uuid (remote r)])
                                        Just (SUCCESS_PLUS us) -> 
-                                               Just (True, Remote.uuid (remote r):us)
+                                               Just ((True, Nothing), Remote.uuid (remote r):us)
                                        Just FAILURE ->
-                                               Just (False, [])
+                                               Just ((False, Nothing), [])
                                        Just (FAILURE_PLUS us) ->
-                                               Just (False, us)
+                                               Just ((False, Nothing), us)
+                                       Just (ERROR err) ->
+                                               Just ((False, Just err), [])
                                        _ -> Nothing
                let v' = map join v
                let us = concatMap snd $ catMaybes v'
@@ -344,12 +346,14 @@ proxy proxydone proxymethods servermode (ClientSide clientrunst clientconn) remo
                        client $ net $ sendMessage $
                                let nonplussed = all (== remoteuuid) us 
                                        || protocolversion < 2
-                               in if all (maybe False fst) v'
+                               in if all (maybe False (fst . fst)) v'
                                        then if nonplussed
                                                then SUCCESS
                                                else SUCCESS_PLUS us
                                        else if nonplussed
-                                               then FAILURE
+                                               then case mapMaybe (snd . fst) (catMaybes v') of
+                                                       [] -> FAILURE
+                                                       (err:_) -> ERROR err
                                                else FAILURE_PLUS us
 
        handleGET remoteside message = getresponse (runRemoteSide remoteside) message $

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 844beb3b2e70c04f73868175d08925238a7bc06e..9cc83c4397dc55500374eb724156e14842dc0d46 100644 (file)
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -456,7 +456,7 @@ dropKey' repo r st@(State connpool duc _ _ _) key
                )
        | Git.repoIsHttp repo = giveup "dropping from http remote not supported"
        | otherwise = P2PHelper.remove (uuid r) 
-               (Ssh.runProto r connpool (return (False, Nothing))) key
+               (Ssh.runProto r connpool (return (Right False, Nothing))) key
 
 lockKey :: Remote -> State -> Key -> (VerifiedCopy -> Annex r) -> Annex r
 lockKey r st key callback = do

diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs
index 05707fdb0306829bbc2b1335faece224fbf13396..80c0f9f6a9ef8bead2231a4038967285f646f155 100644 (file)
--- a/Remote/Helper/P2P.hs
+++ b/Remote/Helper/P2P.hs
@@ -60,12 +60,14 @@ retrieve gc runner k af dest p verifyconfig = do
                        Just (False, _) -> giveup "Transfer failed"
                        Nothing -> remoteUnavail
 
-remove :: UUID -> ProtoRunner (Bool, Maybe [UUID]) -> Key -> Annex ()
+remove :: UUID -> ProtoRunner (Either String Bool, Maybe [UUID]) -> Key -> Annex ()
 remove remoteuuid runner k = runner (P2P.remove k) >>= \case
-       Just (True, alsoremoveduuids) -> note alsoremoveduuids
-       Just (False, alsoremoveduuids) -> do
+       Just (Right True, alsoremoveduuids) -> note alsoremoveduuids
+       Just (Right False, alsoremoveduuids) -> do
                note alsoremoveduuids
                giveup "removing content from remote failed"
+       Just (Left err, _) -> do
+               giveup (safeOutput err)
        Nothing -> remoteUnavail
   where
        -- The remote reports removal from other UUIDs than its own,