diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 "" 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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: diff --git a/pushme.cabal b/pushme.cabal --- a/pushme.cabal +++ b/pushme.cabal @@ -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