sync-mht 0.3.8.1 → 0.3.8.2
raw patch · 8 files changed
+120/−71 lines, 8 files
Files
- README.md +11/−1
- src/Sync/MerkleTree/Client.hs +23/−11
- src/Sync/MerkleTree/CommTypes.hs +2/−2
- src/Sync/MerkleTree/Run.hs +43/−28
- src/Sync/MerkleTree/Server.hs +1/−1
- src/Sync/MerkleTree/Sync.hs +15/−7
- src/Sync/MerkleTree/Test.hs +22/−19
- sync-mht.cabal +3/−2
README.md view
@@ -3,6 +3,10 @@ [](https://travis-ci.org/ekarayel/sync-mht) [](http://codecov.io/github/ekarayel/sync-mht?branch=master) [](http://hackage.haskell.org/package/sync-mht)+[](https://github.com/ekarayel/sync-mht/releases)+[](http://stackage.org/lts-3/package/sync-mht)+[](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: ```
src/Sync/MerkleTree/Client.hs view
@@ -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
src/Sync/MerkleTree/CommTypes.hs view
@@ -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)
src/Sync/MerkleTree/Run.hs view
@@ -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
src/Sync/MerkleTree/Server.hs view
@@ -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
src/Sync/MerkleTree/Sync.hs view
@@ -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
src/Sync/MerkleTree/Test.hs view
@@ -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 $
sync-mht.cabal view
@@ -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