diff options
| -rw-r--r-- | Command/TransferKeys.hs | 21 | ||||
| -rw-r--r-- | RemoteDaemon/Core.hs | 7 | ||||
| -rw-r--r-- | Utility/SimpleProtocol.hs | 19 |
3 files changed, 24 insertions, 23 deletions
diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 8f4498eb1..05129005b 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -16,8 +16,7 @@ import Logs.Location import Annex.Transfer import qualified Remote import Types.Key - -import GHC.IO.Handle +import Utility.SimpleProtocol (ioHandles) data TransferRequest = TransferRequest Direction Remote Key AssociatedFile @@ -29,7 +28,8 @@ seek :: CommandSeek seek = withNothing start start :: CommandStart -start = withHandles $ \(readh, writeh) -> do +start = do + (readh, writeh) <- liftIO ioHandles runRequests readh writeh runner stop where @@ -44,21 +44,6 @@ start = withHandles $ \(readh, writeh) -> do download (Remote.uuid remote) key file forwardRetry $ \p -> getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p -{- stdin and stdout are connected with the caller, to be used for - - communication with it. But doing a transfer might involve something - - that tries to read from stdin, or write to stdout. To avoid that, close - - stdin, and duplicate stderr to stdout. Return two new handles - - that are duplicates of the original (stdin, stdout). -} -withHandles :: ((Handle, Handle) -> Annex a) -> Annex a -withHandles a = do - readh <- liftIO $ hDuplicate stdin - writeh <- liftIO $ hDuplicate stdout - liftIO $ do - nullh <- openFile devNull ReadMode - nullh `hDuplicateTo` stdin - stderr `hDuplicateTo` stdout - a (readh, writeh) - runRequests :: Handle -> Handle diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs index a220e5807..b32be98ef 100644 --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -26,18 +26,19 @@ import qualified Data.Map as M runForeground :: IO () runForeground = do + (readh, writeh) <- ioHandles ichan <- newChan :: IO (Chan Consumed) ochan <- newChan :: IO (Chan Emitted) let reader = forever $ do - l <- getLine + l <- hGetLine readh case parseMessage l of Nothing -> error $ "protocol error: " ++ l Just cmd -> writeChan ichan cmd let writer = forever $ do msg <- readChan ochan - putStrLn $ unwords $ formatMessage msg - hFlush stdout + hPutStrLn writeh $ unwords $ formatMessage msg + hFlush writeh let controller = runController ichan ochan -- If any thread fails, the rest will be killed. diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs index 9cc25bc91..1119cd986 100644 --- a/Utility/SimpleProtocol.hs +++ b/Utility/SimpleProtocol.hs @@ -16,12 +16,13 @@ module Utility.SimpleProtocol ( parse1, parse2, parse3, + ioHandles, ) where -import Control.Applicative import Data.Char +import GHC.IO.Handle -import Utility.Misc +import Common -- Messages that can be sent. class Sendable m where @@ -73,3 +74,17 @@ parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 splitWord :: String -> (String, String) splitWord = separate isSpace + +{- When a program speaks a simple protocol over stdio, any other output + - to stdout (or anything that attempts to read from stdin) + - will mess up the protocol. To avoid that, close stdin, and + - and duplicate stderr to stdout. Return two new handles + - that are duplicates of the original (stdin, stdout). -} +ioHandles :: IO (Handle, Handle) +ioHandles = do + readh <- hDuplicate stdin + writeh <- hDuplicate stdout + nullh <- openFile devNull ReadMode + nullh `hDuplicateTo` stdin + stderr `hDuplicateTo` stdout + return (readh, writeh) |