diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,8 @@ # sync-mht [![Build Status](https://travis-ci.org/ekarayel/sync-mht.svg?branch=master)](https://travis-ci.org/ekarayel/sync-mht) -[![codecov.io](http://codecov.io/github/ekarayel/sync-mht/coverage.svg?branch=master)](http://codecov.io/github/ekarayel/sync-mht?branch=master) +[![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) ## 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 +``` diff --git a/src/Benchmarks.hs b/src/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/src/Benchmarks.hs @@ -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 + } diff --git a/src/Sync/MerkleTree/Analyse.hs b/src/Sync/MerkleTree/Analyse.hs --- a/src/Sync/MerkleTree/Analyse.hs +++ b/src/Sync/MerkleTree/Analyse.hs @@ -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 = 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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)) diff --git a/src/Sync/MerkleTree/Trie.hs b/src/Sync/MerkleTree/Trie.hs --- a/src/Sync/MerkleTree/Trie.hs +++ b/src/Sync/MerkleTree/Trie.hs @@ -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 $ diff --git a/src/Sync/MerkleTree/Types.hs b/src/Sync/MerkleTree/Types.hs --- a/src/Sync/MerkleTree/Types.hs +++ b/src/Sync/MerkleTree/Types.hs @@ -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 diff --git a/src/Sync/MerkleTree/Util/GetFromInputStream.hs b/src/Sync/MerkleTree/Util/GetFromInputStream.hs --- a/src/Sync/MerkleTree/Util/GetFromInputStream.hs +++ b/src/Sync/MerkleTree/Util/GetFromInputStream.hs @@ -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 diff --git a/src/Sync/MerkleTree/Util/RequestMonad.hs b/src/Sync/MerkleTree/Util/RequestMonad.hs --- a/src/Sync/MerkleTree/Util/RequestMonad.hs +++ b/src/Sync/MerkleTree/Util/RequestMonad.hs @@ -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) 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.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