sync-mht 0.3.8.2 → 0.3.8.3
raw patch · 5 files changed
+51/−30 lines, 5 files
Files
- src/Sync/MerkleTree/CommTypes.hs +1/−1
- src/Sync/MerkleTree/Run.hs +31/−18
- src/Sync/MerkleTree/Sync.hs +8/−5
- src/Sync/MerkleTree/Test.hs +9/−4
- sync-mht.cabal +2/−2
src/Sync/MerkleTree/CommTypes.hs view
@@ -60,7 +60,7 @@ deriving (Read, Show, Eq) thisProtocolVersion :: ProtocolVersion-thisProtocolVersion = ProtocolVersion 4+thisProtocolVersion = ProtocolVersion 5 data LaunchMessage = LaunchMessage
src/Sync/MerkleTree/Run.hs view
@@ -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
src/Sync/MerkleTree/Sync.hs view
@@ -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 ]
src/Sync/MerkleTree/Test.hs view
@@ -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.@=?)
sync-mht.cabal view
@@ -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