remotedaemon: avoid extraneous stdout output
This commit is contained in:
parent
9a4a3bfb43
commit
cbcb7f50d8
3 changed files with 24 additions and 23 deletions
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in a new issue