pushme 1.1.0 → 1.4.0
raw patch · 3 files changed
+290/−268 lines, 3 filesdep +optparse-applicativedep −cabal-file-thdep −cmdargsdep −stringable
Dependencies added: optparse-applicative
Dependencies removed: cabal-file-th, cmdargs, stringable
Files
- Main.hs +226/−217
- README.md +60/−45
- pushme.cabal +4/−6
Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-}@@ -11,12 +12,13 @@ import Control.Concurrent.ParallelIO ( stopGlobalPool, parallel ) import Control.DeepSeq ( NFData(..) ) import Control.Exception ( SomeException, Exception, catch )-import Control.Lens hiding ( value )+import Control.Lens import Control.Monad ( void, liftM2, (>=>) ) import Data.Aeson ( ToJSON(..), FromJSON(..) ) import Data.Aeson.TH ( deriveJSON ) import qualified Data.ByteString.Char8 as BC ( writeFile, readFile ) import Data.Char ( isDigit )+import Data.Data ( Data ) import Data.Foldable ( for_ ) import Data.Function ( on ) import Data.Function.Pointless ( (.:) )@@ -24,21 +26,25 @@ import qualified Data.Map as M ( Map, fromList, lookup ) import Data.Maybe ( fromMaybe, isNothing, isJust, fromJust ) import Data.Monoid ( Monoid(mconcat), (<>) )-import Data.Stringable as S ( Stringable(fromString, toString) )-import Data.Text.Format ( format )+import qualified Data.Text.Format+#if MIN_VERSION_shelly(1, 0, 0)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy (toStrict)+#else import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T+#endif import Data.Time.Clock ( getCurrentTime ) import Data.Time.Format ( readTime, formatTime ) import Data.Time.LocalTime+import Data.Typeable ( Typeable ) import Data.Yaml ( encode, decode )-import Debug.Trace as D ()-import qualified Distribution.PackageDescription.TH as Pkg import Filesystem ( isFile, getHomeDirectory ) import GHC.Conc ( setNumCapabilities, getNumProcessors )+import Options.Applicative import Prelude hiding (FilePath, catch) import Shelly hiding (find)-import System.Console.CmdArgs import System.Environment ( getArgs, withArgs ) import System.IO ( stderr ) import System.IO.Storage ( withStore, putValue, getValue )@@ -64,68 +70,68 @@ instance ToJSON FilePath where toJSON = toJSON . toTextIgnore++format = (toStrict .) . Data.Text.Format.format version :: String-version = $(Pkg.packageVariable (Pkg.pkgVersion . Pkg.package))+version = "1.3.0" copyright :: String-copyright = "2012"+copyright = "2013" pushmeSummary :: String pushmeSummary = "pushme v" ++ version ++ ", (C) John Wiegley " ++ copyright -data PushmeOpts = PushmeOpts { jobs :: Int- , dryRun :: Bool- , noSync :: Bool- , copyAll :: Bool- , loadRevs :: Bool- , stores :: Bool- , ssh :: String- , filesets :: String- , classes :: String- , verbose :: Bool- , quiet :: Bool- , debug :: Bool- , arguments :: [String] }- deriving (Data, Typeable, Show, Eq)+data PushmeOpts = PushmeOpts+ { jobs :: Int+ , dryRun :: Bool+ , noSync :: Bool+ , copyAll :: Bool+ , loadRevs :: Bool+ , stores :: Bool+ , ssh :: String+ , filesets :: String+ , classes :: String+ , verbose :: Bool+ , quiet :: Bool+ , debug :: Bool+ , cliArgs :: [String]+ } deriving (Data, Typeable, Show, Eq) -pushmeOpts :: PushmeOpts+pushmeOpts :: Parser PushmeOpts pushmeOpts = PushmeOpts- { jobs = def &= name "j" &= typ "INT"- &= help "Run INT concurrent finds at once (default: 2)"- , dryRun = def &= name "n"- &= help "Don't take any actions"- , noSync = def &= name "N"- &= help "Don't even attempt a dry-run sync"- , copyAll = def &= help "For git-annex directories, copy all files"- , loadRevs = def &= name "L"- &= help "Load latest snapshot revs from disk"- , stores = def &= help "Show all the stores know to pushme"- , ssh = def &= help "Use a specific ssh command"- , filesets = def &= name "f"- &= help "Synchronize the given fileset(s) (comma-sep)"- , classes = def &= name "c"- &= help "Filesets classes to synchronize (comma-sep)"- , verbose = def &= name "v"- &= help "Report progress verbosely"- , quiet = def &= name "q"- &= help "Be a little quieter"- , debug = def &= name "D"- &= help "Report debug information"- , arguments = def &= args &= typ "ARGS..." }-- &= summary pushmeSummary- &= program "pushme"- &= help "Synchronize data from one machine to another"+ <$> option (short 'j' <> long "jobs" <> value 1 <>+ help "Run INT concurrent finds at once (default: 1)")+ <*> switch (short 'n' <> long "dry-run" <>+ help "Don't take any actions")+ <*> switch (short 'N' <> long "no-sync" <>+ help "Don't even attempt a dry-run sync")+ <*> switch (long "copy-all" <>+ help "For git-annex directories, copy all files")+ <*> switch (short 'L' <> long "load-revs" <>+ help "Load latest snapshot revs from disk")+ <*> switch (long "stores" <>+ help "Show all the stores know to pushme")+ <*> strOption (long "ssh" <> value "" <>+ help "Use a specific ssh command")+ <*> strOption (short 'f' <> long "filesets" <> value "" <>+ help "Synchronize the given fileset(s) (comma-sep)")+ <*> strOption (short 'c' <> long "classes" <> value "" <>+ help "Filesets classes to synchronize (comma-sep)")+ <*> switch (short 'v' <> long "verbose" <> help "Report progress verbosely")+ <*> switch (short 'q' <> long "quiet" <> help "Be a little quieter")+ <*> switch (short 'D' <> long "debug" <> help "Report debug information")+ <*> arguments Just (metavar "ARGS") -- | A 'Fileset' is a logical grouping of files, with an assigned class and -- priority. It may also have an associated filter. -data Fileset = Fileset { _filesetName :: Text- , _filesetClass :: Text- , _filesetPriority :: Int- , _filesetReportMissing :: Bool }- deriving (Show, Eq)+data Fileset = Fileset+ { _filesetName :: Text+ , _filesetClass :: Text+ , _filesetPriority :: Int+ , _filesetReportMissing :: Bool+ } deriving (Show, Eq) makeLenses ''Fileset @@ -136,15 +142,16 @@ -- are many 'Container' instances. When a fileset is synchronized, it means -- copying it by some means between different containers. -data Container = Container { _containerFileset :: Text- , _containerStore :: Text- , _containerPath :: FilePath- , _containerPoolPath :: Maybe FilePath- , _containerRecurse :: Bool- , _containerIsAnnex :: Bool- , _containerLastRev :: Maybe Int- , _containerLastSync :: Maybe LocalTime }- deriving (Show, Eq)+data Container = Container+ { _containerFileset :: Text+ , _containerStore :: Text+ , _containerPath :: FilePath+ , _containerPoolPath :: Maybe FilePath+ , _containerRecurse :: Bool+ , _containerIsAnnex :: Bool+ , _containerLastRev :: Maybe Int+ , _containerLastSync :: Maybe LocalTime+ } deriving (Show, Eq) makeLenses ''Container @@ -158,19 +165,21 @@ -- container is done by copying over incremental snapshots. Note that -- 'storeHostName' refers to name used by SSH. -data Store = Store { _storeName :: Text- , _storeHostRe :: Text- , _storeSelfRe :: Text- , _storeUserName :: Text- , _storeIsPrimary :: Bool- , _storeZfsPool :: Maybe Text- , _storeZfsPath :: Maybe FilePath- -- 'storeTargets' is a list of (StoreName, [FilesetName]),- -- where the containers involved are looked up from the- -- Container list by the Store/Fileset name pair for both- -- source and target.- , _storeTargets :: [(Text, [Text])] }- deriving (Show, Eq)+data Store = Store+ { _storeName :: Text+ , _storeHostRe :: Text+ , _storeSelfRe :: Text+ , _storeUserName :: Text+ , _storeIsPrimary :: Bool+ , _storeZfsPool :: Maybe Text+ , _storeZfsPath :: Maybe FilePath+ -- 'storeTargets' is a list of (StoreName, [FilesetName]), where the+ -- containers involved are looked up from the Container list by the+ -- Store/Fileset name pair for both source and target.+ , _storeTargets :: [(Text, [Text])]+ , _storeAnnexName :: Text+ , _storeAnnexFlags :: [(Text, [(Text, [Text])])]+ } deriving (Show, Eq) makeLenses ''Store @@ -179,61 +188,38 @@ instance NFData Store where rnf a = a `seq` () -data Info = Info { _infoHostName :: Text- , _infoStore :: Store- , _infoContainer :: Container }- deriving (Show, Eq)+data Info = Info+ { _infoHostName :: Text+ , _infoStore :: Store+ , _infoContainer :: Container+ } deriving (Show, Eq) makeLenses ''Info -data Binding = Binding { _bindingThis :: Info- , _bindingThat :: Info- , _bindingFileset :: Fileset }- deriving (Show, Eq)+data Binding = Binding+ { _bindingThis :: Info+ , _bindingThat :: Info+ , _bindingFileset :: Fileset+ } deriving (Show, Eq) makeLenses ''Binding--data PushmeException = PushmeException deriving (Show, Typeable)--instance Exception PushmeException main :: IO ()-main = do- mainArgs <- getArgs- opts <- withArgs (if null mainArgs then [] else mainArgs)- (cmdArgs pushmeOpts)- procs <- GHC.Conc.getNumProcessors- _ <- GHC.Conc.setNumCapabilities $- case jobs opts of 0 -> min procs 1; x -> x-- runPushme opts `catch` \(_ :: PushmeException) -> return ()- `catch` \(ex :: SomeException) -> error (show ex)--testme :: IO ()-testme = runPushme- PushmeOpts { jobs = 1- , dryRun = True- , noSync = True- , copyAll = False- , loadRevs = True- , stores = False- , ssh = ""- , filesets = ""- , classes = ""- , verbose = True- , quiet = False- , debug = True- , arguments = ["@data", "data/titan"] }+main = execParser opts >>= \o -> do+ _ <- GHC.Conc.setNumCapabilities (jobs o)+ runPushme o+ stopGlobalPool+ where+ opts = info (helper <*> pushmeOpts)+ (fullDesc <> progDesc "" <> header pushmeSummary) runPushme :: PushmeOpts -> IO () runPushme opts = do- let level- | debug opts = DEBUG- | verbose opts = INFO- | otherwise = NOTICE+ let level | debug opts = DEBUG+ | verbose opts = INFO+ | otherwise = NOTICE h <- (`setFormatter` tfLogFormatter "%H:%M:%S" "$time - [$prio] $msg") <$> streamHandler System.IO.stderr level- removeAllHandlers updateGlobalLogger "pushme" (setLevel level) updateGlobalLogger "pushme" (addHandler h)@@ -250,13 +236,11 @@ pushmeCommand opts sts fsets cts - stopGlobalPool- pushmeCommand :: PushmeOpts -> [Store] -> [Fileset] -> [Container] -> IO () pushmeCommand opts sts fsets cts | stores opts =- let fss = fromString $ filesets opts- cls = fromString $ classes opts+ let fss = T.pack $ filesets opts+ cls = T.pack $ classes opts sorted = sortBy (compare `on` (^._2.filesetPriority)) $ filter@@ -264,16 +248,18 @@ (T.null fss || matchText fss (fs^.filesetName)) && (T.null cls || matchText cls (fs^.filesetClass))) $ map (\x -> (x, findFileset (x^.containerFileset) fsets)) $- case arguments opts of+ case cliArgs opts of [] -> cts- xs -> nub $ mconcat $ map (\st -> containersForStore st cts) $- map (\n -> findStore (fromString n) sts) xs+ xs -> nub $ mconcat $+ map (\n -> containersForStore (findStore (T.pack n) sts)+ cts) xs in for_ sorted $ \(ct, _) -> putStrLn $- printf "%-12s %-38.38s %19s %5d"- (toString (ct^.containerStore))- (toString (toTextIgnore (ct^.containerPath)))+ printf "%-12s %-12s %-28.38s %19s %5d"+ (T.unpack (ct^.containerStore))+ (T.unpack (ct^.containerFileset))+ (T.unpack (toTextIgnore (ct^.containerPath))) (maybe "" (formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S") (ct^.containerLastSync)) (fromMaybe 0 (ct^.containerLastRev))@@ -282,14 +268,14 @@ here <- shelly $ silently $ cmd "hostname" let this = findStore here sts - shelly $ debugL $ here <> " -> " <> fromString (show this)+ shelly $ debugL $ here <> " -> " <> T.pack (show this) cts' <- foldl' (\acc host -> do innerCts <- acc updatedCts <- shelly $- processHost (here,this) sts fsets innerCts (fromString host)+ processHost (here,this) sts fsets innerCts (T.pack host) -- This can get expensive fast, but the number of containers -- involved should never be large. The idea is to gather the most -- recent data from all updated containers, until we're back to a@@ -297,7 +283,7 @@ -- because of the parallel processing. return $ map (\ct -> foldl' mergeContainers ct updatedCts) innerCts)- (return cts) (arguments opts)+ (return cts) (cliArgs opts) unless (dryRun opts || noSync opts) $ writeDataFile ".pushme/containers.yml" cts'@@ -326,13 +312,13 @@ else (defaultSelf, thereRaw) that = findStore there sts - debugL $ (this^.storeHostRe) <> " -> " <> fromString (show this)- debugL $ there <> " -> " <> fromString (show that)+ debugL $ (this^.storeHostRe) <> " -> " <> T.pack (show this)+ debugL $ there <> " -> " <> T.pack (show that) - noticeL $ format "Synchronizing {} -> {}"- [this^.storeName , that^.storeName]+ noticeL $ format "\ESC[31mSynchronizing {} -> {}\ESC[0m"+ [this^.storeName, that^.storeName] - case lookup (that^.storeName) (this^.storeTargets) of+ xs <- case lookup (that^.storeName) (this^.storeTargets) of Nothing -> warningL "Nothing to do" >> return [] Just xs -> do@@ -345,10 +331,14 @@ return . mconcat =<< (liftIO . parallel . map (shelly . syncContainers) $ bindings) + noticeL $ format "\ESC[32mDone synchronizing {} -> {}\ESC[0m"+ [this^.storeName , that^.storeName]+ return xs+ where filterAndSortBindings bindings = do- fss <- fromString <$> getOption filesets- cls <- fromString <$> getOption classes+ fss <- T.pack <$> getOption filesets+ cls <- T.pack <$> getOption classes return $ sortBy (compare `on` (^.bindingFileset.filesetPriority)) $ filter@@ -431,7 +421,7 @@ patterns = map regexToGlob . filter (`notElem` ["*", "*/", ".*", ".*/"]) . map stringify . T.lines $ optsText- patMatch f p = toString f =~ toString p+ patMatch f p = T.unpack f =~ T.unpack p files' = foldl' (\acc x -> if any (patMatch x) patterns@@ -448,7 +438,7 @@ let bnd = case find (\x -> x^.filesetName == n) fsets of Nothing ->- error $ toString $ "Could not find fileset: " <> n+ error $ T.unpack $ "Could not find fileset: " <> n Just fs -> Binding { _bindingThis =@@ -481,7 +471,7 @@ let p' = toTextIgnore $ p </> fromText ".zfs" </> fromText "snapshot" u = info^.infoStore.storeUserName h = info^.infoHostName- listing <- sort <$> map (read . toString) <$>+ listing <- sort <$> map (read . T.unpack) <$> filter (T.all isDigit) <$> T.lines <$> if storeIsLocal here (info^.infoStore) then vrun "ls" ["-1", p']@@ -491,18 +481,18 @@ else return . Just . last $ listing containersForStore :: Store -> [Container] -> [Container]-containersForStore store conts =+containersForStore store = filter (\x -> let stName = x^.containerStore names = if "," `T.isInfixOf` stName then T.splitOn "," stName else [stName]- in (store^.storeName) `elem` names) conts+ in (store^.storeName) `elem` names) findContainer :: Fileset -> Store -> [Container] -> Container findContainer fileset store conts = fromMaybe- (error $ toString $+ (error $ T.unpack $ format "Could not find container for Store {} + Fileset {}" [ store^.storeName, fileset^.filesetName ]) $ find (\x -> (x^.containerFileset) == (fileset^.filesetName))@@ -549,13 +539,13 @@ findFileset :: Text -> [Fileset] -> Fileset findFileset n fsets = fromMaybe- (error $ toString $ "Could not find fileset matching name " <> n) $+ (error $ T.unpack $ "Could not find fileset matching name " <> n) $ find (\x -> n == x^.filesetName) fsets findStore :: Text -> [Store] -> Store findStore n sts = fromMaybe- (error $ toString $ "Could not find store matching hostname " <> n) $+ (error $ T.unpack $ "Could not find store matching hostname " <> n) $ find (\x -> matchText (x^.storeHostRe) n) sts storeIsLocal :: Text -> Store -> Bool@@ -580,7 +570,7 @@ deriving (Show, Eq) convertPath :: FilePath -> String-convertPath = toString+convertPath = T.unpack . toTextIgnore getHomePath :: Text -> IO FilePath getHomePath p = (</> fromText p) <$> getHomeDirectory@@ -601,9 +591,9 @@ let poolPath = toTextIgnore $ zfsPoolPath this in case (thisCont^.containerLastRev, thatCont^.containerLastRev) of (Just thisRev, Just thatRev) ->- if thisRev > thatRev- then return $ LocalPath $ ZfsSnapshotRange poolPath thatRev thisRev- else return $ LocalPath NoPath+ return $ LocalPath $ if thisRev > thatRev+ then ZfsSnapshotRange poolPath thatRev thisRev+ else NoPath (Just thisRev, Nothing) -> return $ LocalPath $ ZfsSnapshot poolPath thisRev (Nothing, _) ->@@ -638,7 +628,7 @@ syncContainers bnd = errExit False $ do verb <- getOption verbose - noticeL $ format "Sending {}/{} → {}"+ noticeL $ format "Sending {}/{} -> {}" [ bnd^.bindingThis.infoStore.storeName , bnd^.bindingFileset.filesetName , bnd^.bindingThat.infoStore.storeName ]@@ -652,11 +642,7 @@ if null recvArgs then vrun_ (fromText (head sendArgs)) (tail sendArgs) else escaping False $- vrun_ (fromText (head sendArgs)) $- tail sendArgs <> ["|"] <> (if verb- then ["pv", "|"]- else [])- <> recvArgs+ vrun_ (fromText (head sendArgs)) $ tail sendArgs <> ["|"] <> recvArgs updater createSyncCommands :: Binding -> Sh (Sh [Text], Sh [Text], Sh [Container])@@ -664,13 +650,52 @@ src <- liftIO $ sourcePath bnd dst <- liftIO $ destinationPath bnd verb <- getOption verbose+ deb <- getOption debug cpAll <- getOption copyAll - let thisCont = bnd^.bindingThis.infoContainer- thatCont = bnd^.bindingThat.infoContainer- recurseThis = thisCont^.containerRecurse- recurseThat = thatCont^.containerRecurse+ let thisCont = bnd^.bindingThis.infoContainer+ thatCont = bnd^.bindingThat.infoContainer+ recurseThis = thisCont^.containerRecurse+ recurseThat = thatCont^.containerRecurse + defaultFlags = [ "--not", "--in"+ , bnd^.bindingThat.infoStore.storeAnnexName ]+ storeAFlags = lookup (bnd^.bindingThat.infoStore.storeName)+ (bnd^.bindingThis.infoStore.storeAnnexFlags)+ annexFlags =+ flip (maybe defaultFlags) storeAFlags $ \flags ->+ fromMaybe (fromMaybe defaultFlags $ lookup "<default>" flags)+ $ lookup (bnd^.bindingFileset.filesetName) flags++ annexCmds isRemote path = do+ vrun_ "git-annex" $ ["-q" | not verb && not deb] <> ["add", "."]+ vrun_ "git-annex" $ ["-q" | not verb && not deb] <> ["sync"]+ vrun_ "git-annex" $ ["-q" | not verb && not deb]+ <> [ "--auto"+ | not ((bnd^.bindingThat.infoStore.storeIsPrimary)+ || cpAll) ]+ <> [ "copy" ]+ <> annexFlags+ <> [ "--to", bnd^.bindingThat.infoStore.storeAnnexName ]++ if isRemote+ then sub $ do+ let u = bnd^.bindingThat.infoStore.storeUserName+ h = bnd^.bindingThat.infoHostName+ remote vrun_ u h+ [ T.concat $+ [ "\"cd '", toTextIgnore path, "'; git-annex" ]+ <> [" -q" | not verb && not deb]+ <> [" sync", "\""] ]++ else sub $ do+ cd path+ vrun_ "git-annex" $ ["-q" | not verb && not deb]+ <> ["sync"]++ noticeL $ format "{}: Git Annex synchronized"+ [ bnd^.bindingFileset.filesetName ]+ case (src, dst) of (LocalPath NoPath, _) -> return ( infoL "No sync needed" >> return []@@ -680,22 +705,14 @@ (LocalPath (Pathname l), LocalPath (Pathname r)) -> if thisCont^.containerIsAnnex && thatCont^.containerIsAnnex then- return ( (if verb then id else silently) $ chdir l $ do- vrun_ "git-annex" $ ["-q" | not verb] <> ["add", "."]- vrun_ "git-annex" $ ["-q" | not verb]- <> ["sync", bnd^.bindingThat.infoHostName]- vrun_ "git-annex" $ ["-q" | not verb]- <> [ "--auto"- | not ((bnd^.bindingThat.infoStore.storeIsPrimary) ||- cpAll) ]- <> [ "copy", "--to"- , bnd^.bindingThat.infoHostName ]- return []+ return ( (if verb then id else silently) $ chdir l $+ annexCmds False r >> return [] , return [] , updateContainers Nothing bnd ) else- return ( systemVolCopy (bnd^.bindingFileset.filesetName) l- (toTextIgnore r)+ return ( systemVolCopy+ ((bnd^.bindingThat.infoStore.storeUserName) /= "root")+ (bnd^.bindingFileset.filesetName) l (toTextIgnore r) , return [] , updateContainers Nothing bnd ) @@ -703,25 +720,14 @@ if thisCont^.containerIsAnnex && thatCont^.containerIsAnnex then return ( escaping False $ (if verb then id else silently) $- chdir l $ do- vrun_ "git-annex" $ ["-q" | not verb] <> ["add", "."]- vrun_ "git-annex" $ ["-q" | not verb]- <> ["sync", bnd^.bindingThat.infoHostName]- vrun_ "git-annex" $ ["-q" | not verb]- <> [ "--auto"- | not ((bnd^.bindingThat.infoStore.storeIsPrimary)- || cpAll) ]- <> [ "copy", "--to"- , bnd^.bindingThat.infoHostName]- noticeL $ format "{}: Git Annex synchronized"- [ bnd^.bindingFileset.filesetName ]- return []+ chdir l $ annexCmds True r >> return [] , return [] , updateContainers Nothing bnd ) else- return ( systemVolCopy (bnd^.bindingFileset.filesetName) l $- format "{}@{}:{}"- [u, h, escape (toTextIgnore r)]+ return ( systemVolCopy+ ((bnd^.bindingThat.infoStore.storeUserName) /= "root")+ (bnd^.bindingFileset.filesetName) l+ (format "{}@{}:{}" [u, h, escape (toTextIgnore r)]) , return [] , updateContainers Nothing bnd ) @@ -761,7 +767,7 @@ , remoteReceive u h r recurseThat , updateContainers (Just e) bnd ) - (l, r) -> error $ toString $+ (l, r) -> error $ T.unpack $ format "Unexpected paths {} and {}" [ T.pack (show l), T.pack (show r) ] @@ -800,16 +806,16 @@ remote (\x xs -> return (toTextIgnore x:xs)) u h $ ["zfs", "recv"] <> ["-d" | recurse] <> ["-F", pool ] -systemVolCopy :: Text -> FilePath -> Text -> Sh [Text]-systemVolCopy label src dest = do+systemVolCopy :: Bool -> Text -> FilePath -> Text -> Sh [Text]+systemVolCopy useSudo label src dest = do optsFile <- liftIO $ getHomePath (".pushme/filters/" <> label) exists <- liftIO $ isFile optsFile let rsyncOptions = ["--include-from=" <> toTextIgnore optsFile | exists]- volcopy label True rsyncOptions (toTextIgnore src) dest+ volcopy label useSudo rsyncOptions (toTextIgnore src) dest volcopy :: Text -> Bool -> [Text] -> Text -> Text -> Sh [Text] volcopy label useSudo options src dest = do- infoL $ format "{} → {}" [src, dest]+ infoL $ format "{} -> {}" [src, dest] dry <- getOption dryRun noSy <- getOption noSync@@ -820,8 +826,8 @@ let shhh = not deb && not verb toRemote = ":" `T.isInfixOf` dest options' =- [ "-aHXEy" -- jww (2012-09-23): maybe -A too?- , "--fileflags"+ [ "-aHEy" -- jww (2012-09-23): maybe -A too?+ -- , "--fileflags" , "--delete-after" , "--ignore-errors" , "--force-delete"@@ -844,7 +850,7 @@ , "--filter=-p .com.apple.timemachine.supported" ] <> (if not (null sshCmd)- then ["--rsh", fromString sshCmd]+ then ["--rsh", T.pack sshCmd] else []) <> ["-n" | dry] <> (if shhh@@ -873,12 +879,13 @@ sent = field "Number of files transferred" stats total = field "Total file size" stats xfer = field "Total transferred file size" stats- noticeL $ format "{}: Sent {} in {} files (out of {} in {})"- [ label- , fromString (humanReadable xfer),- commaSep (fromIntegral sent)- , fromString (humanReadable total),- commaSep (fromIntegral files) ]+ noticeL $ format+ "{}: \ESC[34mSent \ESC[35m{}\ESC[0m\ESC[34m in {} files\ESC[0m (out of {} in {})"+ [ label+ , T.pack (humanReadable xfer),+ commaSep (fromIntegral sent)+ , T.pack (humanReadable total),+ commaSep (fromIntegral files) ] else doCopy (drun_ False) r toRemote useSudo options' @@ -894,21 +901,23 @@ . intToText field :: Text -> M.Map Text Text -> Integer- field x stats = fromMaybe 0 $ read . toString <$> M.lookup x stats+ field x stats = fromMaybe 0 $ read . T.unpack <$> M.lookup x stats doCopy f rsync False False os = f rsync os doCopy f rsync False True os = sudo f rsync os- doCopy f rsync True False os = f rsync (remoteRsync rsync:os)- doCopy f rsync True True os = asRoot f rsync (remoteRsync rsync:os)+ doCopy f rsync True False os = f rsync (remoteRsync False rsync:os)+ doCopy f rsync True True os = asRoot f rsync (remoteRsync True rsync:os) - remoteRsync x = format "--rsync-path=sudo {}" [toTextIgnore x]+ remoteRsync useSudo' x = if useSudo'+ then format "--rsync-path=sudo {}" [toTextIgnore x]+ else format "--rsync-path={}" [toTextIgnore x] readDataFile :: FromJSON a => Text -> IO [a] readDataFile p = do p' <- getHomePath p d <- Data.Yaml.decode <$> BC.readFile (convertPath p') case d of- Nothing -> error $ toString $ "Failed to read file " <> p+ Nothing -> error $ T.unpack $ "Failed to read file " <> p Just d' -> return d' writeDataFile :: ToJSON a => Text -> a -> IO ()@@ -930,10 +939,10 @@ getOption = liftIO . getOption' matchText :: Text -> Text -> Bool-matchText = flip ((=~) `on` toString)+matchText = flip ((=~) `on` T.unpack) intToText :: Int -> Text-intToText = fromString . show+intToText = T.pack . show remote :: (FilePath -> [Text] -> Sh a) -> Text -> Text -> [Text] -> Sh a remote f user host xs = do@@ -989,22 +998,22 @@ srun_ = void .: doRun run_ infoL (return ()) False True debugL :: Text -> Sh ()-debugL = liftIO . debugM "pushme" . toString+debugL = liftIO . debugM "pushme" . T.unpack infoL :: Text -> Sh ()-infoL = liftIO . infoM "pushme" . toString+infoL = liftIO . infoM "pushme" . T.unpack noticeL :: Text -> Sh ()-noticeL = liftIO . noticeM "pushme" . toString+noticeL = liftIO . noticeM "pushme" . T.unpack warningL :: Text -> Sh ()-warningL = liftIO . warningM "pushme" . toString+warningL = liftIO . warningM "pushme" . T.unpack errorL :: Text -> Sh ()-errorL = liftIO . errorM "pushme" . toString+errorL = liftIO . errorM "pushme" . T.unpack criticalL :: Text -> Sh ()-criticalL = liftIO . criticalM "pushme" . toString+criticalL = liftIO . criticalM "pushme" . T.unpack humanReadable :: Integer -> String humanReadable x
README.md view
@@ -6,58 +6,73 @@ `/usr/local` via rsync between two machines: `foo` and `bar`. First, `~/.pushme/stores.yml`: - - 'Targets':- - - 'bar'- - - 'home'- - 'local'- 'HostRe': '[Ff]oo'- 'Name': 'Foo'- 'UserName': 'johnw'- 'SelfRe': '[Ff]oo'- 'ZfsPool': null- 'ZfsPath': null- 'IsPrimary': true- - 'Targets':+ - Targets:+ - - bar+ - - home+ - local+ HostRe: [Ff]oo+ Name: Foo+ UserName: johnw+ SelfRe: [Ff]oo+ ZfsPool: null+ ZfsPath: null+ IsPrimary: true+ AnnexName: foo+ AnnexFlags: []+ - Targets:+ - - foo+ - - home+ - local+ HostRe: [Bb]ar+ Name: Bar+ UserName: johnw+ SelfRe: [Bb]ar+ ZfsPool: null+ ZfsPath: null+ IsPrimary: false+ AnnexName: bar+ AnnexFlags: - - 'foo'- - - 'home'- - 'local'- 'HostRe': '[Bb]ar'- 'Name': 'Bar'- 'UserName': 'johnw'- 'SelfRe': '[Bb]ar'- 'ZfsPool': null- 'ZfsPath': null- 'IsPrimary': false+ - - - 'home'+ - - '-\('+ - '--not'+ - '--in'+ - 'foo'+ - '--and'+ - '--not'+ - '--in'+ - 'web'+ - '-\)' Then, `~/.pushme/filesets.yml`: - - 'Priority': 60- 'Name': 'home'- 'Class': 'quick,main'- 'ReportMissing': true- - 'Priority': 80- 'Name': 'local'- 'Class': 'system,main'- 'ReportMissing': false+ - Priority: 60+ Name: home+ Class: quick,main+ ReportMissing: true+ - Priority: 80+ Name: local+ Class: system,main+ ReportMissing: false And finally, `~/.pushme/containers.yml`: - - 'Store': 'foo,bar'- 'Recurse': false- 'Fileset': 'home'- 'PoolPath': null- 'IsAnnex': false- 'LastRev': null- 'LastSync': null- 'Path': '~/'- - 'Store': 'foo,bar'- 'Recurse': false- 'Fileset': 'local'- 'PoolPath': null- 'IsAnnex': false- 'LastRev': null- 'LastSync': null- 'Path': '/usr/local/'+ - Store: foo,bar+ Recurse: false+ Fileset: home+ PoolPath: null+ IsAnnex: false+ LastRev: null+ LastSync: null+ Path: ~/+ - Store: foo,bar+ Recurse: false+ Fileset: local+ PoolPath: null+ IsAnnex: false+ LastRev: null+ LastSync: null+ Path: /usr/local/ Now I can run the following command:
pushme.cabal view
@@ -1,6 +1,6 @@ Name: pushme -Version: 1.1.0+Version: 1.4.0 Synopsis: Tool to synchronize multiple directories with rsync, zfs or git-annex Description: Script I use for synchronizing my data among machines.@@ -17,25 +17,23 @@ Extra-Source-Files: README.md Executable pushme- Main-is: Main.hs- Ghc-options: -threaded+ Main-is: Main.hs+ Ghc-options: -threaded Build-depends: base >= 4 && < 5 , aeson >= 0.6.0- , cabal-file-th >= 0.2.3 , bytestring >= 0.9.2- , cmdargs >= 0.10 , containers >= 0.4.2 , deepseq >= 1.3 , hslogger >= 1.2 , io-storage >= 0.3 , lens >= 2.8 , old-locale >= 1.0.0+ , optparse-applicative >= 0.5.2.1 , parallel-io >= 0.3.2 , pointless-fun >= 1.1 , regex-posix >= 0.95 , shelly >= 0.14.0.1- , stringable >= 0.1 , system-fileio >= 0.3.9 , system-filepath >= 0.4.7 , text >= 0.11.2