diff --git a/src/main/hs/Sync/MerkleTree/Run.hs b/src/main/hs/Sync/MerkleTree/Run.hs --- a/src/main/hs/Sync/MerkleTree/Run.hs +++ b/src/main/hs/Sync/MerkleTree/Run.hs @@ -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 " diff --git a/src/main/hs/Sync/MerkleTree/Test.hs b/src/main/hs/Sync/MerkleTree/Test.hs --- a/src/main/hs/Sync/MerkleTree/Test.hs +++ b/src/main/hs/Sync/MerkleTree/Test.hs @@ -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] diff --git a/sync-mht.cabal b/sync-mht.cabal --- a/sync-mht.cabal +++ b/sync-mht.cabal @@ -8,7 +8,7 @@ extra-doc-files: README.md cabal-version: >= 1.22 build-type: Simple -version: 0.3.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