diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,6 +3,10 @@ [![Build Status](https://travis-ci.org/ekarayel/sync-mht.svg?branch=master)](https://travis-ci.org/ekarayel/sync-mht) [![codecov.io](https://img.shields.io/codecov/c/github/ekarayel/sync-mht.svg)](http://codecov.io/github/ekarayel/sync-mht?branch=master) [![Hackage](https://img.shields.io/hackage/v/sync-mht.svg)](http://hackage.haskell.org/package/sync-mht) +[![Release](https://img.shields.io/github/release/ekarayel/sync-mht.svg)](https://github.com/ekarayel/sync-mht/releases) +[![Stackage LTS 3](http://stackage.org/package/sync-mht/badge/lts-3)](http://stackage.org/lts-3/package/sync-mht) +[![Stackage Nightly](http://stackage.org/package/sync-mht/badge/nightly)](http://stackage.org/nightly/package/sync-mht) + ## Synopsis Fast incremental file transfer using Merkle-Hash-Trees @@ -38,7 +42,13 @@ directory and deleting files that are in the destination directory but not in the source directory. ## Setup -Installing sync-mht can be done using [stack](https://github.com/commercialhaskell/stack) with the +Installing the latest release of sync-mht with [stack](https://github.com/commercialhaskell/stack): +``` +stack install sync-mht +``` + +## Contribution +If you want to contribute - cloning the latest commit and building can be done using the following steps: ``` diff --git a/src/Sync/MerkleTree/Client.hs b/src/Sync/MerkleTree/Client.hs --- a/src/Sync/MerkleTree/Client.hs +++ b/src/Sync/MerkleTree/Client.hs @@ -80,25 +80,37 @@ , pg_last :: IORef UTCTime } -checkClockDiff :: (ClientMonad m) => ClientServerOptions -> m Bool +checkClockDiff :: (ClientMonad m) => ClientServerOptions -> m (Maybe T.Text) checkClockDiff opts | Just (realToFrac -> treshold, realToFrac -> skew) <- cs_compareClocks opts = do t0 <- liftIO getCurrentTime t1 <- liftM (addUTCTime skew) queryTime t2 <- liftIO getCurrentTime - return $ and [ diffUTCTime t0 t1 < treshold, diffUTCTime t1 t2 < treshold ] - | otherwise = return True + case (and [ diffUTCTime t0 t1 < treshold, diffUTCTime t1 t2 < treshold ]) of + False -> + return $ Just $ T.concat + [ "Warning: Server and client clocks are apart by at least " + , showText treshold, " seconds!" + ] + True -> + return Nothing + | otherwise = return Nothing -abstractClient :: (ClientMonad m) => ClientServerOptions -> FilePath -> Trie Entry -> m () +abstractClient :: + (ClientMonad m) + => ClientServerOptions + -> FilePath + -> Trie Entry + -> m (Maybe T.Text) abstractClient cs fp trie = do drift <- checkClockDiff cs case drift of - True -> syncClient cs fp trie - False -> - do True <- terminateReq - return () + Nothing -> syncClient cs fp trie + Just msg -> + do True <- terminateReq (Just msg) + return (Just msg) -syncClient :: (ClientMonad m) => ClientServerOptions -> FilePath -> Trie Entry -> m () +syncClient :: (ClientMonad m) => ClientServerOptions -> FilePath -> Trie Entry -> m (Maybe T.Text) syncClient cs fp trie = do logClient $ T.concat [ "Hash of destination directory: ", showText $ t_hash trie, "\n" ] Diff oent nent <- nodeReq (rootLocation, trie) @@ -128,8 +140,8 @@ mapM_ (syncNewOrChangedEntries progress fp) $ groupBy ((==) `on` levelOf) $ sort $ updateEntries logClient "Done. \n" - True <- terminateReq - return () + True <- terminateReq Nothing + return Nothing _CONCURRENT_FILETRANSFER_SIZE_ :: Int _CONCURRENT_FILETRANSFER_SIZE_ = 48 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 @@ -19,7 +19,7 @@ logReq :: T.Text -> m Bool queryFileReq :: Path -> m QueryFileResponse queryFileContReq :: ContHandle -> m QueryFileResponse - terminateReq :: m Bool + terminateReq :: Maybe T.Text -> m Bool queryTime :: m UTCTime data ContHandle = ContHandle Int @@ -43,7 +43,7 @@ | Log T.Text | QueryFile Path | QueryFileCont ContHandle - | Terminate + | Terminate (Maybe T.Text) | QueryTime deriving (Generic) 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 @@ -104,9 +104,9 @@ _HIDDENT_CLIENT_MODE_OPTION_ :: String _HIDDENT_CLIENT_MODE_OPTION_ = "--hidden-client-mode-option" -printUsageInfo :: String -> [String] -> IO () -printUsageInfo version prefix = - mapM_ putError (prefix ++ [usageInfo header optDescriptions] ++ [details]) +printUsageInfo :: String -> IO () +printUsageInfo version = + mapM_ putError ([usageInfo header optDescriptions] ++ [details]) where header = unlines [ "Usage: sync-mht [OPTIONS..]" @@ -134,39 +134,46 @@ do let parsedOpts = getOpt (ReturnInOrder parseNonOption) optDescriptions args case () of () | [_HIDDENT_CLIENT_MODE_OPTION_] == args -> runChild - | (options,[],[]) <- parsedOpts -> run version $ toSyncOptions options - | (_,_,errs) <- parsedOpts -> printUsageInfo version errs + | (options,[],[]) <- parsedOpts -> + do mMsg <- run version $ toSyncOptions options + case mMsg of + Just err -> fail $ T.unpack err + Nothing -> return () + | (_,_,errs) <- parsedOpts -> fail $ concat $ map (++"\n") errs -run :: String -> SyncOptions -> IO () +run :: String -> SyncOptions -> IO (Maybe T.Text) run version so - | so_help so = usage [] - | so_version so = putStrLn version + | so_help so = usage >> return Nothing + | so_version so = putStrLn version >> return Nothing | not (null (so_nonOptions so)) = - usage ["Unrecognized options: " ++ intercalate ", " (so_nonOptions so)] + return $ Just $ T.concat + [ "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 - (Remote _, Remote _) -> usage [doubleRemote] + (Remote _, Remote _) -> return $ Just doubleRemote (Local source', Local destination') - | Just _ <- so_remote so -> usage [missingRemote] + | Just _ <- so_remote so -> return $ Just missingRemote | otherwise -> local cs source' destination' (Remote source', Local destination') | Just remoteCmd <- so_remote so -> runParent cs remoteCmd source' destination' FromRemote - | otherwise -> usage [missingRemoteCmd] + | otherwise -> return $ Just missingRemoteCmd (Local source', Remote destination') | Just remoteCmd <- so_remote so -> runParent cs remoteCmd source' destination' ToRemote - | otherwise -> usage [missingRemoteCmd] + | otherwise -> return $ Just missingRemoteCmd | otherwise = do let missingOpts = - intercalate ", " $ map snd $ filter ((== Nothing) . ($ so) . fst) - [(so_source, "--source"),(so_destination, "--destination")] - usage ["The options " ++ missingOpts ++ " are required."] + T.intercalate ", " $ map snd $ filter ((== Nothing) . ($ so) . fst) + [(so_source, "--source"), (so_destination, "--destination")] + 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." - missingRemote = concat + missingRemote = T.concat [ "The --remote-shell options requires that either the directory given at " , "--source or --destination is at remote site. (Indicated by the prefix: 'remote:')" ] @@ -177,25 +184,33 @@ do streams <- openStreams stdin stdout child streams -runParent :: ClientServerOptions -> RemoteCmd -> FilePath -> FilePath -> Direction -> IO () +runParent :: + ClientServerOptions + -> RemoteCmd + -> FilePath + -> FilePath + -> Direction + -> IO (Maybe T.Text) runParent clientServerOpts mRemoteCmd source destination dir = - do parentStreams <- + do (exitAction, parentStreams) <- case mRemoteCmd of RemoteCmd remoteCmd -> do let remoteCmd' = remoteCmd ++ " " ++ _HIDDENT_CLIENT_MODE_OPTION_ - (Just hIn, Just hOut, Nothing, _ph) <- + (Just hIn, Just hOut, Nothing, ph) <- createProcess $ (shell remoteCmd') { std_in = CreatePipe , std_out = CreatePipe } - openStreams hOut hIn + parentStreams <- openStreams hOut hIn + return (waitForProcess ph >> return (), parentStreams) Simulate -> do (parentInStream, childOutStream) <- mkChanStreams (childInStream, parentOutStream) <- mkChanStreams - _ <- forkIO $ child $ - StreamPair - { sp_in = childInStream - , sp_out = childOutStream - } - return $ StreamPair { sp_in = parentInStream, sp_out = parentOutStream } - parent parentStreams source destination dir clientServerOpts + childTerminated <- 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 ()) + return (takeMVar childTerminated, parentStrs) + exitMsg <- parent parentStreams source destination dir clientServerOpts + exitAction + return exitMsg diff --git a/src/Sync/MerkleTree/Server.hs b/src/Sync/MerkleTree/Server.hs --- a/src/Sync/MerkleTree/Server.hs +++ b/src/Sync/MerkleTree/Server.hs @@ -56,7 +56,7 @@ put $ s { st_handles = M.insert n h (st_handles s), st_nextHandle = n + 1 } withHandle h n queryTime = liftIO getCurrentTime - terminateReq = return True + terminateReq _ = return True -- | Respond to a queryFile or queryFileCont request for a given file handle and id withHandle :: Handle -> Int -> ServerMonad QueryFileResponse 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 @@ -30,6 +30,7 @@ import qualified Data.Bytes.Serial as SE import qualified Data.Bytes.Put as P import qualified Data.ByteString as BS +import qualified Data.Text as T import qualified System.IO.Streams as ST import qualified System.IO.Streams.Concurrent as ST import qualified Test.HUnit as H @@ -65,7 +66,7 @@ queryFileContReq = request . QueryFileCont logReq = request . Log queryTime = request QueryTime - terminateReq = request Terminate + terminateReq = request . Terminate instance ClientMonad RequestMonad where split = splitRequests @@ -81,8 +82,15 @@ child streams = do launchMessage <- getFromInputStream (sp_in streams) serverOrClient (read launchMessage) streams + return () -parent :: StreamPair -> FilePath -> FilePath -> Direction -> ClientServerOptions -> IO () +parent :: + StreamPair + -> FilePath + -> FilePath + -> Direction + -> ClientServerOptions + -> IO (Maybe T.Text) parent streams source destination direction clientServerOpts = case direction of FromRemote -> @@ -103,14 +111,14 @@ respond :: (SE.Serial a) => OutputStream ByteString -> a -> IO () respond os = mapM_ (flip ST.write os . Just) . (:[BS.empty]) . P.runPutS . SE.serialize -local :: ClientServerOptions -> FilePath -> FilePath -> IO () +local :: ClientServerOptions -> FilePath -> FilePath -> IO (Maybe T.Text) local cs source destination = do sourceDir <- liftM (mkTrie 0) $ analyse source (cs_ignore cs) destinationDir <- liftM (mkTrie 0) $ analyse destination (cs_ignore cs) serverState <- startServerState source sourceDir evalStateT (abstractClient cs destination destinationDir) serverState -serverOrClient :: LaunchMessage -> StreamPair -> IO () +serverOrClient :: LaunchMessage -> StreamPair -> IO (Maybe T.Text) serverOrClient lm streams | lm_protocolVersion lm == thisProtocolVersion = let side = @@ -121,7 +129,7 @@ side entries (lm_dir lm) streams | otherwise = fail "Incompatible sync-mht versions." -server :: [Entry] -> FilePath -> StreamPair -> IO () +server :: [Entry] -> FilePath -> StreamPair -> IO (Maybe T.Text) server entries fp streams = (startServerState fp $ mkTrie 0 entries) >>= evalStateT loop where serverRespond = liftIO . respond (sp_out streams) @@ -134,9 +142,9 @@ QueryFileCont c -> queryFileContReq c >>= serverRespond >> loop Log t -> logReq t >>= serverRespond >> loop QueryTime -> queryTime >>= serverRespond >> loop - Terminate -> terminateReq >>= serverRespond + Terminate mMsg -> (terminateReq mMsg >>= serverRespond) >> return mMsg -client :: ClientServerOptions -> [Entry] -> FilePath -> StreamPair -> IO () +client :: ClientServerOptions -> [Entry] -> FilePath -> StreamPair -> IO (Maybe T.Text) client cs entries fp streams = runRequestMonad (sp_in streams) (sp_out streams) $ abstractClient cs fp $ mkTrie 0 entries 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 @@ -18,6 +18,7 @@ import System.IO.Temp import System.Posix.Files import System.Random +import qualified Data.Text as T import qualified Test.HUnit as H tests :: H.Test @@ -148,17 +149,17 @@ createDirectory srcDir createDirectory destDir writeFile (srcDir "new.txt") expected - runSync $ syncOpts { so_compareClocks = Just (10.0, -100.0) } - runSync $ syncOpts { so_compareClocks = Just (10.0, 100.0) } + Just _ <- runSync $ syncOpts { so_compareClocks = Just (10.0, -100.0) } + Just _ <- runSync $ syncOpts { so_compareClocks = Just (10.0, 100.0) } (doesFileExist $ destDir "new.txt") >>= (False H.@=?) - runSync $ syncOpts { so_compareClocks = Just (10.0, 0.0) } + Nothing <- runSync $ syncOpts { so_compareClocks = Just (10.0, 0.0) } got <- readFile $ destDir "new.txt" expected H.@=? got runMain :: [String] -> IO () runMain = main "" -runSync :: SyncOptions -> IO () +runSync :: SyncOptions -> IO (Maybe T.Text) runSync = run "" testHelp :: H.Test @@ -176,21 +177,22 @@ createDirectory srcDir createDirectory destDir writeFile (srcDir "new.txt") data_ - mapM (runSync) $ - [ syncOpts { so_nonOptions = ["foo", "bar"] } - , syncOpts { so_source = Just $ "remote:" ++ srcDir } - , syncOpts { so_source = Nothing } - , syncOpts { so_destination = Nothing } - , syncOpts { so_source = Nothing, so_destination = Nothing } - , defaultSyncOptions - , syncOpts { so_remote = Just $ RemoteCmd "/bin/true" } - , syncOpts { so_destination = Just $ "remote:" ++ destDir } - , syncOpts { so_help = True } - , syncOpts - { so_source = Just $ "remote:" ++ srcDir - , so_destination = Just $ "remote:" ++ destDir - , so_remote = Just $ RemoteCmd "/bin/true" - } ] + Just _ <- runSync $ syncOpts { so_nonOptions = ["foo", "bar"] } + Just _ <- runSync $ syncOpts { so_source = Just $ "remote:" ++ srcDir } + Just _ <- runSync $ syncOpts { so_destination = Just $ "remote:" ++ destDir } + Just _ <- runSync $ syncOpts { so_source = Nothing } + Just _ <- runSync $ syncOpts { so_destination = Nothing } + Just _ <- runSync $ syncOpts { so_source = Nothing, so_destination = Nothing } + Just _ <- runSync defaultSyncOptions + Just _ <- runSync $ syncOpts { so_remote = Just $ RemoteCmd "/bin/true" } + Just _ <- + runSync $ syncOpts + { so_source = Just $ "remote:" ++ srcDir + , so_destination = Just $ "remote:" ++ destDir + , so_remote = Just $ RemoteCmd "/bin/true" + } + Nothing <- runSync $ syncOpts { so_help = True } + Nothing <- runSync $ syncOpts { so_version = True } (doesFileExist $ destDir "new.txt") >>= (False H.@=?) testExit :: H.Test @@ -209,6 +211,7 @@ , so_remote = Just $ RemoteCmd "exit" , so_add = True } + return () testOptions :: H.Test testOptions = H.TestLabel "testOptions" $ H.TestCase $ 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.1 +version: 0.3.8.2 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.1 + tag: 0.3.8.2 location: https://github.com/ekarayel/sync-mht benchmark benchmarks type: exitcode-stdio-1.0 @@ -44,6 +44,7 @@ , directory >=1.2 && <1.3 , temporary >= 1.2 && < 1.3 hs-source-dirs: src + default-language: Haskell2010 test-suite main type: exitcode-stdio-1.0 main-is: Test.hs