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 Annex.Transfer
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Types.Key
|
import Types.Key
|
||||||
|
import Utility.SimpleProtocol (ioHandles)
|
||||||
import GHC.IO.Handle
|
|
||||||
|
|
||||||
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
|
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
|
||||||
|
|
||||||
|
@ -29,7 +28,8 @@ seek :: CommandSeek
|
||||||
seek = withNothing start
|
seek = withNothing start
|
||||||
|
|
||||||
start :: CommandStart
|
start :: CommandStart
|
||||||
start = withHandles $ \(readh, writeh) -> do
|
start = do
|
||||||
|
(readh, writeh) <- liftIO ioHandles
|
||||||
runRequests readh writeh runner
|
runRequests readh writeh runner
|
||||||
stop
|
stop
|
||||||
where
|
where
|
||||||
|
@ -44,21 +44,6 @@ start = withHandles $ \(readh, writeh) -> do
|
||||||
download (Remote.uuid remote) key file forwardRetry $ \p ->
|
download (Remote.uuid remote) key file forwardRetry $ \p ->
|
||||||
getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t 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
|
runRequests
|
||||||
:: Handle
|
:: Handle
|
||||||
-> Handle
|
-> Handle
|
||||||
|
|
|
@ -26,18 +26,19 @@ import qualified Data.Map as M
|
||||||
|
|
||||||
runForeground :: IO ()
|
runForeground :: IO ()
|
||||||
runForeground = do
|
runForeground = do
|
||||||
|
(readh, writeh) <- ioHandles
|
||||||
ichan <- newChan :: IO (Chan Consumed)
|
ichan <- newChan :: IO (Chan Consumed)
|
||||||
ochan <- newChan :: IO (Chan Emitted)
|
ochan <- newChan :: IO (Chan Emitted)
|
||||||
|
|
||||||
let reader = forever $ do
|
let reader = forever $ do
|
||||||
l <- getLine
|
l <- hGetLine readh
|
||||||
case parseMessage l of
|
case parseMessage l of
|
||||||
Nothing -> error $ "protocol error: " ++ l
|
Nothing -> error $ "protocol error: " ++ l
|
||||||
Just cmd -> writeChan ichan cmd
|
Just cmd -> writeChan ichan cmd
|
||||||
let writer = forever $ do
|
let writer = forever $ do
|
||||||
msg <- readChan ochan
|
msg <- readChan ochan
|
||||||
putStrLn $ unwords $ formatMessage msg
|
hPutStrLn writeh $ unwords $ formatMessage msg
|
||||||
hFlush stdout
|
hFlush writeh
|
||||||
let controller = runController ichan ochan
|
let controller = runController ichan ochan
|
||||||
|
|
||||||
-- If any thread fails, the rest will be killed.
|
-- If any thread fails, the rest will be killed.
|
||||||
|
|
|
@ -16,12 +16,13 @@ module Utility.SimpleProtocol (
|
||||||
parse1,
|
parse1,
|
||||||
parse2,
|
parse2,
|
||||||
parse3,
|
parse3,
|
||||||
|
ioHandles,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
import GHC.IO.Handle
|
||||||
|
|
||||||
import Utility.Misc
|
import Common
|
||||||
|
|
||||||
-- Messages that can be sent.
|
-- Messages that can be sent.
|
||||||
class Sendable m where
|
class Sendable m where
|
||||||
|
@ -73,3 +74,17 @@ parse3 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3
|
||||||
|
|
||||||
splitWord :: String -> (String, String)
|
splitWord :: String -> (String, String)
|
||||||
splitWord = separate isSpace
|
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…
Add table
Add a link
Reference in a new issue