sync-mht 0.3.7.0 → 0.3.8.0
raw patch · 14 files changed
+343/−85 lines, 14 filesdep +aesondep +bytesdep ~directorydep ~process
Dependencies added: aeson, bytes
Dependency ranges changed: directory, process
Files
- README.md +13/−1
- src/Benchmarks.hs +175/−0
- src/Sync/MerkleTree/Analyse.hs +1/−1
- src/Sync/MerkleTree/Client.hs +24/−6
- src/Sync/MerkleTree/CommTypes.hs +13/−10
- src/Sync/MerkleTree/Run.hs +11/−1
- src/Sync/MerkleTree/Server.hs +3/−1
- src/Sync/MerkleTree/Sync.hs +9/−5
- src/Sync/MerkleTree/Test.hs +30/−4
- src/Sync/MerkleTree/Trie.hs +17/−16
- src/Sync/MerkleTree/Types.hs +10/−17
- src/Sync/MerkleTree/Util/GetFromInputStream.hs +8/−10
- src/Sync/MerkleTree/Util/RequestMonad.hs +5/−5
- sync-mht.cabal +24/−8
README.md view
@@ -1,7 +1,8 @@ # sync-mht [](https://travis-ci.org/ekarayel/sync-mht)-[](http://codecov.io/github/ekarayel/sync-mht?branch=master)+[](http://codecov.io/github/ekarayel/sync-mht?branch=master)+[](http://hackage.haskell.org/package/sync-mht) ## Synopsis Fast incremental file transfer using Merkle-Hash-Trees @@ -35,3 +36,14 @@ 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 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+following steps:++```+git clone --recursive https://github.com/ekarayel/sync-mht.git+cd sync-mht+stack exec runhaskell configure.hs+stack install+```
+ src/Benchmarks.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DeriveGeneric #-}+import Control.Monad+import Data.Aeson hiding (Result)+import qualified Data.ByteString.Lazy as BS+import Data.List+import Data.Ratio+import Data.Time.Clock+import GHC.Generics+import System.Directory+import System.IO.Temp+import System.FilePath+import System.Process+import System.Environment++data Times+ = Times+ { t_syncMht :: Integer+ , t_rsync :: Integer+ , t_size :: Integer+ }+ deriving Generic+instance ToJSON Times++data Result+ = Result+ { r_full :: Times+ , r_patch :: Times+ , r_sample :: Sample+ }+ deriving Generic+instance ToJSON Result++data Summary+ = Summary+ { s_results :: [Result]+ , s_tag :: String+ }+ deriving Generic+instance ToJSON Summary++_RESOLUTION_ :: (Fractional a) => a+_RESOLUTION_ = fromRational $ 1000 % 1++withTime :: IO () -> IO Integer+withTime action =+ do start <- getCurrentTime+ action+ end <- getCurrentTime+ return $ round $ _RESOLUTION_ * (diffUTCTime end start)++runCmd :: [String] -> IO ()+runCmd = callCommand . intercalate " "++_SSH_PREFIX_ :: String+_SSH_PREFIX_ = "ssh"++_LOCALHOST_ :: String+_LOCALHOST_ = "127.0.0.1"++realFile :: String -> Bool+realFile = (`notElem` [".", ".."])++data Sample+ = Sample+ { s_ghAccount :: String+ , s_ghRepo :: String+ , s_startTag :: String+ , s_diffTag :: String+ }+ deriving Generic+instance ToJSON Sample++samples :: [Sample]+samples =+ [ Sample+ { s_ghAccount = "gionkunz"+ , s_ghRepo = "chartist-js"+ , s_startTag = "60e94d35e2e023f90e14b8907eb1115c9270e7ad"+ , s_diffTag = "ffddebc1c819f14d3982af5c185f9f619249020c"+ }+ , Sample+ { s_ghAccount = "JuliaLang"+ , s_ghRepo = "julia"+ , s_startTag = "3cb9b4879d9da4e14caa79fa6a1ed71fa93871e7"+ , s_diffTag = "5b40f2bd35d87b267dc1ff1cfc6fd7e07670e89c"+ }+ , Sample+ { s_ghAccount = "google"+ , s_ghRepo = "closure-compiler"+ , s_startTag = "2b748b89f8737f3338c0cbe027aa09df1dc8fcaa"+ , s_diffTag = "7e74ada6effa6d429401e2f363a79594a123f269"+ }+ , Sample+ { s_ghAccount = "atom"+ , s_ghRepo = "atom"+ , s_diffTag = "321bf690d214d229b132a4bc03c2f249aa670340"+ , s_startTag = "27cc9cdff3521d5fd5b1725f8e354a2df91117b1"+ }+ ]++sourceDir :: FilePath -> FilePath+sourceDir = (</> "src")++sourceDataDir :: FilePath -> Sample -> FilePath+sourceDataDir baseDir s = (sourceDir baseDir) </> (s_ghRepo s ++ "-" ++ s_startTag s)++targetDir :: FilePath -> String -> FilePath+targetDir fp s = (fp </> "src" </> s)++prepare :: Sample -> FilePath -> IO (FilePath, Integer, Integer)+prepare s benchmarks =+ do createDirectoryIfMissing True benchmarks+ createDirectory baseDir+ createDirectory src+ mapM (createDirectory . targetDir baseDir) ["rsync", "sync-mht"]+ mapM (runCmd . (["wget","-P",src]++) . (:[]) . (gitHubPrefix ++))+ [ "/archive/" ++ startTagZip+ , "/commit/" ++ (s_diffTag s) ++ ".diff"+ ]+ runCmd ["unzip", src </> startTagZip, "-d", src]+ fSize <- readCreateProcess+ (shell "zip -0 -r - . | wc -c") { cwd = Just $ sourceDataDir baseDir s } ""+ pSize <- readCreateProcess+ (shell $ concat ["cat ", sourceDir baseDir </> (s_diffTag s ++ ".diff"), " | wc -c"]) ""+ return (baseDir, read fSize, read pSize)+ where+ gitHubPrefix = "https://github.com/" ++ (s_ghAccount s) ++ "/" ++ (s_ghRepo s)+ startTagZip = (s_startTag s) ++ ".zip"+ src = sourceDir baseDir+ baseDir = benchmarks </> (s_ghAccount s ++ "-" ++ s_ghRepo s)++measure :: Integer -> String -> Sample -> FilePath -> IO Times+measure size syncMhtPath s baseDir =+ do let srcData = sourceDataDir baseDir s+ tSyncMht <- withTime $ runCmd+ [ syncMhtPath, "-a", "-u", "--delete", "-s", srcData, "-d"+ , "remote:" ++ (targetDir baseDir "sync-mht"), "-r"+ , "'" ++ _SSH_PREFIX_ ++ " " ++ _LOCALHOST_ ++ " " ++ syncMhtPath ++ "'"+ ]+ tRsync <- withTime $ runCmd+ [ "rsync", "-rtz", "--delete", "-e", "'"++_SSH_PREFIX_++"'", srcData+ , _LOCALHOST_ ++ ":" ++ (targetDir baseDir "rsync")+ ]+ return $+ Times+ { t_syncMht = tSyncMht+ , t_rsync = tRsync+ , t_size = size+ }++-- | Compare synchronization speeds of rsync vs. sync-mht using (patches of) GitHub repositories+-- Note: To make the comparison fair, we need to run sync-mht (just as rsync using a shell call).+-- Requires: patch, ssh, sshd listening on port 22, passwordless login for loopback ssh+main :: IO ()+main = withSystemTempDirectory "bench" $ \benchmarks ->+ do [syncMhtPath,tag] <- getArgs+ results <- forM samples $ \s ->+ do (baseDir, fSize, pSize) <- prepare s benchmarks+ fullTimes <- measure fSize syncMhtPath s baseDir+ runCmd+ [ "patch", "-p1", "-d", sourceDataDir baseDir s, "-i"+ , sourceDir baseDir </> (s_diffTag s ++ ".diff")+ ]+ patchTimes <- measure pSize syncMhtPath s baseDir+ return $+ Result+ { r_full = fullTimes+ , r_patch = patchTimes+ , r_sample = s+ }+ BS.writeFile "benchmarks.json" $ encode $+ Summary+ { s_results = results+ , s_tag = tag+ }
src/Sync/MerkleTree/Analyse.hs view
@@ -48,7 +48,7 @@ do status <- getFileStatus fp' analyse' status where- path' = Path (SerText $ T.pack name) path+ path' = Path (T.pack name) path fp' = fp </> name analyse' status | isRegularFile status =
src/Sync/MerkleTree/Client.hs view
@@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-} module Sync.MerkleTree.Client where 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(..))+import Data.Monoid(Monoid, mempty, mappend, Sum(..)) import Data.Set(Set) import Data.Time.Clock import Data.List@@ -38,13 +38,13 @@ showText :: (Show a) => a -> T.Text showText = T.pack . show -dataSize :: (Foldable f) => f Entry -> FileSize+dataSize :: (F.Foldable f) => f Entry -> FileSize dataSize s = getSum $ F.foldMap sizeOf s where sizeOf (FileEntry f) = Sum $ f_size f sizeOf (DirectoryEntry _) = Sum $ FileSize 0 -dataSizeText :: (Foldable f) => f Entry -> T.Text+dataSizeText :: (F.Foldable f) => f Entry -> T.Text dataSizeText s = T.concat [showText $ unFileSize $ dataSize s, " bytes"] class (Protocol m, MonadIO m) => (ClientMonad m) where@@ -52,7 +52,7 @@ logClient :: (Protocol m) => T.Text -> m () logClient t =- do True <- logReq $ SerText t+ do True <- logReq t return () data SimpleEntry@@ -80,8 +80,26 @@ , pg_last :: IORef UTCTime } +checkClockDiff :: (ClientMonad m) => ClientServerOptions -> m Bool+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+ abstractClient :: (ClientMonad m) => ClientServerOptions -> FilePath -> Trie Entry -> m () abstractClient cs fp trie =+ do drift <- checkClockDiff cs+ case drift of+ True -> syncClient cs fp trie+ False ->+ do True <- terminateReq+ return ()++syncClient :: (ClientMonad m) => ClientServerOptions -> FilePath -> Trie Entry -> m ()+syncClient cs fp trie = do logClient $ T.concat [ "Hash of destination directory: ", showText $ t_hash trie, "\n" ] Diff oent nent <- nodeReq (rootLocation, trie) let (delEntries, changedEntries, newEntries) = analyseEntries (Diff oent nent)@@ -184,4 +202,4 @@ , False H.~=? (DirectorySimpleEntry p == FileSimpleEntry p) ] where- p = Path (SerText "t") Root+ p = Path "t" Root
src/Sync/MerkleTree/CommTypes.hs view
@@ -5,7 +5,9 @@ import GHC.Generics import Data.Set(Set)-import Data.Serialize+import qualified Data.Text as T+import Data.Bytes.Serial+import Data.Time.Clock import Data.ByteString(ByteString) import Sync.MerkleTree.Types@@ -14,15 +16,16 @@ class Monad m => Protocol m where queryHashReq :: TrieLocation -> m Fingerprint querySetReq :: TrieLocation -> m (Set Entry)- logReq :: SerText -> m Bool+ logReq :: T.Text -> m Bool queryFileReq :: Path -> m QueryFileResponse queryFileContReq :: ContHandle -> m QueryFileResponse terminateReq :: m Bool+ queryTime :: m UTCTime data ContHandle = ContHandle Int deriving (Generic) -instance Serialize ContHandle+instance Serial ContHandle data ClientServerOptions = ClientServerOptions@@ -30,34 +33,34 @@ , cs_update :: Bool , cs_delete :: Bool , cs_ignore :: [FilePath]+ , cs_compareClocks :: Maybe (Double, Double) } deriving (Read, Show) data Request = QuerySet TrieLocation | QueryHash TrieLocation- | Log SerText+ | Log T.Text | QueryFile Path | QueryFileCont ContHandle | Terminate+ | QueryTime deriving (Generic) -instance Serialize Request+instance Serial Request data QueryFileResponse = Final | ToBeContinued ByteString ContHandle deriving (Generic) -instance Serialize QueryFileResponse+instance Serial QueryFileResponse -data ProtocolVersion- = Version1- | Version2+data ProtocolVersion = ProtocolVersion !Int deriving (Read, Show, Eq) thisProtocolVersion :: ProtocolVersion-thisProtocolVersion = Version2+thisProtocolVersion = ProtocolVersion 4 data LaunchMessage = LaunchMessage
src/Sync/MerkleTree/Run.hs view
@@ -31,6 +31,8 @@ , so_delete :: Bool , so_help :: Bool , so_nonOptions :: [String]+ , so_compareClocks :: Maybe (Double, Double)+ , so_version :: Bool } defaultSyncOptions :: SyncOptions@@ -46,6 +48,8 @@ , so_delete = False , so_help = False , so_nonOptions = []+ , so_version = False+ , so_compareClocks = Nothing } toClientServerOptions :: SyncOptions -> IO ClientServerOptions@@ -60,6 +64,7 @@ , cs_update = so_update so , cs_delete = so_delete so , cs_ignore = (concat ignoreFromBoringFiles) ++ (so_ignore so)+ , cs_compareClocks = so_compareClocks so } optDescriptions :: [OptDescr (SyncOptions -> SyncOptions)]@@ -80,6 +85,10 @@ "overwrite existing files" , Option [] ["delete"] (NoArg (\so -> so { so_delete = True })) "delete superfluos files in the destination directory"+ , Option [] ["compareclocks"]+ (OptArg (\x so -> so { so_compareClocks = fmap (flip (,) 0.0 . read) x }) "T")+ "check whether there is a clock drift between client and server"+ , Option ['v'] ["version"] (NoArg (\so -> so { so_version = True})) "shows version" , Option ['h'] ["help"] (NoArg (\so -> so { so_help = True })) "shows usage information" ] @@ -131,6 +140,7 @@ run :: String -> SyncOptions -> IO () run version so | so_help so = usage []+ | so_version so = putStrLn version | not (null (so_nonOptions so)) = usage ["Unrecognized options: " ++ intercalate ", " (so_nonOptions so)] | Just source <- so_source so, Just destination <- so_destination so =@@ -185,7 +195,7 @@ _ <- forkIO $ child $ StreamPair { sp_in = childInStream- , sp_out = childOutStream + , sp_out = childOutStream } return $ StreamPair { sp_in = parentInStream, sp_out = parentOutStream } parent parentStreams source destination dir clientServerOpts
src/Sync/MerkleTree/Server.hs view
@@ -17,6 +17,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import System.IO+import Data.Time.Clock data ServerState = ServerState@@ -43,7 +44,7 @@ instance Protocol ServerMonad where querySetReq l = get >>= (\s -> querySet (st_trie s) l) queryHashReq l = get >>= (\s -> queryHash (st_trie s) l)- logReq (SerText msg) = liftIO (T.hPutStr stderr msg) >> return True+ logReq msg = liftIO (T.hPutStr stderr msg) >> return True queryFileContReq (ContHandle n) = do s <- get let Just h = M.lookup n (st_handles s)@@ -54,6 +55,7 @@ let n = st_nextHandle s put $ s { st_handles = M.insert n h (st_handles s), st_nextHandle = n + 1 } withHandle h n+ queryTime = liftIO getCurrentTime terminateReq = return True -- | Respond to a queryFile or queryFileCont request for a given file handle and id
src/Sync/MerkleTree/Sync.hs view
@@ -27,7 +27,8 @@ import System.IO.Temp import System.IO.Streams(InputStream, OutputStream, connect) import Data.ByteString(ByteString)-import qualified Data.Serialize as SE+import qualified Data.Bytes.Serial as SE+import qualified Data.Bytes.Put as P import qualified Data.ByteString as BS import qualified System.IO.Streams as ST import qualified System.IO.Streams.Concurrent as ST@@ -63,6 +64,7 @@ queryFileReq = request . QueryFile queryFileContReq = request . QueryFileCont logReq = request . Log+ queryTime = request QueryTime terminateReq = request Terminate instance ClientMonad RequestMonad where@@ -98,8 +100,8 @@ , lm_side = side } -respond :: (SE.Serialize a) => OutputStream ByteString -> a -> IO ()-respond os = mapM_ (flip ST.write os . Just) . (:[BS.empty]) . SE.encode+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 cs source destination =@@ -131,6 +133,7 @@ QueryFile f -> queryFileReq f >>= serverRespond >> loop QueryFileCont c -> queryFileContReq c >>= serverRespond >> loop Log t -> logReq t >>= serverRespond >> loop+ QueryTime -> queryTime >>= serverRespond >> loop Terminate -> terminateReq >>= serverRespond client :: ClientServerOptions -> [Entry] -> FilePath -> StreamPair -> IO ()@@ -155,9 +158,9 @@ withSystemTempDirectory "testProtocolVersion" $ \dir -> do r <- flip catchIOError (\_ -> return True) $ do inst <-- ST.fromByteString $ SE.encode $ show $+ ST.fromByteString $ P.runPutS $ SE.serialize $ show $ LaunchMessage- { lm_protocolVersion = Version1+ { lm_protocolVersion = ProtocolVersion 1 , lm_dir = dir , lm_side = Client , lm_clientServerOptions =@@ -166,6 +169,7 @@ , cs_update = False , cs_delete = False , cs_ignore = []+ , cs_compareClocks = Nothing } } out <- ST.nullOutput
src/Sync/MerkleTree/Test.hs view
@@ -6,11 +6,13 @@ import Data.List import Data.Time.Calendar import Data.Time.Clock+import Foreign.C.Types import Sync.MerkleTree.Analyse import Sync.MerkleTree.Run import Sync.MerkleTree.Client import System.Directory import System.FilePath+import System.Posix.Files import System.IO import System.IO.Error import System.IO.Temp@@ -20,7 +22,8 @@ tests :: H.Test tests = H.TestList $- [ testOptions+ [ testClockDriftFail+ , testOptions , testBigFile , testHelp , testCmdLine@@ -129,6 +132,29 @@ runMain ["-s",srcDir,"-d",destDir] (doesFileExist $ destDir </> "new.txt") >>= (False H.@=?) +testClockDriftFail :: H.Test+testClockDriftFail = H.TestLabel "testClockDriftFail" $ H.TestCase $+ withSystemTempDirectory "sync-mht" $ \testDir ->+ do let srcDir = testDir </> "src"+ destDir = testDir </> "dest"+ expected = "expected"+ syncOpts =+ defaultSyncOptions+ { so_add = True+ , so_source = Just $ srcDir+ , so_destination = Just $ "remote:" ++ destDir+ , so_remote = Just Simulate+ }+ 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) }+ (doesFileExist $ destDir </> "new.txt") >>= (False H.@=?)+ runSync $ syncOpts { so_compareClocks = Just (10.0, 0.0) }+ got <- readFile $ destDir </> "new.txt"+ expected H.@=? got+ runMain :: [String] -> IO () runMain = main "" @@ -258,8 +284,8 @@ cmd areDirsEqual (testDir </> "target") (testDir </> "src-backup") -utcTimeFrom :: Integer -> UTCTime-utcTimeFrom x = UTCTime (fromGregorian 2015 07 29) (fromInteger x)+utcTimeFrom :: Integer -> CTime+utcTimeFrom x = CTime (1000+ fromIntegral x) mkRandomDir :: Integer -> [FilePath] -> IO () mkRandomDir md fps =@@ -274,7 +300,7 @@ do d <- randomRIO (1,4) forM_ fps $ \fp -> do writeFile (fp </> n) (show d)- setModificationTime (fp </> n) (utcTimeFrom d)+ setFileTimes (fp </> n) (utcTimeFrom d) (utcTimeFrom d) doesThrowIOError :: IO () -> IO Bool doesThrowIOError a = catchIOError (a >>= (return . (`seq` False))) (return . (`seq` True))
src/Sync/MerkleTree/Trie.hs view
@@ -12,19 +12,19 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 import qualified Data.List as L-import qualified Data.Serialize as SE+import qualified Data.Bytes.Serial as SE import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Test.HUnit as H -data Hash = Hash { unHash :: BS.ByteString }+data Hash = Hash { unHash :: !BS.ByteString } deriving (Eq, Generic) instance Show Hash where showsPrec _ x = ((T.unpack $ TE.decodeUtf8 $ B16.encode $ unHash x) ++) -instance SE.Serialize Hash+instance SE.Serial Hash -- Abstract Merkle Hash Trie data Trie a@@ -41,34 +41,35 @@ data NodeType = NodeType | LeaveType deriving (Eq, Generic)-instance SE.Serialize NodeType +instance SE.Serial NodeType+ -- Location in the Merkle Hash Trie data TrieLocation = TrieLocation- { tl_level :: Int -- ^ Must be nonnegative- , tl_index :: Int -- ^ Must be between nonnegative and smaller than (degree^tl_level)+ { tl_level :: !Int -- ^ Must be nonnegative+ , tl_index :: !Int -- ^ Must be between nonnegative and smaller than (degree^tl_level) } deriving (Generic) -instance SE.Serialize TrieLocation+instance SE.Serial TrieLocation degree :: Int degree = 64 class HasDigest a where- digest :: a -> Digest SHA256+ digest :: a -> Digest MD5 -- | Fingerprint of a Merkle-Hash-Tree node -- We asssume the Tree below a node is identical while synchronizing if its FingerPrint is data Fingerprint = Fingerprint- { f_hash :: Hash- , f_nodeType :: NodeType+ { f_hash :: !Hash+ , f_nodeType :: !NodeType } deriving (Eq, Generic) -instance SE.Serialize Fingerprint+instance SE.Serial Fingerprint toFingerprint :: Trie a -> Fingerprint toFingerprint (Trie h node) = Fingerprint h nodeType@@ -95,11 +96,11 @@ , t_node = Node arr } -hashSHA256 :: BS.ByteString -> Digest SHA256-hashSHA256 = hash+hashMD5 :: BS.ByteString -> Digest MD5+hashMD5 = hash combineHash :: [Hash] -> Hash-combineHash = Hash . toBytes . hashSHA256 . BS.concat . map unHash+combineHash = Hash . toBytes . hashMD5 . BS.concat . map unHash -- | The function @groupOf x@ eeturns a value between 0 to degree-1 for a digest with the property -- that @groupOf@ forms an approximate unviversal hash familiy.@@ -107,7 +108,7 @@ groupOf i x = fromInteger $ toInteger $ (h0 `mod` (fromInteger $ toInteger degree)) where Just (h0, _t) = BS.uncons $ toBytes $ h- h :: Digest SHA256+ h :: Digest MD5 h = hash $ BS.concat [BS.pack [fromInteger $ toInteger i], toBytes $ digest x] mkLeave :: (HasDigest a, Ord a) => [a] -> Trie a@@ -158,7 +159,7 @@ deriving (Eq, Ord, Show) instance HasDigest TestDigest where- digest = hashSHA256 . TE.encodeUtf8 . unTestDigest+ digest = hashMD5 . TE.encodeUtf8 . unTestDigest tests :: H.Test tests = H.TestList $
src/Sync/MerkleTree/Types.hs view
@@ -7,10 +7,10 @@ import Crypto.Hash import Data.Ord import GHC.Generics-import qualified Data.Text.Encoding as TE import qualified Data.Text as T import Sync.MerkleTree.Trie-import qualified Data.Serialize as SE+import qualified Data.Bytes.Serial as SE+import qualified Data.Bytes.Put as P -- | Information about a file that we expect to change, when the contents change. data File@@ -21,29 +21,29 @@ } deriving (Eq, Ord, Generic) -instance SE.Serialize File+instance SE.Serial File data Entry = FileEntry File | DirectoryEntry Path deriving (Eq, Generic) -instance SE.Serialize Entry+instance SE.Serial Entry newtype FileSize = FileSize { unFileSize :: Int64 } deriving (Eq, Ord, Generic, Num) -instance SE.Serialize FileSize+instance SE.Serial FileSize data FileModTime = FileModTime { unModTime :: !Int64 } deriving (Eq, Ord, Generic) -instance SE.Serialize FileModTime+instance SE.Serial FileModTime -- | Representation for paths below the synchronization root directory data Path = Root- | Path SerText Path+ | Path T.Text Path deriving (Eq, Ord, Generic) -- | Returns the string representation of a path@@ -51,9 +51,9 @@ toFilePath fp p = case p of Root -> fp- Path x y -> (toFilePath fp y) </> (T.unpack $ unSerText x)+ Path x y -> (toFilePath fp y) </> (T.unpack x) -instance SE.Serialize Path+instance SE.Serial Path -- | Entries are sorted first according to their depth in the path which is useful for directory -- operations@@ -77,11 +77,4 @@ level (Path _ p) = 1 + level p instance HasDigest Entry where- digest = hash . SE.encode--data SerText = SerText { unSerText :: !T.Text }- deriving (Ord, Eq)--instance SE.Serialize SerText where- get = SE.get >>= either (fail . show) (return . SerText) . TE.decodeUtf8'- put = SE.put . TE.encodeUtf8 . unSerText+ digest = hash . P.runPutS . SE.serialize
src/Sync/MerkleTree/Util/GetFromInputStream.hs view
@@ -2,22 +2,20 @@ ( getFromInputStream ) where -import Data.ByteString(ByteString)-import Data.Serialize(Serialize)-import System.IO.Streams(InputStream) import qualified Data.ByteString as BS-import qualified Data.Serialize as SE+import qualified Data.Bytes.Serial as SE+import qualified Data.Serialize as CES import qualified System.IO.Streams as ST -- | Deserialize value from inputstream-getFromInputStream :: (Serialize a) => InputStream ByteString -> IO a-getFromInputStream s = go (SE.Partial $ SE.runGetPartial SE.get)+getFromInputStream :: (SE.Serial a) => ST.InputStream BS.ByteString -> IO a+getFromInputStream s = go (CES.Partial $ CES.runGetPartial SE.deserialize) where- go (SE.Fail err _bs) = fail err- go (SE.Partial f) =+ go (CES.Fail err _bs) = fail err+ go (CES.Partial f) = do x <- ST.read s case x of Nothing -> (go $ f BS.empty)- Just x' | BS.null x' -> go (SE.Partial f)+ Just x' | BS.null x' -> go (CES.Partial f) | otherwise -> go (f x')- go (SE.Done r bs) = ST.unRead bs s >> return r+ go (CES.Done r bs) = ST.unRead bs s >> return r
src/Sync/MerkleTree/Util/RequestMonad.hs view
@@ -39,15 +39,15 @@ import Data.ByteString(ByteString) import Data.IORef(IORef,newIORef,modifyIORef,readIORef) import Data.Monoid(Monoid, mempty, mappend)-import Data.Serialize(Serialize) import System.IO.Streams(InputStream, OutputStream) import Sync.MerkleTree.Util.GetFromInputStream-import qualified Data.Serialize as SE+import qualified Data.Bytes.Serial as SE+import qualified Data.Bytes.Put as P import qualified System.IO.Streams as ST data SplitState f b = forall a. (Monoid a) => SplitState [RequestMonadT f a] a (a -> RequestMonadT ByteString b)-data RequestState f b = forall a. (Serialize a) => RequestState f (a -> RequestMonadT ByteString b)+data RequestState f b = forall a. (SE.Serial a) => RequestState f (a -> RequestMonadT ByteString b) data LiftIOState b = forall a. LiftIOState (IO a) (a -> RequestMonadT ByteString b) newtype RequestMonad b = RequestMonad { unReqMonad :: RequestMonadT ByteString b }@@ -87,8 +87,8 @@ Return x -> g x Fail s -> Fail s -request :: (Serialize a, Serialize b) => a -> RequestMonad b-request x = RequestMonad $ Request $ RequestState (SE.encode x) Return+request :: (SE.Serial a, SE.Serial b) => a -> RequestMonad b+request x = RequestMonad $ Request $ RequestState (P.runPutS $ SE.serialize x) Return -- | Combine results in the monad non-deterministically -- (it is required that the monoid is commutative)
sync-mht.cabal view
@@ -8,7 +8,7 @@ extra-doc-files: README.md cabal-version: >= 1.18 build-type: Simple-version: 0.3.7.0+version: 0.3.8.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,8 +29,21 @@ location: https://github.com/ekarayel/sync-mht --recursive source-repository this type: git- tag: 0.3.7.0+ tag: 0.3.8.0 location: https://github.com/ekarayel/sync-mht --recursive+benchmark benchmarks+ type: exitcode-stdio-1.0+ main-is: Benchmarks.hs+ build-depends:+ base >=4.7 && <4.9+ , process >= 1.2 && <1.3+ , bytestring >=0.10 && <0.11+ , aeson >= 0.8 && < 1.0+ , time >= 1.4 && < 1.6+ , filepath >=1.3 && <1.5+ , directory >=1.2 && <1.3+ , temporary >= 1.2 && < 1.3+ hs-source-dirs: src test-suite main type: exitcode-stdio-1.0 main-is: Test.hs@@ -49,9 +62,9 @@ build-depends: base >=4.7 && <4.9 , unix >=2.7 && <2.8- , directory >=1.2.3 && <1.3+ , directory >=1.2 && <1.3 , filepath >=1.3 && <1.5- , process == 1.2.3.0+ , process >= 1.2 && <1.3 , cryptohash >=0.11 && <0.12 , exceptions >=0.7 && <0.9 , byteable >=0.1 && <0.2@@ -59,6 +72,7 @@ , containers >=0.5 && <0.6 , text >=1.1 && <1.3 , bytestring >=0.10 && <0.11+ , bytes >= 0.15 , base16-bytestring >=0.1 && <0.2 , cereal >= 0.4 && < 0.5 , io-streams >= 1.2 && <1.4@@ -89,9 +103,9 @@ build-depends: base >=4.7 && <4.9 , unix >=2.7 && <2.8- , directory >=1.2.3 && <1.3+ , directory >=1.2 && <1.3 , filepath >=1.3 && <1.5- , process == 1.2.3.0+ , process >= 1.2 && <1.3 , cryptohash >=0.11 && <0.12 , exceptions >=0.7 && <0.9 , byteable >=0.1 && <0.2@@ -99,6 +113,7 @@ , containers >=0.5 && <0.6 , text >=1.1 && <1.3 , bytestring >=0.10 && <0.11+ , bytes >= 0.15 , base16-bytestring >=0.1 && <0.2 , cereal >= 0.4 && < 0.5 , io-streams >= 1.2 && <1.4@@ -128,9 +143,9 @@ build-depends: base >=4.7 && <4.9 , unix >=2.7 && <2.8- , directory >=1.2.3 && <1.3+ , directory >=1.2 && <1.3 , filepath >=1.3 && <1.5- , process == 1.2.3.0+ , process >= 1.2 && <1.3 , cryptohash >=0.11 && <0.12 , exceptions >=0.7 && <0.9 , byteable >=0.1 && <0.2@@ -138,6 +153,7 @@ , containers >=0.5 && <0.6 , text >=1.1 && <1.3 , bytestring >=0.10 && <0.11+ , bytes >= 0.15 , base16-bytestring >=0.1 && <0.2 , cereal >= 0.4 && < 0.5 , io-streams >= 1.2 && <1.4