sync-mht 0.3.3.0 → 0.3.4.0
raw patch · 3 files changed
+118/−65 lines, 3 files
Files
- src/main/hs/Sync/MerkleTree/Run.hs +58/−54
- src/main/hs/Sync/MerkleTree/Test.hs +58/−9
- sync-mht.cabal +2/−2
src/main/hs/Sync/MerkleTree/Run.hs view
@@ -3,15 +3,17 @@ module Sync.MerkleTree.Run where import Control.Concurrent-import System.Process-import System.IO-import System.Console.GetOpt-import Paths_sync_mht (version)+import Control.Monad import Data.List import Data.Version (showVersion)-+import Paths_sync_mht (version)+import System.Console.GetOpt+import System.IO+import System.Process import Sync.MerkleTree.CommTypes import Sync.MerkleTree.Sync+import qualified Data.Text as T+import qualified Data.Text.IO as T data RemoteCmd = RemoteCmd String@@ -23,6 +25,7 @@ , so_destination :: Maybe FilePath , so_remote :: Maybe RemoteCmd , so_ignore :: [String]+ , so_boring :: [FilePath] , so_add :: Bool , so_update :: Bool , so_delete :: Bool@@ -37,6 +40,7 @@ , so_destination = Nothing , so_remote = Nothing , so_ignore = []+ , so_boring = [] , so_add = False , so_update = False , so_delete = False@@ -44,39 +48,38 @@ , so_nonOptions = [] } -toClientServerOptions :: SyncOptions -> ClientServerOptions+toClientServerOptions :: SyncOptions -> IO ClientServerOptions toClientServerOptions so =- ClientServerOptions- { cs_add = so_add so- , cs_update = so_update so- , cs_delete = so_delete so- , cs_ignore = so_ignore so- }+ do let parseBoringFile = map T.unpack . filter noComment . map T.strip . T.lines+ noComment s = not (T.null s || ("#" `T.isPrefixOf` s))+ ignoreFromBoringFiles <-+ forM (so_boring so) $ liftM parseBoringFile . T.readFile+ return $+ ClientServerOptions+ { cs_add = so_add so+ , cs_update = so_update so+ , cs_delete = so_delete so+ , cs_ignore = (concat ignoreFromBoringFiles) ++ (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)"+ "source directory" , Option ['d'] ["destination"] (ReqArg (\fp so -> so { so_destination = Just fp }) "DIR")- "directory to copy files to (destination) (this option is required)"+ "destination directory" , 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"- ])+ "synchroize with a remote-site (see below)"+ , Option ['i'] ["ignore"] (ReqArg (\fp so -> so { so_ignore = fp:(so_ignore so) }) "REGEX")+ "ignore entries matching the given regex"+ , Option ['b'] ["boring"] (ReqArg (\fp so -> so { so_boring = fp:(so_boring so) }) "PATH")+ "ignore entries matching the regexes in the given file"+ , Option ['a'] ["add"] (NoArg (\so -> so { so_add = True }))+ "copy additional files from the source directory"+ , Option ['u'] ["update"] (NoArg (\so -> so { so_update = True }))+ "overwrite existing files"+ , Option [] ["delete"] (NoArg (\so -> so { so_delete = True }))+ "delete superfluos files in the destination directory" , Option ['h'] ["help"] (NoArg (\so -> so { so_help = True })) "shows usage information" ] @@ -89,26 +92,25 @@ 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..]" , ""- , "Usage: sync-mht [OPTIONS..]"+ , "Fast incremental file transfer using Merkle-Hash-Trees (Version: "+ ++ showVersion version ++ ")" ]- 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."+ details = unlines+ [ "Note: The argument to the --remote-shell option should be a CMD running sync-mht"+ , "with a remote command execution tool (like ssh or docker). If given 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@@ -123,26 +125,28 @@ | so_help so = printUsageInfo [] | not (null (so_nonOptions so)) =- printUsageInfo ["Could not understand the following options: " ++ show (so_nonOptions so)]+ printUsageInfo ["Unrecognized options: " ++ intercalate ", " (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]+ do cs <- toClientServerOptions 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."]+ printUsageInfo ["The options " ++ missingOpts ++ " are required."] 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 "
src/main/hs/Sync/MerkleTree/Test.hs view
@@ -32,11 +32,58 @@ tests :: IO [TS.Test] tests = return $- [ TS.testGroup "all" $- [ TS.Test testOptions- ] ++ (map TS.Test testSync)+ [ TS.testGroup "all" $ map TS.Test $+ [ testOptions ]+ ++ testIgnoreBoring+ ++ testSync ] +testIgnoreBoring :: [TS.TestInstance]+testIgnoreBoring =+ let testCase ign bor = withSystemTempDirectory "sync-mht" $ \fp ->+ do let srcDir = fp </> "src"+ destDir = fp </> "dest"+ createDirectory srcDir+ createDirectory $ srcDir </> "a"+ createDirectory destDir+ writeFile (fp </> ".boring") $ unlines $+ [ "#baz"+ , ""+ , "foo"+ , "^bar"+ ]+ writeFile (srcDir </> "added.txt") "testA"+ writeFile (srcDir </> "added-bar.txt") "testB"+ writeFile (srcDir </> "baz") "testC"+ writeFile (srcDir </> "bar-ignore.txt") "testD"+ writeFile (srcDir </> "a" </> "bar") "testE"+ writeFile (srcDir </> "some-foo.txt") "testF"+ writeFile (srcDir </> "a" </> "foo") "testG"+ run $+ SyncOptions+ { so_source = Just $ srcDir+ , so_destination = Just $ destDir+ , so_remote = Nothing+ , so_ignore = ign+ , so_boring = map (const $ fp </> ".boring") bor+ , so_add = True+ , so_update = True+ , so_delete = True+ , so_help = False+ , so_nonOptions = []+ }+ True <- liftM (=="testA") $ readFile (destDir </> "added.txt")+ True <- liftM (=="testB") $ readFile (destDir </> "added-bar.txt")+ True <- liftM (=="testC") $ readFile (destDir </> "baz")+ False <- doesFileExist (destDir </> "bar-ignore.txt")+ True <- liftM (=="testE") $ readFile (destDir </> "a" </> "bar")+ False <- doesFileExist (destDir </> "some-foo.txt")+ False <- doesFileExist (destDir </> "a" </> "foo")+ return TS.Pass+ in [ mkTestInstance "testIgnore" $ testCase ["foo","^bar"] []+ , mkTestInstance "testBoring" $ testCase [] [()]+ ]+ testOptions :: TS.TestInstance testOptions = mkTestInstance "testOptions" $ let prepare add update delete go =@@ -57,6 +104,7 @@ , so_destination = Just $ destDir , so_remote = Nothing , so_ignore = []+ , so_boring = [] , so_add = add , so_update = update , so_delete = delete@@ -86,12 +134,12 @@ return TS.Pass testSync :: [TS.TestInstance]-testSync = +testSync = flip map [0,1,2] $ \simulate -> mkTestInstance ("testSync"++ show simulate) $- do forM [1..50] $ \_ ->+ do forM [1..10] $ \_ -> withSystemTempDirectory "sync-mht" $ \testDir ->- do mkRandomDir 2 [testDir </> "src", testDir </> "src-backup"]- mkRandomDir 2 [testDir </> "target"]+ do mkRandomDir 3 [testDir </> "src", testDir </> "src-backup"]+ mkRandomDir 3 [testDir </> "target"] let sourcePrefix | simulate == 1 = "remote:" | otherwise = ""@@ -107,6 +155,7 @@ 0 -> Nothing _ -> Just Simulate , so_ignore = []+ , so_boring = [] , so_add = True , so_update = True , so_delete = True@@ -166,8 +215,8 @@ 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)-+ fail $ show+ (f1, f2, isDirectory s1, isDirectory s2, isRegularFile s1, isRegularFile s2) -- | @distinctNames k@ creates k distinct file names distinctNames :: Integer -> IO [String]
sync-mht.cabal view
@@ -8,7 +8,7 @@ extra-doc-files: README.md cabal-version: >= 1.22 build-type: Simple-version: 0.3.3.0+version: 0.3.4.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.3.0+ tag: 0.3.4.0 location: https://github.com/ekarayel/sync-mht --recursive test-suite main type: detailed-0.9