diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -34,4 +34,4 @@ Note that: The options -a -u --delete respectively, allow copying of files to the target directory, updating files that are already in the target directory - not matching the contents in the source -directory and delete files that are in the destination directory but not in the source directory. +directory and deleting files that are in the destination directory but not in the source directory. diff --git a/src/main/hs/Sync/MerkleTree/Client.hs b/src/main/hs/Sync/MerkleTree/Client.hs --- a/src/main/hs/Sync/MerkleTree/Client.hs +++ b/src/main/hs/Sync/MerkleTree/Client.hs @@ -5,6 +5,7 @@ import Control.Monad import Control.Monad.IO.Class +import Codec.Compression.GZip import Data.Foldable(Foldable) import Data.Function import Data.Monoid(Monoid, mappend, mempty, Sum(..)) @@ -12,6 +13,7 @@ import Data.List import Foreign.C.Types import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL import qualified Data.Foldable as F import qualified Data.Set as S import qualified Data.Map as M @@ -113,7 +115,8 @@ case result of Final -> return () ToBeContinued content contHandle -> - (liftIO $ BS.hPut h content) >> queryFileContReq contHandle >>= loop + do liftIO $ BS.hPut h $ BL.toStrict $ decompress $ BL.fromStrict content + queryFileContReq contHandle >>= loop loop firstResult liftIO $ hClose h let modTime = (CTime $ unModTime $ f_modtime f) diff --git a/src/main/hs/Sync/MerkleTree/CommTypes.hs b/src/main/hs/Sync/MerkleTree/CommTypes.hs --- a/src/main/hs/Sync/MerkleTree/CommTypes.hs +++ b/src/main/hs/Sync/MerkleTree/CommTypes.hs @@ -55,10 +55,11 @@ data ProtocolVersion = Version1 + | Version2 deriving (Read, Show, Eq) thisProtocolVersion :: ProtocolVersion -thisProtocolVersion = Version1 +thisProtocolVersion = Version2 data LaunchMessage = LaunchMessage diff --git a/src/main/hs/Sync/MerkleTree/Run.hs b/src/main/hs/Sync/MerkleTree/Run.hs --- a/src/main/hs/Sync/MerkleTree/Run.hs +++ b/src/main/hs/Sync/MerkleTree/Run.hs @@ -102,7 +102,8 @@ [ "Usage: sync-mht [OPTIONS..]" , "" , "Fast incremental file transfer using Merkle-Hash-Trees (Version: " - ++ showVersion version ++ ")" + ++ showVersion version + ++ ")" ] details = unlines [ "Note: The argument to the --remote-shell option should be a CMD running sync-mht" @@ -161,19 +162,18 @@ runParent :: ClientServerOptions -> RemoteCmd -> FilePath -> FilePath -> Direction -> IO () runParent clientServerOpts mRemoteCmd source destination dir = - case mRemoteCmd of - RemoteCmd remoteCmd -> - do let remoteCmd' = remoteCmd ++ " " ++ _HIDDENT_CLIENT_MODE_OPTION_ - handles <- - createProcess ((shell remoteCmd') { std_in = CreatePipe, std_out = CreatePipe }) - case handles of - (Just hIn, Just hOut, Nothing, _ph) -> - do streams <- openStreams hOut hIn - parent streams source destination dir clientServerOpts - _ -> fail "createProcess did not return the correct set of handles." - Simulate -> - do (parentInStream, childOutStream) <- mkChanStreams - (childInStream, parentOutStream) <- mkChanStreams - _ <- forkIO $ child $ StreamPair { sp_in = childInStream, sp_out = childOutStream } - let parentStreams = StreamPair { sp_in = parentInStream, sp_out = parentOutStream } - parent parentStreams source destination dir clientServerOpts + do parentStreams <- + case mRemoteCmd of + RemoteCmd remoteCmd -> + do let remoteCmd' = remoteCmd ++ " " ++ _HIDDENT_CLIENT_MODE_OPTION_ + handles <- + createProcess $ (shell remoteCmd') { std_in = CreatePipe, std_out = CreatePipe } + case handles of + (Just hIn, Just hOut, Nothing, _ph) -> openStreams hOut hIn + _ -> fail "createProcess did not return the correct set of handles." + 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 diff --git a/src/main/hs/Sync/MerkleTree/Server.hs b/src/main/hs/Sync/MerkleTree/Server.hs --- a/src/main/hs/Sync/MerkleTree/Server.hs +++ b/src/main/hs/Sync/MerkleTree/Server.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} module Sync.MerkleTree.Server where +import Codec.Compression.GZip import Control.Monad.State import Sync.MerkleTree.CommTypes import Sync.MerkleTree.Trie @@ -13,6 +14,7 @@ import qualified Data.Map as M import Data.Map(Map) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL import System.IO data ServerState @@ -58,4 +60,5 @@ do liftIO $ hClose h modify (\s -> s { st_handles = M.delete n (st_handles s) }) return $ Final - | otherwise -> return $ ToBeContinued bs $ ContHandle n + | otherwise -> + return $ ToBeContinued (BL.toStrict $ compress $ BL.fromStrict bs) $ ContHandle n 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.22 build-type: Simple -version: 0.3.4.0 +version: 0.3.5.0 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 --recursive source-repository this type: git - tag: 0.3.4.0 + tag: 0.3.5.0 location: https://github.com/ekarayel/sync-mht --recursive test-suite main type: detailed-0.9 @@ -66,6 +66,7 @@ , transformers >= 0.3 && < 0.4 , regex-compat >= 0.95 && < 0.96 , mtl >= 2.1 && < 2.2 + , zlib >= 0.6 && < 0.7 , Cabal >= 1.22 && < 1.23 , time >= 1.4 && < 1.5 , random >= 1.0 && < 1.1 @@ -102,6 +103,7 @@ , transformers >= 0.3 && < 0.4 , regex-compat >= 0.95 && < 0.96 , mtl >= 2.1 && < 2.2 + , zlib >= 0.6 && < 0.7 , Cabal >= 1.22 && < 1.23 , time >= 1.4 && < 1.5 , random >= 1.0 && < 1.1