diff --git a/src/Sync/MerkleTree/CommTypes.hs b/src/Sync/MerkleTree/CommTypes.hs --- a/src/Sync/MerkleTree/CommTypes.hs +++ b/src/Sync/MerkleTree/CommTypes.hs @@ -60,7 +60,7 @@ deriving (Read, Show, Eq) thisProtocolVersion :: ProtocolVersion -thisProtocolVersion = ProtocolVersion 4 +thisProtocolVersion = ProtocolVersion 5 data LaunchMessage = LaunchMessage diff --git a/src/Sync/MerkleTree/Run.hs b/src/Sync/MerkleTree/Run.hs --- a/src/Sync/MerkleTree/Run.hs +++ b/src/Sync/MerkleTree/Run.hs @@ -3,10 +3,11 @@ module Sync.MerkleTree.Run where import Control.Concurrent +import Control.Concurrent.MVar import Control.Monad import Data.List - import System.Console.GetOpt +import System.Exit import System.IO import System.IO.Error import System.Process @@ -101,9 +102,6 @@ putError :: String -> IO () putError = hPutStrLn stderr -_HIDDENT_CLIENT_MODE_OPTION_ :: String -_HIDDENT_CLIENT_MODE_OPTION_ = "--hidden-client-mode-option" - printUsageInfo :: String -> IO () printUsageInfo version = mapM_ putError ([usageInfo header optDescriptions] ++ [details]) @@ -132,14 +130,15 @@ main :: String -> [String] -> IO () main version args = flip catchIOError (putError . show) $ do let parsedOpts = getOpt (ReturnInOrder parseNonOption) optDescriptions args + exit err = hPutStrLn stderr err >> exitFailure case () of - () | [_HIDDENT_CLIENT_MODE_OPTION_] == args -> runChild + () | [] == args -> runChild | (options,[],[]) <- parsedOpts -> do mMsg <- run version $ toSyncOptions options case mMsg of - Just err -> fail $ T.unpack err + Just err -> exit $ T.unpack err Nothing -> return () - | (_,_,errs) <- parsedOpts -> fail $ concat $ map (++"\n") errs + | (_,_,errs) <- parsedOpts -> exit $ concat $ map (++"\n") errs run :: String -> SyncOptions -> IO (Maybe T.Text) run version so @@ -147,9 +146,9 @@ | so_version so = putStrLn version >> return Nothing | not (null (so_nonOptions so)) = return $ Just $ T.concat - [ "Unrecognized options: " - , T.intercalate ", " (map T.pack $ so_nonOptions so) - ] + [ "Unrecognized options: " + , T.intercalate ", " (map T.pack $ so_nonOptions so) + ] | Just source <- so_source so, Just destination <- so_destination so = do cs <- toClientServerOptions so case (parseFilePath source, parseFilePath destination) of @@ -169,7 +168,7 @@ do let missingOpts = T.intercalate ", " $ map snd $ filter ((== Nothing) . ($ so) . fst) [(so_source, "--source"), (so_destination, "--destination")] - return $ Just $ T.concat ["The options ", missingOpts, " are required."] + return $ Just $ T.concat [ "The options ", missingOpts, " are required." ] where usage = printUsageInfo version doubleRemote = "Either the directory given in --source or --destination must be local." @@ -179,10 +178,19 @@ ] missingRemoteCmd = "The --remote-shell is required when the prefix 'remote:' is used." +_WAIT_FOR_INPUT_ :: Int +_WAIT_FOR_INPUT_ = 1000 * 1000 * 3 + runChild :: IO () runChild = - do streams <- openStreams stdin stdout - child streams + do gotMessage <- newEmptyMVar + streams <- openStreams stdin stdout + _ <- forkIO $ + do threadDelay _WAIT_FOR_INPUT_ + r <- isEmptyMVar gotMessage + when r $ putError + "Running in server mode. (The command `sync-mht --help` prints usage info.)" + child gotMessage streams runParent :: ClientServerOptions @@ -195,21 +203,26 @@ do (exitAction, parentStreams) <- case mRemoteCmd of RemoteCmd remoteCmd -> - do let remoteCmd' = remoteCmd ++ " " ++ _HIDDENT_CLIENT_MODE_OPTION_ - (Just hIn, Just hOut, Nothing, ph) <- - createProcess $ (shell remoteCmd') + do (Just hIn, Just hOut, Nothing, ph) <- + createProcess $ (shell remoteCmd) { std_in = CreatePipe , std_out = CreatePipe } parentStreams <- openStreams hOut hIn - return (waitForProcess ph >> return (), parentStreams) + let shutdown = + do hClose hIn + hClose hOut + waitForProcess ph + return () + return (shutdown, parentStreams) Simulate -> do (parentInStream, childOutStream) <- mkChanStreams (childInStream, parentOutStream) <- mkChanStreams childTerminated <- newEmptyMVar + running <- newEmptyMVar let childStrs = StreamPair { sp_in = childInStream, sp_out = childOutStream } let parentStrs = StreamPair { sp_in = parentInStream, sp_out = parentOutStream } - _ <- forkFinally (child childStrs) (const $ putMVar childTerminated ()) + _ <- forkFinally (child running childStrs) (const $ putMVar childTerminated ()) return (takeMVar childTerminated, parentStrs) exitMsg <- parent parentStreams source destination dir clientServerOpts exitAction diff --git a/src/Sync/MerkleTree/Sync.hs b/src/Sync/MerkleTree/Sync.hs --- a/src/Sync/MerkleTree/Sync.hs +++ b/src/Sync/MerkleTree/Sync.hs @@ -15,6 +15,7 @@ ) where import Control.Concurrent(newChan) +import Control.Concurrent.MVar import Control.Monad import Control.Monad.State import Data.Monoid @@ -78,10 +79,11 @@ = FromRemote | ToRemote -child :: StreamPair -> IO () -child streams = +child :: MVar () -> StreamPair -> IO () +child gotMessage streams = do launchMessage <- getFromInputStream (sp_in streams) - serverOrClient (read launchMessage) streams + putMVar gotMessage () + _ <- serverOrClient (read launchMessage) streams return () parent :: @@ -160,7 +162,7 @@ connect (sp_in st) (sp_out st) hClose hIn hClose hOut - got <- readFile (dir "write.out") + got <- readFile $ dir "write.out" testStr H.@=? got , H.TestLabel "testProtocolVersion" $ H.TestCase $ withSystemTempDirectory "testProtocolVersion" $ \dir -> @@ -181,7 +183,8 @@ } } out <- ST.nullOutput - child $ StreamPair { sp_in = inst, sp_out = out } + r <- newEmptyMVar + child r $ StreamPair { sp_in = inst, sp_out = out } return False True H.@=? r ] diff --git a/src/Sync/MerkleTree/Test.hs b/src/Sync/MerkleTree/Test.hs --- a/src/Sync/MerkleTree/Test.hs +++ b/src/Sync/MerkleTree/Test.hs @@ -1,6 +1,7 @@ module Sync.MerkleTree.Test where import Control.Concurrent +import Control.Exception import Control.Monad import Data.Ix import Data.List @@ -24,11 +25,11 @@ tests :: H.Test tests = H.TestList $ [ testClockDriftFail + , testCmdLineFail , testOptions , testBigFile , testHelp , testCmdLine - , testCmdLineFail , testExit , testEntry , testIgnoreBoring @@ -126,9 +127,9 @@ createDirectory srcDir createDirectory destDir writeFile (srcDir "new.txt") expected - runMain ["-s",srcDir,"-d",destDir,"foo","bar"] + shouldFail $ runMain ["-s",srcDir,"-d",destDir,"foo","bar"] runMain ["-s",srcDir,"-d","remote:"++destDir,"-r","exit 0"] - runMain ["-foobar"] + shouldFail $ runMain ["-foobar"] runMain ["--help"] runMain ["-s",srcDir,"-d",destDir] (doesFileExist $ destDir "new.txt") >>= (False H.@=?) @@ -306,7 +307,11 @@ setFileTimes (fp n) (utcTimeFrom d) (utcTimeFrom d) doesThrowIOError :: IO () -> IO Bool -doesThrowIOError a = catchIOError (a >>= (return . (`seq` False))) (return . (`seq` True)) +doesThrowIOError a = + do r <- try (a >> return False) + case r of + Left (SomeException _) -> return True + Right x -> return x shouldFail :: IO () -> IO () shouldFail action = doesThrowIOError action >>= (True H.@=?) diff --git a/sync-mht.cabal b/sync-mht.cabal --- a/sync-mht.cabal +++ b/sync-mht.cabal @@ -8,7 +8,7 @@ extra-doc-files: README.md cabal-version: >= 1.18 build-type: Simple -version: 0.3.8.2 +version: 0.3.8.3 homepage: https://github.com/ekarayel/sync-mht bug-reports: https://github.com/ekarayel/sync-mht/issues package-url: https://github.com/ekarayel/sync-mht @@ -29,7 +29,7 @@ location: https://github.com/ekarayel/sync-mht source-repository this type: git - tag: 0.3.8.2 + tag: 0.3.8.3 location: https://github.com/ekarayel/sync-mht benchmark benchmarks type: exitcode-stdio-1.0