packages feed

sync-mht 0.2.1.1 → 0.3.0.0

raw patch · 12 files changed

+521/−209 lines, 12 filesdep +Cabaldep +randomdep +regex-compatdep ~directory

Dependencies added: Cabal, random, regex-compat, temporary, time

Dependency ranges changed: directory

Files

README.md view
@@ -32,3 +32,6 @@  to synchronize the folder /bar (of the container named bar) with the local folder foo/. +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.
+ dist/build/mainStub/mainStub-tmp/mainStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test ( stubMain )+import Sync.MerkleTree.Test ( tests )+main :: IO ()+main = stubMain tests
src/main/hs/Main.hs view
@@ -1,165 +1,16 @@--- main module {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} import System.Environment-import System.Process-import System.IO import System.IO.Error import System.Console.GetOpt-import Paths_sync_mht (version)-import Data.List-import Data.Version (showVersion) -import Sync.MerkleTree.CommTypes-import Sync.MerkleTree.Sync--data SyncOptions-    = SyncOptions-      { so_source :: Maybe FilePath-      , so_destination :: Maybe FilePath-      , so_remote :: Maybe String-      , so_ignore :: [FilePath]-      , so_add :: Bool-      , so_update :: Bool-      , so_delete :: Bool-      , so_help :: Bool-      , so_nonOptions :: [String]-      }--defaultSyncOptions :: SyncOptions-defaultSyncOptions =-    SyncOptions-    { so_source = Nothing-    , so_destination = Nothing-    , so_remote = Nothing-    , so_ignore = []-    , so_add = False-    , so_update = False-    , so_delete = False-    , so_help = False-    , so_nonOptions = []-    }---toClientServerOptions :: SyncOptions -> ClientServerOptions-toClientServerOptions so =-     ClientServerOptions-     { cs_add = so_add so-     , cs_update = so_update so-     , cs_delete = so_delete so-     , cs_ignore = so_ignore so-     }--optDescriptions :: [OptDescr (SyncOptions -> SyncOptions)]-optDescriptions =-    [ Option ['s'] ["source"] (ReqArg (\fp so -> so { so_source = Just fp }) "DIR")-        "directory to copy files from (source) (this option is required)"-    , Option ['d'] ["destination"] (ReqArg (\fp so -> so { so_destination = Just fp }) "DIR")-        "directory to copy files to (destination) (this option is required)"-    , Option ['r'] ["remote-shell"] (ReqArg (\s so -> so { so_remote = Just s }) "CMD")-        "synchroize with a remote-site using a remote command execution tool (like ssh or docker)"-    , Option ['i'] ["ignore"] (ReqArg (\fp so -> so { so_ignore = fp:(so_ignore so) }) "PATH") ( concat-        [ "files or directories (relative to the source and destination directories) that are to "-        , "be ignored during synchroization (this option can be given multiple times)"-        ])-    , Option ['a'] ["add"] (NoArg (\so -> so { so_add = True })) ( concat-        [ "copy files from the source directory if there is corresponding file inside "-        , "the destination directory"-        ])-    , Option ['u'] ["update"] (NoArg (\so -> so { so_update = True })) ( concat-        [ "overwrite existing files inside the destination directory if their content does not "-        , "match the respective files inside the source directory"-        ])-    , Option [] ["delete"] (NoArg (\so -> so { so_delete = True })) ( concat-        [ "delete files inside the destination directory if there is no corresponding file inside "-        , "the source directory"-        ])-    , Option ['h'] ["help"] (NoArg (\so -> so { so_help = True })) "shows usage information"-    ]--parseNonOption :: String -> (SyncOptions -> SyncOptions)-parseNonOption s so = so { so_nonOptions = s:(so_nonOptions so) }--toSyncOptions :: [(SyncOptions -> SyncOptions)] -> SyncOptions-toSyncOptions = foldl (flip id) defaultSyncOptions--putError :: String -> IO ()-putError = hPutStrLn stderr--printUsageInfo :: [String] -> IO ()-printUsageInfo prefix = mapM_ putError (prefix ++ [usageInfo header optDescriptions] ++ [details])-    where-      header = unlines-          [ "sync-mht version " ++ showVersion version-          , ""-          , "Usage: sync-mht [OPTIONS..]"-          ]-      details = concat-          [ "Note: If the --remote-shell option has been provided, exactly one of the directories "-          , "must be prepended with 'remote:' - indicating a folder on the site, accessible with "-          , "the provided remote shell command."-          ]--_HIDDENT_CLIENT_MODE_OPTION_ :: String-_HIDDENT_CLIENT_MODE_OPTION_ = "--hidden-client-mode-option"+import Sync.MerkleTree.Run  main :: IO () main = flip catchIOError (putError . show) $     do args <- getArgs        let parsedOpts = getOpt (ReturnInOrder parseNonOption) optDescriptions args        case () of-         () | [_HIDDENT_CLIENT_MODE_OPTION_] == args -> child+         () | [_HIDDENT_CLIENT_MODE_OPTION_] == args -> runChild             | (options,[],[]) <- parsedOpts -> run $ toSyncOptions options             | (_,_,errs) <- parsedOpts -> printUsageInfo errs--data Side-    = Remote FilePath-    | Local FilePath--parseFilePath :: FilePath -> Side-parseFilePath fp-    | Just rest <- stripPrefix "remote:" fp = Remote rest-    | otherwise = Local fp--run :: SyncOptions -> IO ()-run so-    | so_help so =-        printUsageInfo []-    | not (null (so_nonOptions so)) =-        printUsageInfo ["Could not understand the following options: " ++ show (so_nonOptions so)]-    | Just source <- so_source so, Just destination <- so_destination so =-        case (parseFilePath source, parseFilePath destination) of-          (Remote _, Remote _) -> printUsageInfo [doubleRemote]-          (Local source', Local destination')-              | Just _ <- so_remote so -> printUsageInfo [missingRemote]-              | otherwise -> local cs source' destination'-          (Remote source', Local destination')-              | Just remoteCmd <- so_remote so -> runParent cs remoteCmd source' destination' FromRemote-              | otherwise -> printUsageInfo [missingRemoteCmd]-          (Local source', Remote destination')-              | Just remoteCmd <- so_remote so -> runParent cs remoteCmd source' destination' ToRemote-              | otherwise -> printUsageInfo [missingRemoteCmd]-    | otherwise =-        do let missingOpts =-                intercalate ", " $ map snd $ filter ((== Nothing) . ($ so) . fst)-                [(so_source, "--source"),(so_destination, "--destination")]-           printUsageInfo ["The follwing required options: " ++ missingOpts ++ " were missing."]-    where-      cs = toClientServerOptions so-      doubleRemote = "Either the directory given in --source or --destination must be local."-      missingRemote = concat-          [ "The --remote-shell options requires that either the directory given at "-          , "--source or --destination is at remote site. (Indicated by the prefix: 'remote:')"-          ]-      missingRemoteCmd = "The --remote-shell is required when the prefix 'remote:' is used."--runParent :: ClientServerOptions -> String -> FilePath -> FilePath -> Direction -> IO ()-runParent clientServerOpts remoteCmd source destination dir =-    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 return the correct set of handles."-
src/main/hs/Sync/MerkleTree/Analyse.hs view
@@ -5,17 +5,19 @@ {-# LANGUAGE OverloadedStrings #-} module Sync.MerkleTree.Analyse     ( analyseDirectory+    , isRealFile     ) where  import Control.Monad+import Data.Maybe import System.FilePath import Foreign.C.Types import Prelude hiding (lookup) import Sync.MerkleTree.Types import System.Directory- import System.Posix.Types import System.Posix.Files+import Text.Regex (matchRegex, mkRegex, Regex) import qualified Data.Text as T  isRealFile :: String -> Bool@@ -23,16 +25,22 @@     | x `elem` [".", ".."] = False     | otherwise = True -analyseDirectory :: FilePath -> [FilePath] -> Path -> IO [Entry]-analyseDirectory fp ignore path-    | fp `elem` ignore = return []+shouldIgnore :: Path -> [Regex] -> Bool+shouldIgnore p regexes = any (isJust . (`matchRegex` (toFilePath "" p))) regexes++analyseDirectory :: FilePath -> [String] -> Path -> IO [Entry]+analyseDirectory fp ignore path = analyseDir fp (map mkRegex ignore) path++analyseDir :: FilePath -> [Regex] -> Path -> IO [Entry]+analyseDir fp ignore path+    | shouldIgnore path ignore = return []     | otherwise =         do files <- getDirectoryContents fp            liftM concat $ mapM (analyse fp ignore path) $ filter isRealFile files -analyse :: FilePath -> [FilePath] -> Path -> String -> IO [Entry]+analyse :: FilePath -> [Regex] -> Path -> String -> IO [Entry] analyse fp ignore path name-    | (fp </> name) `elem` ignore = return []+    | shouldIgnore path' ignore = return []     | otherwise =         do status <- getFileStatus fp'            analyse' status@@ -50,6 +58,6 @@                     , f_modtime = FileModTime modtime                     } ]           | isDirectory status =-              liftM ((DirectoryEntry path'):) $ analyseDirectory fp' ignore path'+              liftM ((DirectoryEntry path'):) $ analyseDir fp' ignore path'           | otherwise = return [] -- No support for devices, sockets yet.
src/main/hs/Sync/MerkleTree/Client.hs view
@@ -6,6 +6,7 @@ import Control.Monad import Control.Monad.IO.Class import Data.Foldable(Foldable)+import Data.Function import Data.Monoid(Monoid, mappend, mempty, Sum(..)) import Data.Set(Set) import Data.List@@ -49,6 +50,11 @@     do True <- logReq $ SerText t        return () +data SimpleEntry+    = FileSimpleEntry Path+    | DirectorySimpleEntry Path+    deriving (Eq, Ord)+ analyseEntries :: Diff Entry -> ([Entry],[Entry],[Entry]) analyseEntries (Diff obsoleteEntries newEntries) =     (M.elems deleteMap, M.elems changeMap, M.elems newMap)@@ -59,8 +65,8 @@       obsMap = M.fromList $ S.toList $ S.map keyValue obsoleteEntries       updMap = M.fromList $ S.toList $ S.map keyValue newEntries       keyValue x = (name x, x)-      name (FileEntry f) = f_name f-      name (DirectoryEntry f) = f+      name (FileEntry f) = FileSimpleEntry $ f_name f+      name (DirectoryEntry f) = DirectorySimpleEntry f  abstractClient :: (ClientMonad m) => ClientServerOptions -> FilePath -> Trie Entry -> m () abstractClient cs fp trie =@@ -78,20 +84,25 @@                case e of                  FileEntry f -> liftIO $ removeFile $ toFilePath fp $ f_name f                  DirectoryEntry p -> liftIO $ removeDirectory $ toFilePath fp p-       mapM_ (split . map (synchronizeNewOrChangedEntry fp))-           $ splitEvery _CONCURRENT_FILETRANSFER_SIZE_ $ sort-           $ [ e | cs_add cs, e <- newEntries ] ++ [ e | cs_update cs, e <- changedEntries ]+       mapM_ (synchronizeNewOrChangedEntries fp)+           $ groupBy ((==) `on` levelOf)+           $ sort $ [ e | cs_add cs, e <- newEntries ] ++ [ e | cs_update cs, e <- changedEntries ]        True <- terminateReq        return ()  _CONCURRENT_FILETRANSFER_SIZE_ :: Int-_CONCURRENT_FILETRANSFER_SIZE_ = 96+_CONCURRENT_FILETRANSFER_SIZE_ = 48  splitEvery :: Int -> [a] -> [[a]] splitEvery n l     | null l = []     | (h,t) <- splitAt n l = h:(splitEvery n t) +synchronizeNewOrChangedEntries :: (ClientMonad m) => FilePath -> [Entry] -> m ()+synchronizeNewOrChangedEntries fp entries =+    forM_ (splitEvery _CONCURRENT_FILETRANSFER_SIZE_ entries) $ \entryGroup ->+        split $ map (synchronizeNewOrChangedEntry fp) entryGroup+ synchronizeNewOrChangedEntry :: (ClientMonad m) => FilePath -> Entry -> m () synchronizeNewOrChangedEntry fp entry =     case entry of@@ -121,6 +132,3 @@                 do s' <- querySetReq loc                    let s = getAll trie                    return $ Diff (s `S.difference` s') (s' `S.difference` s)---
src/main/hs/Sync/MerkleTree/CommTypes.hs view
@@ -33,9 +33,7 @@       , cs_delete :: Bool       , cs_ignore :: [FilePath]       }-      deriving (Generic, Show, Typeable)--instance Serialize ClientServerOptions+      deriving (Read, Show)  data Request     = QuerySet TrieLocation@@ -55,9 +53,21 @@  instance Serialize QueryFileResponse -data ChildSide-    = Service FilePath ClientServerOptions-    | Client FilePath ClientServerOptions-    deriving (Show, Generic, Typeable)+data ProtocolVersion+    = Version1+    deriving (Read, Show, Eq) -instance Serialize ChildSide+thisProtocolVersion :: ProtocolVersion+thisProtocolVersion = Version1++data LaunchMessage+    = LaunchMessage+    { lm_protocolVersion :: ProtocolVersion+    , lm_dir :: FilePath+    , lm_side :: Side+    , lm_clientServerOptions :: ClientServerOptions+    }+    deriving (Read, Show)++data Side = Server | Client+    deriving (Read, Show)
+ src/main/hs/Sync/MerkleTree/Run.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Sync.MerkleTree.Run where++import Control.Concurrent+import System.Process+import System.IO+import System.Console.GetOpt+import Paths_sync_mht (version)+import Data.List+import Data.Version (showVersion)++import Sync.MerkleTree.CommTypes+import Sync.MerkleTree.Sync++data RemoteCmd+    = RemoteCmd String+    | Simulate++data SyncOptions+    = SyncOptions+      { so_source :: Maybe FilePath+      , so_destination :: Maybe FilePath+      , so_remote :: Maybe RemoteCmd+      , so_ignore :: [String]+      , so_add :: Bool+      , so_update :: Bool+      , so_delete :: Bool+      , so_help :: Bool+      , so_nonOptions :: [String]+      }++defaultSyncOptions :: SyncOptions+defaultSyncOptions =+    SyncOptions+    { so_source = Nothing+    , so_destination = Nothing+    , so_remote = Nothing+    , so_ignore = []+    , so_add = False+    , so_update = False+    , so_delete = False+    , so_help = False+    , so_nonOptions = []+    }++toClientServerOptions :: SyncOptions -> ClientServerOptions+toClientServerOptions so =+     ClientServerOptions+     { cs_add = so_add so+     , cs_update = so_update so+     , cs_delete = so_delete so+     , cs_ignore = so_ignore so+     }++optDescriptions :: [OptDescr (SyncOptions -> SyncOptions)]+optDescriptions =+    [ Option ['s'] ["source"] (ReqArg (\fp so -> so { so_source = Just fp }) "DIR")+        "directory to copy files from (source) (this option is required)"+    , Option ['d'] ["destination"] (ReqArg (\fp so -> so { so_destination = Just fp }) "DIR")+        "directory to copy files to (destination) (this option is required)"+    , Option ['r'] ["remote-shell"] (ReqArg (\s so -> so { so_remote = Just $ RemoteCmd s }) "CMD")+        "synchroize with a remote-site using a remote command execution tool (like ssh or docker)"+    , Option ['i'] ["ignore"] (ReqArg (\fp so -> so { so_ignore = fp:(so_ignore so) }) "PATH") ( concat+        [ "files or directories (relative to the source and destination directories) that are to "+        , "be ignored during synchroization (this option can be given multiple times)"+        ])+    , Option ['a'] ["add"] (NoArg (\so -> so { so_add = True })) ( concat+        [ "copy files from the source directory if there is corresponding file inside "+        , "the destination directory"+        ])+    , Option ['u'] ["update"] (NoArg (\so -> so { so_update = True })) ( concat+        [ "overwrite existing files inside the destination directory if their content does not "+        , "match the respective files inside the source directory"+        ])+    , Option [] ["delete"] (NoArg (\so -> so { so_delete = True })) ( concat+        [ "delete files inside the destination directory if there is no corresponding file inside "+        , "the source directory"+        ])+    , Option ['h'] ["help"] (NoArg (\so -> so { so_help = True })) "shows usage information"+    ]++parseNonOption :: String -> (SyncOptions -> SyncOptions)+parseNonOption s so = so { so_nonOptions = s:(so_nonOptions so) }++toSyncOptions :: [(SyncOptions -> SyncOptions)] -> SyncOptions+toSyncOptions = foldl (flip id) defaultSyncOptions++putError :: String -> IO ()+putError = hPutStrLn stderr+++_HIDDENT_CLIENT_MODE_OPTION_ :: String+_HIDDENT_CLIENT_MODE_OPTION_ = "--hidden-client-mode-option"+++printUsageInfo :: [String] -> IO ()+printUsageInfo prefix = mapM_ putError (prefix ++ [usageInfo header optDescriptions] ++ [details])+    where+      header = unlines+          [ "sync-mht version " ++ showVersion version+          , ""+          , "Usage: sync-mht [OPTIONS..]"+          ]+      details = concat+          [ "Note: If the --remote-shell option has been provided, exactly one of the directories "+          , "must be prepended with 'remote:' - indicating a folder on the site, accessible with "+          , "the provided remote shell command."+          ]+++data Location+    = Remote FilePath+    | Local FilePath++parseFilePath :: FilePath -> Location+parseFilePath fp+    | Just rest <- stripPrefix "remote:" fp = Remote rest+    | otherwise = Local fp++run :: SyncOptions -> IO ()+run so+    | so_help so =+        printUsageInfo []+    | not (null (so_nonOptions so)) =+        printUsageInfo ["Could not understand the following options: " ++ show (so_nonOptions so)]+    | Just source <- so_source so, Just destination <- so_destination so =+        case (parseFilePath source, parseFilePath destination) of+          (Remote _, Remote _) -> printUsageInfo [doubleRemote]+          (Local source', Local destination')+              | Just _ <- so_remote so -> printUsageInfo [missingRemote]+              | otherwise -> local cs source' destination'+          (Remote source', Local destination')+              | Just remoteCmd <- so_remote so -> runParent cs remoteCmd source' destination' FromRemote+              | otherwise -> printUsageInfo [missingRemoteCmd]+          (Local source', Remote destination')+              | Just remoteCmd <- so_remote so -> runParent cs remoteCmd source' destination' ToRemote+              | otherwise -> printUsageInfo [missingRemoteCmd]+    | otherwise =+        do let missingOpts =+                intercalate ", " $ map snd $ filter ((== Nothing) . ($ so) . fst)+                [(so_source, "--source"),(so_destination, "--destination")]+           printUsageInfo ["The follwing required options: " ++ missingOpts ++ " were missing."]+    where+      cs = toClientServerOptions so+      doubleRemote = "Either the directory given in --source or --destination must be local."+      missingRemote = concat+          [ "The --remote-shell options requires that either the directory given at "+          , "--source or --destination is at remote site. (Indicated by the prefix: 'remote:')"+          ]+      missingRemoteCmd = "The --remote-shell is required when the prefix 'remote:' is used."++runChild :: IO ()+runChild =+     do streams <- openStreams stdin stdout+        child streams++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
src/main/hs/Sync/MerkleTree/Sync.hs view
@@ -8,9 +8,12 @@     , local     , parent     , openStreams+    , mkChanStreams+    , StreamPair(..)     , Direction(..)     ) where +import Control.Concurrent(newChan) import Control.Monad import Control.Monad.State import Data.Monoid@@ -24,6 +27,7 @@ import qualified Data.Serialize as SE import qualified Data.ByteString as BS import qualified System.IO.Streams as ST+import qualified System.IO.Streams.Concurrent as ST  import Sync.MerkleTree.Analyse import Sync.MerkleTree.CommTypes@@ -43,6 +47,11 @@        outStream <- ST.handleToOutputStream hOut        return $ StreamPair { sp_in = inStream, sp_out = outStream } +mkChanStreams :: IO (InputStream ByteString, OutputStream ByteString)+mkChanStreams =+    do chan <- newChan+       liftM2 (,) (ST.chanToInput chan) (ST.chanToOutput chan)+ instance Protocol RequestMonad where     queryHashReq = request . QueryHash     querySetReq = request . QuerySet@@ -61,23 +70,28 @@     = FromRemote     | ToRemote -child :: IO ()-child =-    do streams <- openStreams stdin stdout-       side <- getFromInputStream (sp_in streams)-       case side of-         Service dir clientServerOpts -> server dir clientServerOpts streams-         Client dir clientServerOpts -> client dir clientServerOpts streams+child :: StreamPair -> IO ()+child streams =+    do launchMessage <- getFromInputStream (sp_in streams)+       serverOrClient (read launchMessage) streams  parent :: StreamPair -> FilePath -> FilePath -> Direction -> ClientServerOptions -> IO () parent streams source destination direction clientServerOpts =     case direction of       FromRemote ->-        do respond (sp_out streams) $ Service source clientServerOpts-           client destination clientServerOpts streams+        do respond (sp_out streams) $ show $ mkLaunchMessage Server source+           serverOrClient (mkLaunchMessage Client destination) streams       ToRemote ->-        do respond (sp_out streams) $ Client destination clientServerOpts-           server source clientServerOpts streams+        do respond (sp_out streams) $ show $ mkLaunchMessage Client destination+           serverOrClient (mkLaunchMessage Server source) streams+    where+      mkLaunchMessage side dir =+          LaunchMessage+          { lm_dir = dir+          , lm_clientServerOptions = clientServerOpts+          , lm_protocolVersion = thisProtocolVersion+          , lm_side = side+          }  respond :: (Show a, SE.Serialize a) => OutputStream ByteString -> a -> IO () respond os = mapM_ (flip ST.write os . Just) . (:[BS.empty]) . SE.encode@@ -88,10 +102,19 @@        destinationDir <- liftM (mkTrie 0) $ analyseDirectory destination (cs_ignore cs) Root        evalStateT (abstractClient cs destination destinationDir) (startServerState source sourceDir) -server :: FilePath -> ClientServerOptions -> StreamPair -> IO ()-server fp cs streams =-    do dir <- analyseDirectory fp (cs_ignore cs) Root-       evalStateT loop (startServerState fp $ mkTrie 0 dir)+serverOrClient :: LaunchMessage -> StreamPair -> IO ()+serverOrClient lm streams+    | lm_protocolVersion lm == thisProtocolVersion =+        let side =+                case lm_side lm of+                  Server -> server+                  Client -> client (lm_clientServerOptions lm)+        in do entries <- analyseDirectory (lm_dir lm) (cs_ignore $ lm_clientServerOptions lm) Root+              side entries (lm_dir lm) streams+    | otherwise = fail "Incompatible sync-mht versions."++server :: [Entry] -> FilePath -> StreamPair -> IO ()+server entries fp streams = evalStateT loop (startServerState fp $ mkTrie 0 entries)     where        serverRespond = liftIO . respond (sp_out streams)        loop =@@ -104,8 +127,6 @@                 Log t -> logReq t >>= serverRespond >> loop                 Terminate -> terminateReq >>= serverRespond >> return () -client :: FilePath -> ClientServerOptions -> StreamPair -> IO ()-client fp cs streams =-    do dir <- analyseDirectory fp (cs_ignore cs) Root-       runRequestMonad (sp_in streams) (sp_out streams) $ abstractClient cs fp $ mkTrie 0 dir-+client :: ClientServerOptions -> [Entry] -> FilePath -> StreamPair -> IO ()+client cs entries fp streams =+    runRequestMonad (sp_in streams) (sp_out streams) $ abstractClient cs fp $ mkTrie 0 entries
+ src/main/hs/Sync/MerkleTree/Test.hs view
@@ -0,0 +1,183 @@+module Sync.MerkleTree.Test where++import Control.Concurrent+import Control.Monad+import Data.Ix+import Data.List+import Data.Time.Calendar+import Data.Time.Clock+import Sync.MerkleTree.Analyse+import Sync.MerkleTree.Run+import System.Directory+import System.FilePath+import System.IO+import System.IO.Error+import System.IO.Temp+import System.Posix.Files+import System.Random+import qualified Distribution.TestSuite as TS++mkTestInstance :: String -> IO TS.Result -> TS.TestInstance+mkTestInstance name run = ti+    where+      ti =+          TS.TestInstance+          { TS.run = liftM TS.Finished (catchIOError run $ return . TS.Fail . show)+          , TS.name = name+          , TS.tags = []+          , TS.options = []+          , TS.setOption = setOpt+          }+      setOpt _ _ = Right ti++tests :: IO [TS.Test]+tests = return $+    [ TS.testGroup "all" $+        [ TS.Test testOptions+        ] ++ (map TS.Test testSync)+    ]++testOptions :: TS.TestInstance+testOptions = mkTestInstance "testOptions" $+    let prepare add update delete go =+            withSystemTempDirectory "sync-mht" $ \testDir ->+                do let srcDir = testDir </> "src"+                       destDir = testDir </> "dest"+                   createDirectory srcDir+                   createDirectory destDir+                   writeFile (srcDir </> "same.txt") "test"+                   copyFile (srcDir </> "same.txt") (destDir </> "same.txt")+                   writeFile (srcDir </> "changed.txt") "test"+                   writeFile (destDir </> "changed.txt") "testB"+                   writeFile (srcDir </> "added.txt") "test"+                   writeFile (destDir </> "deleted.txt") "testB"+                   run $+                       SyncOptions+                       { so_source = Just $ srcDir+                       , so_destination = Just $ destDir+                       , so_remote = Nothing+                       , so_ignore = []+                       , so_add = add+                       , so_update = update+                       , so_delete = delete+                       , so_help = False+                       , so_nonOptions = []+                       }+                   True <- liftM (=="test") $ readFile (srcDir </> "same.txt")+                   True <- liftM (=="test") $ readFile (srcDir </> "changed.txt")+                   True <- liftM (=="test") $ readFile (srcDir </> "added.txt")+                   go srcDir destDir+    in do prepare True False False $ \srcDir destDir ->+              do True <- liftM (=="test") $ readFile (destDir </> "same.txt")+                 True <- liftM (=="testB") $ readFile (destDir </> "changed.txt")+                 True <- liftM (=="test") $ readFile (destDir </> "added.txt")+                 True <- liftM (=="testB") $ readFile (destDir </> "deleted.txt")+                 return ()+          prepare False True False $ \srcDir destDir ->+              do True <- liftM (=="test") $ readFile (destDir </> "same.txt")+                 True <- liftM (=="test") $ readFile (destDir </> "changed.txt")+                 True <- liftM (=="testB") $ readFile (destDir </> "deleted.txt")+                 return ()+          prepare False False True $ \srcDir destDir ->+              do True <- liftM (=="test") $ readFile (destDir </> "same.txt")+                 True <- liftM (=="testB") $ readFile (destDir </> "changed.txt")+                 False <- doesFileExist (destDir </> "deleted.txt")+                 return ()+          return TS.Pass++testSync :: [TS.TestInstance]+testSync = +    flip map [0,1,2] $ \simulate -> mkTestInstance ("testSync"++ show simulate) $+        do forM [1..50] $ \_ ->+               withSystemTempDirectory "sync-mht" $ \testDir ->+                   do mkRandomDir 2 [testDir </> "src", testDir </> "src-backup"]+                      mkRandomDir 2 [testDir </> "target"]+                      let sourcePrefix+                              | simulate == 1 = "remote:"+                              | otherwise = ""+                          targetPrefix+                              | simulate == 2 = "remote:"+                              | otherwise = ""+                      run $+                          SyncOptions+                          { so_source = Just $ (sourcePrefix ++) testDir </> "src"+                          , so_destination = Just $ (targetPrefix ++) testDir </> "target"+                          , so_remote =+                               case simulate of+                                 0 -> Nothing+                                 _ -> Just Simulate+                          , so_ignore = []+                          , so_add = True+                          , so_update = True+                          , so_delete = True+                          , so_help = False+                          , so_nonOptions = []+                          }+                      areDirsEqual (testDir </> "src") (testDir </> "target")+                      areDirsEqual (testDir </> "src") (testDir </> "src-backup")+           return TS.Pass++data FileOrDir+    = File+    | Dir+    deriving (Eq, Ix, Enum, Bounded, Ord, Show)++instance Random FileOrDir where+    random = randomR (minBound, maxBound)+    randomR (l, u) g =+       let (i, g) = randomR (fromEnum l, fromEnum u) g+       in (toEnum i, g)++utcTimeFrom :: Integer -> UTCTime+utcTimeFrom x = UTCTime (fromGregorian 2015 07 29) (fromInteger x)++mkRandomDir :: Integer -> [FilePath] -> IO ()+mkRandomDir md fps =+   do forM fps createDirectory+      names <- distinctNames 6+      forM_ names $ \n ->+          do m <- randomRIO (0,1)+             case toEnum m of+               Dir | md > 0 -> mkRandomDir (md - 1) $ map (</> n) fps+                   | otherwise -> return ()+               File ->+                   do d <- randomRIO (1,4)+                      forM_ fps $ \fp ->+                          do writeFile (fp </> n) (show d)+                             setModificationTime (fp </> n) (utcTimeFrom d)+++areDirsEqual :: FilePath -> FilePath -> IO ()+areDirsEqual fp1 fp2 =+   do files1 <- liftM (sort . filter isRealFile) $ getDirectoryContents fp1+      files2 <- liftM (sort . filter isRealFile) $ getDirectoryContents fp2+      case () of+        () | files1 == files2 -> forM_ files1 $ \f -> areEntriesEqual (fp1 </> f) (fp2 </> f)+           | otherwise -> fail $ "Unequal: " ++ show (fp1, fp2, files1, files2)++areEntriesEqual :: FilePath -> FilePath -> IO ()+areEntriesEqual f1 f2 =+  do s1 <- getFileStatus f1+     s2 <- getFileStatus f2+     case () of+        () | isDirectory s1, isDirectory s2 -> areDirsEqual f1 f2+           | isRegularFile s1, isRegularFile s2 ->+               do c1 <- readFile f1+                  c2 <- readFile f2+                  unless (c1 == c2) $fail $ "Unequal files: " ++ show (f1, f2, c1, c2)+           | otherwise ->+               fail $ show (f1, f2, isDirectory s1, isDirectory s2, isRegularFile s1, isRegularFile s2)+++-- | @distinctNames k@ creates k distinct file names+distinctNames :: Integer -> IO [String]+distinctNames k = retry+    where+      isDistinct names = null $ filter hasDuplicate $ group $ sort names+      hasDuplicate = (/= 1) . length+      mkName _ = liftM (:[]) $ randomRIO ('a','m')+      retry =+          do result <- forM [1..k] mkName+             if isDistinct result+             then return result+             else retry
src/main/hs/Sync/MerkleTree/Types.hs view
@@ -60,13 +60,21 @@ instance Ord Entry where     compare = comparing withLevel         where-          level Root = 0 :: Int-          level (Path _ p) = 1 + level p-          withLevel entry =+          withLevel entry = (levelOf entry, toEither entry)+          toEither entry =               case entry of-                DirectoryEntry p -> (level p, Right p)-                FileEntry f -> (level $ f_name f, Left f)+                DirectoryEntry p -> Right p+                FileEntry f -> Left f +levelOf :: Entry -> Int+levelOf e =+    case e of+      DirectoryEntry p -> level p+      FileEntry f -> level $ f_name f+    where+      level Root = 0+      level (Path _ p) = 1 + level p+ instance HasDigest Entry where     digest = hash . SE.encode @@ -76,4 +84,3 @@ instance SE.Serialize SerText where     get = SE.get >>= either (fail . show) (return . SerText) . TE.decodeUtf8'     put = SE.put . TE.encodeUtf8 . unSerText-
src/main/hs/Sync/MerkleTree/Util/RequestMonad.hs view
@@ -39,7 +39,6 @@ import Data.IORef(IORef,newIORef,modifyIORef,readIORef) import Data.Monoid(Monoid, mempty, mappend) import Data.Serialize(Serialize)-import System.IO(hPutStrLn,stderr) import System.IO.Streams(InputStream, OutputStream) import qualified Data.ByteString as BS import qualified Data.Serialize as SE@@ -162,9 +161,7 @@           do x <- getFromInputStream input              modifyIORef recvIdx (+1)              expected <- readIORef recvIdx-             unless (expected == i) $-                 do hPutStrLn stderr $ "Expected " ++ (show i) ++ " but got " ++ show expected-                    fail $ "Expected " ++ show i ++ " but got " ++ show expected+             unless (expected == i) $ fail ("Expected " ++ (show i) ++ " but got " ++ show expected)              queueRequests sq $ cont x       Split (SplitState xs z cont) -> loop cont z xs []       Return x -> return $ Return x
sync-mht.cabal view
@@ -6,9 +6,9 @@ maintainer: Emin Karayel <me@eminkarayel.de> category: Utility extra-doc-files: README.md-cabal-version: >=1.10+cabal-version: >= 1.18 build-type: Simple-version: 0.2.1.1+version: 0.3.0.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,46 @@     location: https://github.com/ekarayel/sync-mht --recursive source-repository this     type: git-    tag: 0.2.1.1+    tag: 0.3.0.0     location: https://github.com/ekarayel/sync-mht --recursive+test-suite main+    type: detailed-0.9+    test-module: Sync.MerkleTree.Test+    other-modules:+        Sync.MerkleTree.Analyse+        Sync.MerkleTree.Client+        Sync.MerkleTree.CommTypes+        Sync.MerkleTree.Server+        Sync.MerkleTree.Sync+        Sync.MerkleTree.Run+        Sync.MerkleTree.Trie+        Sync.MerkleTree.Types+        Sync.MerkleTree.Util.RequestMonad+        Paths_sync_mht+    hs-source-dirs: src/main/hs+    default-language: Haskell2010+    build-depends: +        base >=4.7 && <4.8+        , unix >=2.7 && <2.8+        , directory >=1.2.3 && <1.3+        , filepath >=1.3 && <1.4+        , process >=1.2 &&  <1.3+        , cryptohash >=0.11 && <0.12+        , byteable >=0.1 && <0.2+        , array >=0.5 && <0.6+        , containers >=0.5 && <0.6+        , text >=1.2 && <1.3+        , bytestring >=0.10 && <0.11+        , base16-bytestring >=0.1 && <0.2+        , cereal >= 0.4 && < 0.5+        , io-streams >= 1.2 && <1.3+        , transformers >= 0.4 && < 0.5+        , regex-compat >= 0.95 && < 0.96+        , mtl >= 2.2 && < 2.3+        , Cabal >= 1.18 && <= 1.19+        , time >= 1.4 && < 1.5+        , random >= 1.0 && < 1.1+        , temporary >= 1.2 executable sync-mht     main-is: Main.hs     other-modules:@@ -39,6 +77,7 @@         Sync.MerkleTree.CommTypes         Sync.MerkleTree.Server         Sync.MerkleTree.Sync+        Sync.MerkleTree.Run         Sync.MerkleTree.Trie         Sync.MerkleTree.Types         Sync.MerkleTree.Util.RequestMonad@@ -46,7 +85,7 @@     build-depends:          base >=4.7 && <4.8         , unix >=2.7 && <2.8-        , directory >=1.2 && <1.3+        , directory >=1.2.3 && <1.3         , filepath >=1.3 && <1.4         , process >=1.2 &&  <1.3         , cryptohash >=0.11 && <0.12@@ -59,6 +98,11 @@         , cereal >= 0.4 && < 0.5         , io-streams >= 1.2 && <1.3         , transformers >= 0.4 && < 0.5+        , regex-compat >= 0.95 && < 0.96         , mtl >= 2.2 && < 2.3+        , Cabal >= 1.18 && <= 1.19+        , time >= 1.4 && < 1.5+        , random >= 1.0 && < 1.1+        , temporary >= 1.2     hs-source-dirs: src/main/hs     default-language: Haskell2010