summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Command/TransferKeys.hs21
-rw-r--r--RemoteDaemon/Core.hs7
-rw-r--r--Utility/SimpleProtocol.hs19
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)