From 6134431254a20e10bd0c79c35e37cadf2803535b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Sep 2018 16:49:59 -0400 Subject: [PATCH] clean P2P protocol shutdown on EOF try 2 Same goal as b18fb1e343e9654207fbebacf686659c75d0fb4c but without breaking backwards compatability. Just return IO exceptions when running the P2P protocol, so that git-annex-shell can detect eof and avoid the ugly message. This commit was sponsored by Ethan Aubin. --- CmdLine/GitRemoteTorAnnex.hs | 7 +++-- Command/P2P.hs | 2 +- Command/P2PStdIO.hs | 10 +++++-- P2P/Annex.hs | 23 +++++++------- P2P/IO.hs | 56 ++++++++++++++++++++++------------- Remote/Helper/Ssh.hs | 2 +- Remote/P2P.hs | 4 +-- RemoteDaemon/Transport/Tor.hs | 11 +++---- 8 files changed, 70 insertions(+), 45 deletions(-) diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs index b2b9b7837a..7425c5b622 100644 --- a/CmdLine/GitRemoteTorAnnex.hs +++ b/CmdLine/GitRemoteTorAnnex.hs @@ -32,8 +32,9 @@ run (_remotename:address:[]) = forever $ | otherwise = parseAddressPort address go service = do ready - either giveup exitWith - =<< connectService onionaddress onionport service + connectService onionaddress onionport service >>= \case + Right exitcode -> exitWith exitcode + Left e -> giveup $ describeProtoFailure e ready = do putStrLn "" hFlush stdout @@ -48,7 +49,7 @@ parseAddressPort s = Nothing -> giveup "onion address must include port number" Just p -> (OnionAddress a, p) -connectService :: OnionAddress -> OnionPort -> Service -> IO (Either String ExitCode) +connectService :: OnionAddress -> OnionPort -> Service -> IO (Either ProtoFailure ExitCode) connectService address port service = do state <- Annex.new =<< Git.CurrentRepo.get Annex.eval state $ do diff --git a/Command/P2P.hs b/Command/P2P.hs index fecd48d2a8..f1a18fa4d8 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -324,4 +324,4 @@ setupLink remotename (P2PAddressAuth addr authtoken) = do storeP2PRemoteAuthToken addr authtoken return LinkSuccess go (Right Nothing) = return $ AuthenticationError "Unable to authenticate with peer. Please check the address and try again." - go (Left e) = return $ AuthenticationError $ "Unable to authenticate with peer: " ++ e + go (Left e) = return $ AuthenticationError $ "Unable to authenticate with peer: " ++ describeProtoFailure e diff --git a/Command/P2PStdIO.hs b/Command/P2PStdIO.hs index 2bb28a310f..8b3f05d18e 100644 --- a/Command/P2PStdIO.hs +++ b/Command/P2PStdIO.hs @@ -15,6 +15,8 @@ import qualified Annex import Annex.UUID import qualified CmdLine.GitAnnexShell.Checks as Checks +import System.IO.Error + cmd :: Command cmd = noMessages $ command "p2pstdio" SectionPlumbing "communicate in P2P protocol over stdio" @@ -40,5 +42,9 @@ start theiruuid = do P2P.serveAuthed servermode myuuid runst <- liftIO $ mkRunState $ Serving theiruuid Nothing runFullProto runst conn server >>= \case - Right () -> next $ next $ return True - Left e -> giveup e + Right () -> done + -- Avoid displaying an error when the client hung up on us. + Left (ProtoFailureIOError e) | isEOFError e -> done + Left e -> giveup (describeProtoFailure e) + where + done = next $ next $ return True diff --git a/P2P/Annex.hs b/P2P/Annex.hs index 008de23a50..c89ef93a1e 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -28,7 +28,7 @@ import Utility.Metered import Control.Monad.Free -- Full interpreter for Proto, that can receive and send objects. -runFullProto :: RunState -> P2PConnection -> Proto a -> Annex (Either String a) +runFullProto :: RunState -> P2PConnection -> Proto a -> Annex (Either ProtoFailure a) runFullProto runst conn = go where go :: RunProto Annex @@ -36,7 +36,7 @@ runFullProto runst conn = go go (Free (Net n)) = runNet runst conn go n go (Free (Local l)) = runLocal runst go l -runLocal :: RunState -> RunProto Annex -> LocalF (Proto a) -> Annex (Either String a) +runLocal :: RunState -> RunProto Annex -> LocalF (Proto a) -> Annex (Either ProtoFailure a) runLocal runst runner a = case a of TmpContentSize k next -> do tmp <- fromRepo $ gitAnnexTmpObjectLocation k @@ -57,12 +57,12 @@ runLocal runst runner a = case a of transfer upload k af $ sinkfile f o checkchanged sender case v' of - Left e -> return (Left (show e)) - Right (Left e) -> return (Left (show e)) + Left e -> return $ Left $ ProtoFailureException e + Right (Left e) -> return $ Left e Right (Right ok) -> runner (next ok) -- content not available Right Nothing -> runner (next False) - Left e -> return (Left (show e)) + Left e -> return $ Left $ ProtoFailureException e StoreContent k af o l getb validitycheck next -> do -- This is the same as the retrievalSecurityPolicy of -- Remote.P2P and Remote.Git. @@ -79,12 +79,12 @@ runLocal runst runner a = case a of SetPresent k u next -> do v <- tryNonAsync $ logChange k u InfoPresent case v of - Left e -> return (Left (show e)) + Left e -> return $ Left $ ProtoFailureException e Right () -> runner next CheckContentPresent k next -> do v <- tryNonAsync $ inAnnex k case v of - Left e -> return (Left (show e)) + Left e -> return $ Left $ ProtoFailureException e Right result -> runner (next result) RemoveContent k next -> do v <- tryNonAsync $ @@ -96,7 +96,7 @@ runLocal runst runner a = case a of , return True ) case v of - Left e -> return (Left (show e)) + Left e -> return $ Left $ ProtoFailureException e Right result -> runner (next result) TryLockContent k protoaction next -> do v <- tryNonAsync $ lockContentShared k $ \verifiedcopy -> @@ -114,9 +114,10 @@ runLocal runst runner a = case a of Serving _ (Just h) _ -> do v <- tryNonAsync $ liftIO $ waitChangedRefs h case v of - Left e -> return (Left (show e)) + Left e -> return $ Left $ ProtoFailureException e Right changedrefs -> runner (next changedrefs) - _ -> return $ Left "change notification not available" + _ -> return $ Left $ + ProtoFailureMessage "change notification not available" UpdateMeterTotalSize m sz next -> do liftIO $ setMeterTotalSize m sz runner next @@ -153,7 +154,7 @@ runLocal runst runner a = case a of -- known. Force content -- verification. return (rightsize, MustVerify) - Left e -> error e + Left e -> error $ describeProtoFailure e sinkfile f (Offset o) checkchanged sender p = bracket setup cleanup go where diff --git a/P2P/IO.hs b/P2P/IO.hs index 18971d9f3e..0870ec53d4 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -1,6 +1,6 @@ {- P2P protocol, IO implementation - - - Copyright 2016 Joey Hess + - Copyright 2016-2018 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -18,6 +18,8 @@ module P2P.IO , closeConnection , serveUnixSocket , setupHandle + , ProtoFailure(..) + , describeProtoFailure , runNetProto , runNet ) where @@ -38,6 +40,7 @@ import Annex.ChangedRefs import Control.Monad.Free import Control.Monad.IO.Class import System.Exit (ExitCode(..)) +import System.IO.Error import Network.Socket import Control.Concurrent import Control.Concurrent.Async @@ -48,7 +51,17 @@ import System.Log.Logger (debugM) import qualified Network.Socket as S -- Type of interpreters of the Proto free monad. -type RunProto m = forall a. Proto a -> m (Either String a) +type RunProto m = forall a. Proto a -> m (Either ProtoFailure a) + +data ProtoFailure + = ProtoFailureMessage String + | ProtoFailureException SomeException + | ProtoFailureIOError IOError + +describeProtoFailure :: ProtoFailure -> String +describeProtoFailure (ProtoFailureMessage s) = s +describeProtoFailure (ProtoFailureException e) = show e +describeProtoFailure (ProtoFailureIOError e) = show e data RunState = Serving UUID (Maybe ChangedRefsHandle) (TVar ProtocolVersion) @@ -135,19 +148,20 @@ setupHandle s = do -- This only runs Net actions. No Local actions will be run -- (those need the Annex monad) -- if the interpreter reaches any, -- it returns Nothing. -runNetProto :: RunState -> P2PConnection -> Proto a -> IO (Either String a) +runNetProto :: RunState -> P2PConnection -> Proto a -> IO (Either ProtoFailure a) runNetProto runst conn = go where go :: RunProto IO go (Pure v) = return (Right v) go (Free (Net n)) = runNet runst conn go n - go (Free (Local _)) = return (Left "unexpected annex operation attempted") + go (Free (Local _)) = return $ Left $ + ProtoFailureMessage "unexpected annex operation attempted" -- Interpreter of the Net part of Proto. -- -- An interpreter of Proto has to be provided, to handle the rest of Proto -- actions. -runNet :: (MonadIO m, MonadMask m) => RunState -> P2PConnection -> RunProto m -> NetF (Proto a) -> m (Either String a) +runNet :: (MonadIO m, MonadMask m) => RunState -> P2PConnection -> RunProto m -> NetF (Proto a) -> m (Either ProtoFailure a) runNet runst conn runner f = case f of SendMessage m next -> do v <- liftIO $ tryNonAsync $ do @@ -156,13 +170,14 @@ runNet runst conn runner f = case f of hPutStrLn (connOhdl conn) l hFlush (connOhdl conn) case v of - Left e -> return (Left (show e)) + Left e -> return $ Left $ ProtoFailureException e Right () -> runner next ReceiveMessage next -> do - v <- liftIO $ tryNonAsync $ getProtocolLine (connIhdl conn) + v <- liftIO $ tryIOError $ getProtocolLine (connIhdl conn) case v of - Left e -> return (Left (show e)) - Right Nothing -> return (Left "protocol error") + Left e -> return $ Left $ ProtoFailureIOError e + Right Nothing -> return $ Left $ + ProtoFailureMessage "protocol error" Right (Just l) -> case parseMessage l of Just m -> do liftIO $ debugMessage "P2P <" m @@ -175,12 +190,13 @@ runNet runst conn runner f = case f of return ok case v of Right True -> runner next - Right False -> return (Left "short data write") - Left e -> return (Left (show e)) + Right False -> return $ Left $ + ProtoFailureMessage "short data write" + Left e -> return $ Left $ ProtoFailureException e ReceiveBytes len p next -> do v <- liftIO $ tryNonAsync $ receiveExactly len (connIhdl conn) p case v of - Left e -> return (Left (show e)) + Left e -> return $ Left $ ProtoFailureException e Right b -> runner (next b) CheckAuthToken _u t next -> do let authed = connCheckAuth conn t @@ -188,12 +204,12 @@ runNet runst conn runner f = case f of Relay hin hout next -> do v <- liftIO $ runRelay runnerio hin hout case v of - Left e -> return (Left e) + Left e -> return $ Left e Right exitcode -> runner (next exitcode) RelayService service next -> do v <- liftIO $ runRelayService conn runnerio service case v of - Left e -> return (Left e) + Left e -> return $ Left e Right () -> runner next SetProtocolVersion v next -> do liftIO $ atomically $ writeTVar versiontvar v @@ -236,10 +252,10 @@ sendExactly (Len n) b h p = do receiveExactly :: Len -> Handle -> MeterUpdate -> IO L.ByteString receiveExactly (Len n) h p = hGetMetered h (Just n) p -runRelay :: RunProto IO -> RelayHandle -> RelayHandle -> IO (Either String ExitCode) +runRelay :: RunProto IO -> RelayHandle -> RelayHandle -> IO (Either ProtoFailure ExitCode) runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go - `catchNonAsync` (return . Left . show) + `catchNonAsync` (return . Left . ProtoFailureException) where setup = do v <- newEmptyMVar @@ -253,10 +269,10 @@ runRelay runner (RelayHandle hout) (RelayHandle hin) = go v = relayHelper runner v -runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Either String ()) +runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Either ProtoFailure ()) runRelayService conn runner service = bracket setup cleanup go - `catchNonAsync` (return . Left . show) + `catchNonAsync` (return . Left . ProtoFailureException) where cmd = case service of UploadPack -> "upload-pack" @@ -287,13 +303,13 @@ runRelayService conn runner service = go (v, _, _, _, _) = do r <- relayHelper runner v case r of - Left e -> return (Left (show e)) + Left e -> return $ Left e Right exitcode -> runner $ net $ relayToPeer (RelayDone exitcode) waitexit v pid = putMVar v . RelayDone =<< waitForProcess pid -- Processes RelayData as it is put into the MVar. -relayHelper :: RunProto IO -> MVar RelayData -> IO (Either String ExitCode) +relayHelper :: RunProto IO -> MVar RelayData -> IO (Either ProtoFailure ExitCode) relayHelper runner v = loop where loop = do diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 2e14472dcc..8419cc190d 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -343,7 +343,7 @@ runProtoConn a conn@(P2P.OpenConnection (runst, c, _, _)) = do -- When runFullProto fails, the connection is no longer -- usable, so close it. Left e -> do - warning $ "Lost connection (" ++ e ++ ")" + warning $ "Lost connection (" ++ P2P.describeProtoFailure e ++ ")" conn' <- fst <$> liftIO (closeP2PSshConnection conn) return (conn', Nothing) diff --git a/Remote/P2P.hs b/Remote/P2P.hs index 3b3b0bf194..d3106a8480 100644 --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -97,7 +97,7 @@ runProtoConn a c@(OpenConnection (runst, conn)) = do -- so close it. case v of Left e -> do - warning $ "Lost connection to peer (" ++ e ++ ")" + warning $ "Lost connection to peer (" ++ describeProtoFailure e ++ ")" liftIO $ closeConnection conn return (ClosedConnection, Nothing) Right r -> return (c, Just r) @@ -162,7 +162,7 @@ openConnection u addr = do liftIO $ closeConnection conn return ClosedConnection Left e -> do - warning $ "Problem communicating with peer. (" ++ e ++ ")" + warning $ "Problem communicating with peer. (" ++ describeProtoFailure e ++ ")" liftIO $ closeConnection conn return ClosedConnection Left e -> do diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index 6689461840..30e1096cea 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -120,10 +120,10 @@ serveClient th u r q = bracket setup cleanup start v <- liftIO $ runNetProto runstauth conn $ P2P.serveAuth u case v of Right (Just theiruuid) -> authed conn theiruuid - Right Nothing -> liftIO $ - debugM "remotedaemon" "Tor connection failed to authenticate" - Left e -> liftIO $ - debugM "remotedaemon" ("Tor connection error before authentication: " ++ e) + Right Nothing -> liftIO $ debugM "remotedaemon" + "Tor connection failed to authenticate" + Left e -> liftIO $ debugM "remotedaemon" $ + "Tor connection error before authentication: " ++ describeProtoFailure e -- Merge the duplicated state back in. liftAnnex th $ mergeState st' @@ -134,7 +134,8 @@ serveClient th u r q = bracket setup cleanup start P2P.serveAuthed P2P.ServeReadWrite u case v' of Right () -> return () - Left e -> liftIO $ debugM "remotedaemon" ("Tor connection error: " ++ e) + Left e -> liftIO $ debugM "remotedaemon" $ + "Tor connection error: " ++ describeProtoFailure e -- Connect to peer's tor hidden service. transport :: Transport