clean P2P protocol shutdown on EOF

Avoids "git-annex-shell: <stdin>: hGetChar: end of file"
being displayed by the test suite, due to the way it
runs git-annex-shell without using ssh.

git-annex-shell over ssh was not affected because git-annex hangs up the
ssh connection and so never sees the error message that git-annnex-shell
probably did emit.

This commit was sponsored by Ryan Newton on Patreon.
This commit is contained in:
Joey Hess 2018-09-13 10:46:37 -04:00
parent e4d1914e3a
commit b18fb1e343
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 11 additions and 2 deletions

View file

@ -38,6 +38,7 @@ import Annex.ChangedRefs
import Control.Monad.Free import Control.Monad.Free
import Control.Monad.IO.Class import Control.Monad.IO.Class
import System.Exit (ExitCode(..)) import System.Exit (ExitCode(..))
import System.IO.Error
import Network.Socket import Network.Socket
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async import Control.Concurrent.Async
@ -159,9 +160,11 @@ runNet runst conn runner f = case f of
Left e -> return (Left (show e)) Left e -> return (Left (show e))
Right () -> runner next Right () -> runner next
ReceiveMessage next -> do ReceiveMessage next -> do
v <- liftIO $ tryNonAsync $ getProtocolLine (connIhdl conn) v <- liftIO $ tryIOError $ getProtocolLine (connIhdl conn)
case v of case v of
Left e -> return (Left (show e)) Left e
| isEOFError e -> runner (next (Just ProtocolEOF))
| otherwise -> return (Left (show e))
Right Nothing -> return (Left "protocol error") Right Nothing -> return (Left "protocol error")
Right (Just l) -> case parseMessage l of Right (Just l) -> case parseMessage l of
Just m -> do Just m -> do

View file

@ -83,6 +83,7 @@ data Message
| DATA Len -- followed by bytes of data | DATA Len -- followed by bytes of data
| VALIDITY Validity | VALIDITY Validity
| ERROR String | ERROR String
| ProtocolEOF
deriving (Show) deriving (Show)
instance Proto.Sendable Message where instance Proto.Sendable Message where
@ -108,6 +109,7 @@ instance Proto.Sendable Message where
formatMessage (VALIDITY Invalid) = ["INVALID"] formatMessage (VALIDITY Invalid) = ["INVALID"]
formatMessage (DATA len) = ["DATA", Proto.serialize len] formatMessage (DATA len) = ["DATA", Proto.serialize len]
formatMessage (ERROR err) = ["ERROR", Proto.serialize err] formatMessage (ERROR err) = ["ERROR", Proto.serialize err]
formatMessage (ProtocolEOF) = []
instance Proto.Receivable Message where instance Proto.Receivable Message where
parseCommand "AUTH" = Proto.parse2 AUTH parseCommand "AUTH" = Proto.parse2 AUTH
@ -367,6 +369,8 @@ serverLoop :: (Message -> Proto (ServerHandler a)) -> Proto (Maybe a)
serverLoop a = do serverLoop a = do
mcmd <- net receiveMessage mcmd <- net receiveMessage
case mcmd of case mcmd of
-- Stop loop at EOF
Just ProtocolEOF -> return Nothing
-- When the client sends ERROR to the server, the server -- When the client sends ERROR to the server, the server
-- gives up, since it's not clear what state the client -- gives up, since it's not clear what state the client
-- is in, and so not possible to recover. -- is in, and so not possible to recover.

View file

@ -113,6 +113,8 @@ dupIoHandles = do
- This implementation is not super efficient, but as long as the Handle - This implementation is not super efficient, but as long as the Handle
- supports buffering, it avoids reading a character at a time at the - supports buffering, it avoids reading a character at a time at the
- syscall level. - syscall level.
-
- Throws isEOFError when no more input is available.
-} -}
getProtocolLine :: Handle -> IO (Maybe String) getProtocolLine :: Handle -> IO (Maybe String)
getProtocolLine h = go (32768 :: Int) [] getProtocolLine h = go (32768 :: Int) []