pushme 2.1.3 → 3.0.0
raw patch · 4 files changed
+1075/−1019 lines, 4 filesdep +directorydep +filepathdep +pretty-showdep −io-storagedep −pipesdep −pipes-groupdep ~aesondep ~basedep ~bytestring
Dependencies added: directory, filepath, pretty-show, process
Dependencies removed: io-storage, pipes, pipes-group, pipes-safe, pipes-text, safe, shelly, text-format
Dependency ranges changed: aeson, base, bytestring, containers, foldl, lens, logging, optparse-applicative, regex-posix, temporary, text, time, transformers, unix, yaml
Files
- Main.hs +546/−834
- Pushme/Options.hs +172/−84
- README.md +324/−65
- pushme.cabal +33/−36
Main.hs view
@@ -1,834 +1,546 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main where--import Control.Applicative-import Control.Arrow-import Control.Concurrent.ParallelIO (stopGlobalPool, parallel_)-import Control.Exception-import qualified Control.Foldl as L-import Control.Lens-import Control.Logging-import Control.Monad-import Control.Monad.Trans.Reader-import Data.Aeson hiding (Options)-import qualified Data.ByteString as B (readFile)-import Data.Char (isDigit)-import Data.List-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe (catMaybes, fromMaybe, fromJust, isNothing)-import Data.Monoid ((<>), mempty)-import Data.Ord (comparing)-import Data.Text (Text, pack, unpack)-import qualified Data.Text as T-import qualified Data.Text.Format as Fmt-import qualified Data.Text.Format.Params as Fmt-import Data.Text.Lazy (toStrict)-import Data.Yaml (decode)-import Filesystem-import Filesystem.Path.CurrentOS hiding (null, concat)-import GHC.Conc (setNumCapabilities)-import Pipes as P-import qualified Pipes.Group as P-import qualified Pipes.Prelude as P-import Pipes.Safe as P hiding (finally)-import qualified Pipes.Text as Text-import qualified Pipes.Text.IO as Text-import Prelude hiding (FilePath)-import Pushme.Options (Options(..), getOptions)-import Safe hiding (at)-import Shelly.Lifted hiding ((</>))-import Text.Printf (printf)-import Text.Regex.Posix ((=~))----import Debug.Trace--data Rsync = Rsync- { _rsyncPath :: FilePath- , _rsyncName :: Maybe Text- , _rsyncFilters :: [Text]- , _rsyncReportMissing :: Bool- , _rsyncNoLinks :: Bool- , _rsyncSendOnly :: Bool- , _rsyncReceiveOnly :: Bool- , _rsyncReceiveFrom :: Maybe [Text]- }- deriving (Show, Eq)--defaultRsync :: FilePath -> Rsync-defaultRsync p = Rsync p Nothing [] False False False False Nothing--instance FromJSON FilePath where- parseJSON = fmap fromText . parseJSON--instance FromJSON Rsync where- parseJSON (Object v) = Rsync- <$> v .: "Path"- <*> v .:? "Host"- <*> v .:? "Filters" .!= []- <*> v .:? "ReportMissing" .!= False- <*> v .:? "NoLinks" .!= False- <*> v .:? "SendOnly" .!= False- <*> v .:? "ReceiveOnly" .!= False- <*> v .:? "ReceiveFrom" .!= Nothing- parseJSON _ = errorL "Error parsing Rsync"--makeLenses ''Rsync--data Zfs = Zfs- { _zfsPath :: FilePath- , _zfsPoolPath :: FilePath- }- deriving (Show, Eq)--instance FromJSON Zfs where- parseJSON (Object v) = Zfs- <$> v .: "Path"- <*> v .: "PoolPath"- parseJSON _ = errorL "Error parsing Zfs"--makeLenses ''Zfs--data Annex = Annex- { _annexPath :: FilePath- , _annexName :: Maybe Text- , _annexFlags :: [Text]- , _annexIsPrimary :: Bool- }- deriving (Show, Eq)--instance FromJSON Annex where- parseJSON (Object v) = do- p <- v .: "Path"- Annex <$> pure p- <*> v .:? "Name"- <*> v .:? "Flags" .!= []- <*> v .:? "Primary" .!= False- parseJSON _ = errorL "Error parsing Annex"--makeLenses ''Annex--data StorageScheme- = SchemeRsync Rsync- | SchemeZfs Zfs- | SchemeAnnex Annex- deriving (Show, Eq)--makePrisms ''StorageScheme--newtype Store = Store- { _schemes :: Map Text StorageScheme- } deriving (Show, Eq)--makeLenses ''Store--instance FromJSON Store where- parseJSON (Object v) = do- mpath <- fmap (SchemeRsync . defaultRsync) <$> v .:? "Path"- mrsync <- fmap SchemeRsync <$> v .:? "Rsync"- mzfs <- fmap SchemeZfs <$> v .:? "Zfs"- mannex <- fmap SchemeAnnex <$> v .:? "Annex"- return $ Store mempty- & schemes.at "rsync" .~ (mrsync <|> mpath)- & schemes.at "zfs" .~ mzfs- & schemes.at "annex" .~ mannex- parseJSON _ = errorL "Error parsing Store"--rsyncScheme :: Traversal' Store Rsync-rsyncScheme = schemes.ix "rsync"._SchemeRsync--zfsScheme :: Traversal' Store Zfs-zfsScheme = schemes.ix "zfs"._SchemeZfs--annexScheme :: Traversal' Store Annex-annexScheme = schemes.ix "annex"._SchemeAnnex--data Fileset = Fileset- { _fsName :: Text- , _fsClass :: Text- , _fsPriority :: Int- , _stores :: Map Text Store- } deriving (Show, Eq)--makeLenses ''Fileset--fromJSON' :: FromJSON a => Value -> a-fromJSON' a = case fromJSON a of- Error e -> errorL (pack e)- Success x -> x--instance FromJSON Fileset where- parseJSON (Object v) = do- fset <- Fileset- <$> v .: "Name"- <*> v .:? "Class" .!= ""- <*> v .:? "Priority" .!= 1000- <*> v .:? "Stores" .!= mempty- opts <- v .:? "Options" .!= mempty- return $ M.foldlWithKey' f fset (opts :: Map Text (Map Text Value))- where- f fs "Rsync" =- M.foldlWithKey' k fs- where- k fs' "Filters" xs =- fs' & stores.traverse.rsyncScheme.rsyncFilters <>~ fromJSON' xs- k fs' "ReportMissing" xs =- fs' & stores.traverse.rsyncScheme.rsyncReportMissing &&~ fromJSON' xs- k fs' "NoLinks" xs =- fs' & stores.traverse.rsyncScheme.rsyncNoLinks &&~ fromJSON' xs- k fs' "SendOnly" xs =- fs' & stores.traverse.rsyncScheme.rsyncSendOnly &&~ fromJSON' xs- k fs' "ReceiveOnly" xs =- fs' & stores.traverse.rsyncScheme.rsyncReceiveOnly &&~ fromJSON' xs- k fs' "ReceiveFrom" xs =- fs' & stores.traverse.rsyncScheme.rsyncReceiveFrom <>~ fromJSON' xs- k fs' _ _ = fs'-- f fs "Zfs" = const fs-- f fs "Annex" =- M.foldlWithKey' k fs- where- k fs' "Flags" xs =- fs' & stores.traverse.annexScheme.annexFlags <>~ fromJSON' xs- k fs' _ _ = fs'-- f fs _ = const fs- parseJSON _ = errorL "Error parsing Fileset"--data Host = Host- { _hostName :: Text- , _hostAliases :: [Text]- }- deriving (Show, Eq)--defaultHost :: Text -> Host-defaultHost n = Host n []--makeLenses ''Host--data BindingCommand = BindingSync | BindingSnapshot- deriving (Show, Eq)--makePrisms ''BindingCommand--data Binding = Binding- { _fileset :: Fileset- , _source :: Host- , _target :: Host- , _this :: Store- , _that :: Store- , _bindCommand :: BindingCommand- } deriving (Show, Eq)--makeLenses ''Binding--isLocal :: Binding -> Bool-isLocal bnd =- bnd^.source.hostName == bnd^.target.hostName- || bnd^.source.hostName `elem` bnd^.target.hostAliases--targetHost :: Binding -> Maybe Host-targetHost bnd | isLocal bnd = Nothing- | otherwise = Just (bnd^.target)--data ExeMode = Normal | Sudo | SudoAsRoot--data ExeEnv = ExeEnv- { exeMode :: ExeMode- , exeRemote :: Maybe Host- , exeCwd :: Maybe FilePath- , exeDiscard :: Bool -- ^ Discard process output.- , exeFindCmd :: Bool -- ^ Look for command with "which".- }--type App a = ReaderT Options Sh a--defaultExeEnv :: ExeEnv-defaultExeEnv = ExeEnv Normal Nothing Nothing False True--env :: Binding -> ExeEnv-env bnd = ExeEnv Normal (targetHost bnd) Nothing False True--sudoEnv :: Binding -> ExeEnv-sudoEnv bnd = (env bnd) { exeMode = Sudo }--main :: IO ()-main = withStdoutLogging $ do- opts <- getOptions-- when (dryRun opts || noSync opts) $- warn' "`--dryrun' specified, no changes will be made!"-- _ <- GHC.Conc.setNumCapabilities (jobs opts)-- setLogLevel $ if verbose opts then LevelDebug else LevelInfo- setLogTimeFormat "%H:%M:%S"-- hosts <- readHostsFile opts- processBindings opts hosts `finally` stopGlobalPool--readHostsFile :: Options -> IO (Map Text Host)-readHostsFile opts = do- hostsFile <- expandPath (decodeString (configDir opts) </> "hosts")- exists <- isFile hostsFile- if exists- then do- hosts <- runSafeT $ P.toListM $- L.purely P.folds L.mconcat- (Text.readFile (encodeString hostsFile) ^. Text.lines)- >-> P.map (\l -> let (x:xs) = T.words l- h = Host x xs- in (x,h) : map (,h) xs)- return $ M.fromList (concat hosts)- else- return mempty--directoryContents :: FilePath -> Producer FilePath IO ()-directoryContents topPath = do- names <- lift $ listDirectory topPath- let properNames =- filter (`notElem` [".", "..", ".DS_Store", ".localized"]) names- forM_ properNames $ \name -> yield (topPath </> name)--readFilesets :: Options -> IO (Map Text Fileset)-readFilesets opts = do- confD <- expandPath (decodeString (configDir opts) </> "conf.d")- exists <- isDirectory confD- unless exists $- errorL $ "Please define filesets, "- <> "using files named "- <> T.pack (encodeString (decodeString (configDir opts)- </> "conf.d" </> "<name>.yml"))-- fmap (M.fromList . map ((^.fsName) &&& id))- $ P.toListM- $ directoryContents confD- >-> P.filter (\n -> extension n == Just "yml")- >-> P.mapM (liftIO . readDataFile)--readDataFile :: FromJSON a => FilePath -> IO a-readDataFile p = do- d <- Data.Yaml.decode <$> B.readFile (encodeString p)- case d of- Nothing -> errorL $ "Failed to read file " <> toTextIgnore p- Just d' -> return d'--processBindings :: Options -> Map Text Host -> IO ()-processBindings opts hosts = do- fsets <- readFilesets opts- thisHost <- T.init <$> shelly (silently $ cmd "hostname")- let dflt = defaultHost (pack (fromName opts))- here = case dflt of- Host "" _ -> hosts^.at thisHost.non dflt.hostName- _ -> dflt^.hostName- when (T.null here) $- errorL "Please identify the current host using --from"- parallel_- $ map (applyBinding opts)- $ relevantBindings opts here hosts fsets--relevantBindings :: Options -> Text -> Map Text Host -> Map Text Fileset- -> [Binding]-relevantBindings opts thisHost hosts fsets- = sortBy (comparing (^.fileset.fsPriority))- . filter matching'- . catMaybes- $ createBinding- <$> M.elems fsets- <*> pure thisHost- <*> map pack (cliArgs opts)- where- matching' bnd =- (T.null fss || matchText fss (fs^.fsName))- && (T.null cls || matchText cls (fs^.fsClass))- where- fs = bnd^.fileset- fss = pack (filesets opts)- cls = pack (classes opts)-- getHost h = fromMaybe (Host h []) (hosts^.at h)-- createBinding :: Fileset -> Text -> Text -> Maybe Binding- createBinding fs hereRaw thereRaw = do- let atsign = T.head thereRaw == '@'- f | atsign = second T.tail- | "/" `T.isInfixOf` thereRaw =- let [b, e] = T.splitOn "/" thereRaw- in const (b, e)- | otherwise = id- (here, there) = f (hereRaw, thereRaw)- Binding- <$> pure fs- <*> pure (getHost here)- <*> pure (getHost there)- <*> fs^.stores.at here- <*> fs^.stores.at there- <*> pure (if atsign- then BindingSnapshot- else BindingSync)--applyBinding :: Options -> Binding -> IO ()-applyBinding opts bnd- | dump opts =- printBinding bnd- | bnd^.bindCommand == BindingSnapshot =- shelly $ runReaderT (snapshotBinding bnd) opts- | otherwise =- shelly $ silently $ runReaderT (syncBinding bnd) opts--printBinding :: Binding -> IO ()-printBinding bnd = do- go (bnd^.fileset) (bnd^.this)- go (bnd^.fileset) (bnd^.that)- where- go fs c = putStrLn $ printf "%-12s %s"- (unpack (fs^.fsName)) (show (c^.schemes))--snapshotBinding :: Binding -> App ()-snapshotBinding bnd@((^? that.zfsScheme) -> Just z) = do- mrev <- determineLastRev (env bnd) z- let nextRev = maybe 1 succ mrev- thatSnapshot =- toTextIgnore $ z^.zfsPoolPath <> "@" <> decodeString (show nextRev)- liftIO $ log' $ format "Creating snapshot {}" [thatSnapshot]- execute_ (env bnd) "zfs" ["snapshot", thatSnapshot]-snapshotBinding _ = return ()--syncBinding :: Binding -> App ()-syncBinding bnd = errExit False $ do- liftIO $ log' $ format "Sending {}/{} -> {}"- [ bnd^.source.hostName- , bnd^.fileset.fsName- , bnd^.target.hostName- ]- syncStores bnd (bnd^.this) (bnd^.that)--syncStores :: Binding -> Store -> Store -> App ()-syncStores bnd ((^? annexScheme) -> Just a1) ((^? annexScheme) -> Just a2) =- syncAnnexSchemes bnd a1 a2-syncStores bnd ((^? zfsScheme) -> Just z1) ((^? zfsScheme) -> Just z2) =- syncZfsSchemes bnd z1 z2-syncStores bnd s1 s2 = syncUsingRsync bnd s1 s2--checkDirectory :: Binding -> FilePath -> Bool -> App Bool-checkDirectory _ path False = test_d path-checkDirectory (isLocal -> True) path True = test_d path-checkDirectory bnd path True = do- execute_ (env bnd) "test" ["-d", escape (toTextIgnore path)]- (== 0) <$> lastExitCode--getStorePath :: Binding -> Store -> Bool -> Maybe FilePath-getStorePath bnd s wantTarget- = (s^?rsyncScheme.rsyncPath)- <|> (s^?zfsScheme.zfsPath)- <|> (s^?annexScheme.annexPath)- <|> errorL ("Could not find path for "- <> ((if wantTarget- then bnd^.target- else bnd^.source)^.hostName)- <> "/" <> (bnd^.fileset.fsName))--syncAnnexSchemes :: Binding -> Annex -> Annex -> App ()-syncAnnexSchemes bnd a1 a2 = do- opts <- ask- exists1 <- checkDirectory bnd (a1^.annexPath) False- exists2 <- checkDirectory bnd (a2^.annexPath) True- if exists1 && exists2- then do- let runner1_ = execute_ $- (env bnd) { exeCwd = Just (a1^.annexPath)- , exeRemote = Nothing- }- runner2_ = execute_ $- (env bnd) { exeCwd = Just (a2^.annexPath)- , exeFindCmd = isLocal bnd- }-- -- Add, copy, and sync from the source.- runner1_ "git-annex" $ ["-q" | not (verbose opts)]- <> ["add", "-c", "alwayscommit=false", "."]- runner1_ "git-annex" $ ["-q" | not (verbose opts)]- <> [ "--auto"- | not (a2^.annexIsPrimary || copyAll opts) ]- <> [ "copy", "-c", "alwayscommit=false" ]- <> [ "--not", "--in", annexTarget ]- <> a1^.annexFlags- <> [ "--to", annexTarget ]- runner1_ "git-annex" $ ["-q" | not (verbose opts)] <> ["sync"]-- -- Sync to the destination.- runner2_ "git-annex" $ ["-q" | not (verbose opts)] <> ["sync"]-- liftIO $ log' $ format "{}: Git Annex synchronized"- [ bnd^.fileset.fsName ]-- else liftIO $ warn $ "Remote directory missing: "- <> toTextIgnore (a2^.annexPath)- where- annexTarget = a2^.annexName.non (bnd^.target.hostName)--syncZfsSchemes :: Binding -> Zfs -> Zfs -> App ()-syncZfsSchemes bnd z1 z2 = do- exists1 <- checkDirectory bnd (z1^.zfsPath) False- exists2 <- checkDirectory bnd (z2^.zfsPath) True- if exists1 && exists2- then do- rev1 <- determineLastRev (env bnd) { exeRemote = Nothing } z1- rev2 <- determineLastRev (env bnd) z2- opts <- ask- let p = z1^.zfsPoolPath- r = toTextIgnore (z2^.zfsPoolPath)- msendArgs = case (rev1, rev2) of- (Just thisRev, Just thatRev) ->- if thisRev > thatRev- then Just $ sendTwoRevs opts p thatRev thisRev- else Nothing- (Just thisRev, Nothing) ->- Just $ sendRev opts p thisRev- (Nothing, _) ->- Just $ send (toTextIgnore p)- env'' = defaultExeEnv { exeMode = Sudo }-- case msendArgs of- Nothing -> liftIO $ warn "Remote has newer snapshot revision"- Just (c, xs) ->- execute_ env'' c $ xs <> ["|", "zfs", "recv", "-F", r]-- else liftIO $ warn $ "Remote directory missing: "- <> toTextIgnore (z2^.zfsPath)- where- send pool = ("zfs", ["send", pool])-- sendRev opts poolPath r1 =- ("zfs",- ["send"]- <> ["-v" | verbose opts]- <> [ toTextIgnore poolPath <> "@" <> tshow r1 ])-- sendTwoRevs opts poolPath r1 r2 =- ("zfs",- ["send"]- <> ["-v" | verbose opts]- <> [ "-I"- , toTextIgnore poolPath <> "@" <> tshow r1- , toTextIgnore poolPath <> "@" <> tshow r2- ])--determineLastRev :: ExeEnv -> Zfs -> App (Maybe Int)-determineLastRev env' zfs = do- let p = toTextIgnore $ (zfs^.zfsPath) </> ".zfs" </> "snapshot"- fmap lastMay- $ sort- . map (read . unpack)- . filter (T.all isDigit)- . T.lines- <$> execute env' "ls" ["-1", p]--syncUsingRsync :: Binding -> Store -> Store -> App ()-syncUsingRsync bnd s1 s2 = do- exists1 <- checkDirectory bnd l False- exists2 <- checkDirectory bnd r True- if exists1 && exists2- then- rsync- bnd- (fromMaybe (defaultRsync l) (s1^?rsyncScheme))- l- (fromMaybe (defaultRsync r) (s2^?rsyncScheme))- (case h of- Nothing -> toTextIgnore r- Just targ -> format "{}:{}" [targ, toTextIgnore r])-- else do- liftIO $ warn $ "Either local directory missing: " <> toTextIgnore l- liftIO $ warn $ "OR remote directory missing: " <> toTextIgnore r- where- h = case targetHost bnd of- Nothing -> Nothing- Just targ- | Just (Just n) <- s2^?rsyncScheme.rsyncName -> Just n- | otherwise -> Just (targ^.hostName)-- Just (asDirectory -> l) = getStorePath bnd s1 False- Just (asDirectory -> r) = getStorePath bnd s2 True--rsync :: Binding -> Rsync -> FilePath -> Rsync -> Text -> App ()-rsync bnd srcRsync src destRsync dest =- if srcRsync^.rsyncReceiveOnly- || destRsync^.rsyncSendOnly- || maybe False (not . (bnd^.source.hostName `elem`))- (destRsync^.rsyncReceiveFrom)- then do- opts <- ask- let analyze = not (verbose opts) && not (noSync opts)- when analyze $- liftIO $ log' $ format- "{}: \ESC[34mSkipped: {}\ESC[34m\ESC[0m"- [ fs^.fsName- , if srcRsync^.rsyncReceiveOnly- then "<- ReceiveOnly"- else if destRsync^.rsyncSendOnly- then "-> SendOnly"- else if maybe False (not . (bnd^.source.hostName `elem`))- (destRsync^.rsyncReceiveFrom)- then "! ReceiveFrom"- else "Unknown"- ]- else do- let rfs = (srcRsync^.rsyncFilters) <> (destRsync^.rsyncFilters)- nol = (srcRsync^.rsyncNoLinks) || (destRsync^.rsyncNoLinks)- go xs = doRsync (fs^.fsName) xs (toTextIgnore src) dest nol- case rfs of- [] -> go []-- filters -> do- when (srcRsync^.rsyncReportMissing) $- liftIO $ reportMissingFiles fs srcRsync-- withTmpDir $ \p -> do- let fpath = p </> "filters"- writefile fpath (T.unlines filters)- go ["--include-from=" <> toTextIgnore fpath]- where- fs = bnd^.fileset--reportMissingFiles :: Fileset -> Rsync -> IO ()-reportMissingFiles fs r =- runEffect- $ for (directoryContents rpath- >-> P.map (T.drop len . toTextIgnore)- >-> P.catch (P.filter (\x -> not (any (matchText x) patterns)))- (\(_ :: SomeException) -> P.cat))- $ \f -> liftIO $ warn' $ format "{}: unknown: \"{}\"" [label, f]- where- label = fs^.fsName- rpath = asDirectory (r^.rsyncPath)- len = T.length (toTextIgnore rpath)- filters = r^.rsyncFilters-- patterns- = map regexToGlob- $ filter (`notElem` ["*", "*/", ".*", ".*/"])- $ map stringify filters-- stringify- = (\x -> if T.head x == '/' then T.tail x else x)- . (\x -> if T.index x (T.length x - 1) == '/'- then T.init x else x)- . T.drop 2-- regexToGlob- = T.replace "].*" "]*"- . T.replace "*" ".*"- . T.replace "?" "."- . T.replace "." "\\."--doRsync :: Text -> [Text] -> Text -> Text -> Bool -> App ()-doRsync label options src dest noLinks = do- opts <- ask- let den = (\x -> if x then 1000 else 1024) $ siUnits opts- sshCmd = ssh opts- rsyncCmd = rsyncOpt opts- toRemote = ":" `T.isInfixOf` dest- args =- [ "-aHEy" -- jww (2012-09-23): maybe -A too?- -- , "--fileflags"- , "--delete-after"- , "--ignore-errors"- , "--force"-- , "--exclude=/.Caches/"- , "--exclude=/.Spotlight-V100/"- , "--exclude=/.TemporaryItems/"- , "--exclude=/.Trash/"- , "--exclude=/.Trashes/"- , "--exclude=/.fseventsd/"- , "--exclude=/.zfs/"- , "--exclude=/Temporary Items/"- , "--exclude=/Network Trash Folder/"-- , "--filter=-p .DS_Store"- , "--filter=-p .localized"- , "--filter=-p .AppleDouble/"- , "--filter=-p .AppleDB/"- , "--filter=-p .AppleDesktop/"- , "--filter=-p .com.apple.timemachine.supported"- ]- <> (if not (null sshCmd)- then ["--rsh", pack sshCmd]- else [])- <> ["-n" | dryRun opts]- <> ["--no-links" | noLinks]- <> ["--checksum" | checksum opts]- <> (if verbose opts then ["-P"] else ["--stats"])- <> [pack ("--rsync-path=sudo " ++ if not (null rsyncCmd)- then rsyncCmd- else "rsync") | toRemote]- <> options- <> [src, if toRemote- then T.intercalate "\\ " (T.words dest)- else dest]- analyze = not (verbose opts) && not (noSync opts)- env' = defaultExeEnv- { exeMode = if toRemote then SudoAsRoot else Sudo- , exeDiscard = not analyze- }-- output <- execute env' "rsync" args- when analyze $ do- let stats = M.fromList- $ map (fmap (T.filter (/= ',') . (!! 1) . T.words)- . T.breakOn ": ")- $ filter (": " `T.isInfixOf`)- $ T.lines output- files = field "Number of files" stats- sent = field "Number of regular files transferred" stats- <|> field "Number of files transferred" stats- total = field "Total file size" stats- xfer = field "Total transferred file size" stats- liftIO $ log' $ format- ("{}: \ESC[34mSent \ESC[35m{}\ESC[0m\ESC[34m "- <> "in {} files\ESC[0m (out of {} in {})")- [ label- , humanReadable den (fromMaybe 0 xfer)- , commaSep (fromIntegral (fromMaybe 0 sent))- , humanReadable den (fromMaybe 0 total)- , commaSep (fromIntegral (fromMaybe 0 files))- ]- where- field :: Text -> M.Map Text Text -> Maybe Integer- field x stats = read . unpack <$> M.lookup x stats-- commaSep :: Int -> Text- commaSep = fst- . T.foldr (\x (xs, num :: Int) ->- if num /= 0 && num `mod` 3 == 0- then (x `T.cons` ',' `T.cons` xs, num + 1)- else (x `T.cons` xs, num + 1)) ("", 0)- . tshow--execute :: ExeEnv -> FilePath -> [Text] -> App Text-execute ExeEnv {..} name args = do- opts <- ask- cmdName <- (if exeFindCmd then findCmd else return) name- let (name', args') = case exeMode of- Normal -> (cmdName, args)- Sudo -> ("sudo", toTextIgnore cmdName:args)- SudoAsRoot -> sudoAsRoot cmdName args-- (modifier, name'', args'') = case exeRemote of- Nothing -> (id, name', args')- Just h -> remote opts h $ case exeCwd of- Nothing -> (id, name', args')- Just cwd ->- (escaping False, fromText $ T.concat $- [ "\"cd "- , escape (toTextIgnore cwd)- , "; "- , escape (toTextIgnore name')- , " "- ]- <> intersperse " " (map escape args')- <> ["\""], [])- runner p xs- | exeDiscard = run_ p xs >> return ""- | otherwise = run p xs- runner' p xs =- (case exeCwd of- Just cwd | isNothing exeRemote -> chdir cwd- _ -> id) $ modifier $ runner p xs- if dryRun opts || noSync opts- then return ""- else do- let (sshCmd:sshArgs) = words (encodeString name'')- n <- findCmd (decodeString sshCmd)- liftIO $ debug' $ format "{} {}"- [ toTextIgnore n- , T.intercalate " "- (map tshow (map T.pack sshArgs ++ args''))- ]- runner' n args''- where- findCmd n- -- Assume commands with spaces in them are "known"- | " " `T.isInfixOf` toTextIgnore n = return n- | relative n = do- c <- which n- case c of- Nothing -> errorL $ "Failed to find command: " <> toTextIgnore n- Just c' -> return c'- | otherwise = return n-- remote :: Options -> Host -> (App a -> App a, FilePath, [Text])- -> (App a -> App a, FilePath, [Text])- remote opts host (m, p, xs) =- let sshCmd = ssh opts- in (m, if null sshCmd then "ssh" else decodeString sshCmd,- host^.hostName : toTextIgnore p : xs)-- sudoAsRoot :: FilePath -> [Text] -> (FilePath, [Text])- sudoAsRoot p xs =- ("sudo", [ "su", "-", "root", "-c"- -- Pass the argument to su as a single, escaped string.- , T.unwords (map escape (toTextIgnore p:xs))- ])--execute_ :: ExeEnv -> FilePath -> [Text] -> App ()-execute_ env' fp args = void $ execute env' { exeDiscard = True } fp args--expandPath :: FilePath -> IO FilePath-expandPath (encodeString -> '~':'/':p) = (</> decodeString p) <$> getHomeDirectory-expandPath p = return p--asDirectory :: FilePath -> FilePath-asDirectory (toTextIgnore -> fp) =- fromText $ if T.null fp || T.last fp /= '/'- then T.append fp "/"- else fp--escape :: Text -> Text-escape x- | "\"" `T.isInfixOf` x || " " `T.isInfixOf` x =- "'" <> T.replace "\"" "\\\"" x <> "'"- | otherwise = x--matchText :: Text -> Text -> Bool-matchText x y = unpack x =~ unpack y--tshow :: Show a => a -> Text-tshow = pack . show--format :: Fmt.Params a => Fmt.Format -> a -> Text-format = (toStrict .) . Fmt.format--humanReadable :: Integer -> Integer -> Text-humanReadable den x =- pack $ fromJust- $ f 0 "b"- <|> f 1 "K"- <|> f 2 "M"- <|> f 3 "G"- <|> f 4 "T"- <|> f 5 "P"- <|> f 6 "X"- <|> Just (printf "%db" x)- where- f :: Integer -> String -> Maybe String- f n s | x < (den^succ n) =- Just $ if n == 0- then printf ("%d" ++ s) x- else printf ("%." ++ show (min 3 (pred n)) ++ "f" ++ s)- (fromIntegral x / (fromIntegral den^n :: Double))- f _ _ = Nothing---- Main.hs (pushme) ends here+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Control.Applicative ((<|>))+import Control.Arrow ((&&&))+import Control.Concurrent.ParallelIO (parallel_, stopGlobalPool)+import Control.Concurrent.QSem (newQSem, signalQSem, waitQSem)+import Control.Exception (bracket_, finally)+import Control.Lens+import Control.Logging+import Control.Monad (guard, unless, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Data.Aeson hiding (Options)+import Data.Aeson.Types (Parser)+import Data.Function (on)+import Data.List (foldl', isSuffixOf, sortOn, (\\))+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+ ( fromJust,+ fromMaybe,+ maybeToList,+ )+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime)+import Data.Traversable (forM)+import Data.Yaml (decodeFileEither, prettyPrintParseException)+import Pushme.Options+import System.Directory+ ( doesDirectoryExist,+ getHomeDirectory,+ listDirectory,+ )+import System.Exit (ExitCode (..))+import System.FilePath.Posix+ ( takeExtension,+ (</>),+ )+import System.IO (hClose)+import System.IO.Temp (withSystemTempFile)+import System.Process hiding (env)+import Text.Printf (printf)+import Text.Regex.Posix ((=~))+import Text.Show.Pretty (ppShow)++data Fileset = Fileset+ { _filesetName :: Text,+ _filesetClasses :: Maybe [Text],+ _filesetPriority :: Int,+ _filesetStores :: Map Text (FilePath, RsyncOptions),+ _filesetCommon :: Maybe RsyncOptions+ }+ deriving (Show, Eq)++makeLenses ''Fileset++decodeEnrichedOptions :: Map Text Value -> Parser (FilePath, RsyncOptions)+decodeEnrichedOptions m =+ parseM (m ^. at "Path") >>= \case+ Nothing -> fail "Missing value for Path"+ Just path ->+ (path,)+ <$> ( RsyncOptions+ <$> parseM (m ^. at "Filters")+ <*> (fromMaybe False <$> parseM (m ^. at "NoBasicOptions"))+ <*> (fromMaybe False <$> parseM (m ^. at "NoDelete"))+ <*> (fromMaybe False <$> parseM (m ^. at "PreserveAttrs"))+ <*> (fromMaybe False <$> parseM (m ^. at "ProtectTopLevel"))+ <*> parseM (m ^. at "Options")+ <*> parseM (m ^. at "ReceiveFrom")+ <*> (fromMaybe True <$> parseM (m ^. at "Active"))+ )+ where+ parseM :: (FromJSON a) => Maybe Value -> Parser (Maybe a)+ parseM Nothing = pure Nothing+ parseM (Just v) = parseJSON v++instance FromJSON Fileset where+ parseJSON (Object v) =+ Fileset+ <$> v .: "Name"+ <*> v .:? "Classes"+ <*> v .:? "Priority" .!= 1000+ <*> (v .: "Stores" >>= traverse decodeEnrichedOptions)+ <*> v .:? "Common"+ parseJSON _ = errorL "Error parsing Fileset"++data Host = Host+ { _hostName :: Text,+ _hostMaxJobs :: Int+ }+ deriving (Show, Eq, Ord)++makeLenses ''Host++parseHost :: Text -> Host+parseHost name = case T.split (== '@') name of+ [n] -> Host n 1+ [n, j] -> Host n (read (unpack j))+ _ -> errorL $ "Cannot parse hostname: " <> name++data Binding = Binding+ { _bindingFileset :: Fileset,+ _bindingSourceHost :: Host,+ _bindingSourcePath :: FilePath,+ _bindingTargetHost :: Host,+ _bindingTargetPath :: FilePath,+ _bindingRsyncOpts :: RsyncOptions+ }+ deriving (Show, Eq)++makeLenses ''Binding++isLocal :: Binding -> Bool+isLocal bnd = bnd ^. bindingSourceHost == bnd ^. bindingTargetHost++remoteHost :: Binding -> Maybe Host+remoteHost bnd+ | isLocal bnd = Nothing+ | otherwise = Just (bnd ^. bindingTargetHost)++type App a = ReaderT Options IO a++main :: IO ()+main = withStdoutLogging do+ cmdLineOpts <- getOptions+ configOpts <-+ readYaml+ =<< expandPath (cmdLineOpts ^. optsConfigDir </> "config.yaml")+ let opts = configOpts <> cmdLineOpts++ setLogLevel $ if opts ^. optsVerbose then LevelDebug else LevelInfo+ setLogTimeFormat "%H:%M:%S"++ when (opts ^. optsDryRun) $+ warn' "`--dryrun' specified, no changes will be made!"++ debug' $ "Command-line options: " <> pack (ppShow cmdLineOpts)+ debug' $ "Config file options: " <> pack (ppShow configOpts)+ debug' $ "Initial composite options: " <> pack (ppShow opts)++ runReaderT processBindings opts `finally` stopGlobalPool++processBindings :: App ()+processBindings = do+ opts <- ask+ case opts ^. optsCliArgs of+ host : hosts@(_ : _) -> liftIO do+ fsets <- traverse expandFilesetPaths =<< readFilesets opts+ let here = parseHost (pack host)+ bindings =+ relevantBindings+ opts+ here+ fsets+ (map (parseHost . pack) hosts)+ debug' $+ "Local host "+ <> here ^. hostName+ <> " with "+ <> tshow (here ^. hostMaxJobs)+ <> " sending jobs"+ hereSlots <- newQSem (here ^. hostMaxJobs)+ thereSlotsAll <- forM (M.keys bindings) $ \there -> do+ debug' $+ "Remote host "+ <> there ^. hostName+ <> " with "+ <> tshow (there ^. hostMaxJobs)+ <> " receiving jobs"+ newQSem (there ^. hostMaxJobs)+ parallel_ do+ (bnds, thereSlots) <- zip (M.toList bindings) thereSlotsAll+ pure (goHost opts hereSlots thereSlots bnds)+ _ -> log' "Usage: pushme FROM TO..."+ where+ -- Process all bindings for a single destination host+ goHost opts p q (there, bnds) = do+ -- Process all bindings for this host in parallel+ parallel_ (map (go opts p q) bnds)+ -- After all bindings for this host are done, print completion message+ when (not (null bnds)) $ do+ let msg = there ^. hostName <> " done"+ log' $ if opts ^. optsNoColor+ then msg+ else "\ESC[32m" <> msg <> "\ESC[0m"++ go opts p q bnd =+ bracket_ (waitQSem p) (signalQSem p) $+ bracket_ (waitQSem q) (signalQSem q) $+ runReaderT (applyBinding bnd) opts++ applyBinding :: Binding -> App ()+ applyBinding bnd = do+ log' $+ "Sending "+ <> (bnd ^. bindingFileset . filesetName)+ <> " → "+ <> (bnd ^. bindingTargetHost . hostName)+ debug' $ pack (ppShow bnd)+ syncStores+ bnd+ (bnd ^. bindingSourcePath)+ (bnd ^. bindingTargetPath)+ (bnd ^. bindingRsyncOpts)++ relevantBindings ::+ Options ->+ Host ->+ Map Text Fileset ->+ [Host] ->+ Map Host [Binding]+ relevantBindings opts here fsets hosts =+ M.map+ (sortOn (^. bindingFileset . filesetPriority))+ (collect (^. bindingTargetHost) bindings)+ where+ bindings :: [Binding]+ bindings = do+ fset <- M.elems fsets+ there <- hosts+ maybeToList do+ (src, _) <- fset ^. filesetStores . at (here ^. hostName)+ (dest, destOpts) <- fset ^. filesetStores . at (there ^. hostName)+ guard $+ not+ ( maybe+ False+ (not . (here ^. hostName `elem`))+ (destOpts ^. rsyncReceiveFrom)+ )+ let binding =+ Binding+ { _bindingFileset = fset,+ _bindingSourceHost = here,+ _bindingSourcePath = src,+ _bindingTargetHost = there,+ _bindingTargetPath = dest,+ _bindingRsyncOpts =+ case opts ^. optsRsyncOpts <> fset ^. filesetCommon of+ Nothing -> destOpts+ Just common -> common <> destOpts+ }+ guard $ isMatching binding+ guard $ destOpts ^. rsyncActive+ pure binding++ isMatching :: Binding -> Bool+ isMatching bnd =+ (null fss || any id (matchText (fs ^. filesetName) <$> fss))+ && (null cls || any id (matchText <$> cs <*> cls))+ where+ fs = bnd ^. bindingFileset+ cs = fromMaybe [] (fs ^. filesetClasses)+ fss = fromMaybe [] (opts ^. optsFilesets)+ cls = fromMaybe [] (opts ^. optsClasses)++ readFilesets :: Options -> IO (Map Text Fileset)+ readFilesets opts = do+ confD <- expandPath (opts ^. optsConfigDir </> "filesets")+ exists <- doesDirectoryExist confD+ unless exists $+ errorL $+ "Please define filesets, "+ <> "using files named "+ <> pack (opts ^. optsConfigDir)+ <> "filesets/<name>.yaml"+ directoryContents confD+ >>= mapM readYaml . filter (\n -> takeExtension n == ".yaml")+ <&> M.fromList . map ((^. filesetName) &&& id)++checkDirectory :: Binding -> FilePath -> Bool -> App Bool+checkDirectory _ path False =+ liftIO $ doesDirectoryExist path+checkDirectory (isLocal -> True) path True =+ liftIO $ doesDirectoryExist path+checkDirectory bnd path True =+ (ExitSuccess ==) . fstOf3+ <$> execute+ (remoteHost bnd)+ "test"+ ["-d", unpack (escape (pack path))]+ where+ escape :: Text -> Text+ escape x+ | "\"" `T.isInfixOf` x || " " `T.isInfixOf` x =+ "'" <> T.replace "\"" "\\\"" x <> "'"+ | otherwise = x++syncStores :: Binding -> FilePath -> FilePath -> RsyncOptions -> App ()+syncStores bnd src dest roDest = do+ exists <-+ (&&)+ <$> checkDirectory bnd l False+ <*> checkDirectory bnd r True+ if exists+ then invokeRsync bnd l roDest (remoteHost bnd) r+ else liftIO do+ warn $ "Either local directory missing: " <> pack l+ warn $ "OR remote directory missing: " <> pack r+ where+ (asDirectory -> l) = src+ (asDirectory -> r) = dest++invokeRsync ::+ Binding ->+ FilePath ->+ RsyncOptions ->+ Maybe Host ->+ FilePath ->+ App ()+invokeRsync bnd src roDest host dest = do+ opts <- ask+ withProtected $ \args1 ->+ withFilters "Filters" (roDest ^. rsyncFilters) $ \args2 ->+ doRsync+ ( bnd ^. bindingTargetHost . hostName+ <> "/"+ <> bnd ^. bindingFileset . filesetName+ )+ (rsyncArguments opts (args1 ++ args2))+ where+ withProtected k+ | roDest ^. rsyncProtectTopLevel =+ k ["--filter", "P /*"]+ | otherwise = k []++ withFilters label fs k = case fs of+ Nothing -> k []+ Just filters -> withSystemTempFile "filters" $ \fpath h -> do+ liftIO do+ T.hPutStr h filters+ hClose h+ debug' $ label <> ":\n" <> filters+ k ["--include-from", pack fpath]++ rsyncArguments :: Options -> [Text] -> [Text]+ rsyncArguments opts args =+ ["-a" | not (roDest ^. rsyncNoBasicOptions)]+ <> ["--delete" | not (roDest ^. rsyncNoDelete)]+ <> ["-AXUNHE" | roDest ^. rsyncPreserveAttrs]+ <> ["-n" | opts ^. optsDryRun]+ <> ( if opts ^. optsVerbose+ then ["-v"]+ else ["--stats"]+ )+ <> args+ <> fromMaybe [] (roDest ^. rsyncOptions)+ <> [ pack src,+ case host ^? _Just . hostName of+ Nothing -> pack dest+ Just h -> h <> ":" <> T.intercalate "\\ " (T.words (pack dest))+ ]++doRsync :: Text -> [Text] -> App ()+doRsync label args = do+ opts <- ask+ (ec, diff, output) <- execute Nothing "rsync" (map unpack args)+ when (ec == ExitSuccess && not (opts ^. optsDryRun)) $+ if opts ^. optsVerbose+ then liftIO $ putStr output+ else do+ let stats =+ M.fromList+ $ map+ ( fmap (T.filter (/= ',') . (!! 1) . T.words)+ . T.breakOn ": "+ )+ $ filter (": " `T.isInfixOf`)+ $ map pack+ $ lines output+ files = field "Number of files" stats+ sent =+ field "Number of regular files transferred" stats+ <|> field "Number of files transferred" stats+ total = field "Total file size" stats+ xfer = field "Total transferred file size" stats+ den = (\x -> if x then 1000 else 1024) $ opts ^. optsSiUnits+ log' $+ label+ <> ": "+ <> purple+ (opts ^. optsNoColor)+ (humanReadable den (fromMaybe 0 xfer))+ <> cyan+ (opts ^. optsNoColor)+ (" in " <> commaSep (fromIntegral (fromMaybe 0 sent)))+ <> " ("+ <> humanReadable den (fromMaybe 0 total)+ <> " in "+ <> commaSep (fromIntegral (fromMaybe 0 files))+ <> ") "+ <> green+ (opts ^. optsNoColor)+ ("[" <> tshow (round diff :: Int) <> "s]")+ where+ field :: Text -> M.Map Text Text -> Maybe Integer+ field x = fmap (read . unpack) . M.lookup x++ colored True _ s = s+ colored False n s = "\ESC[" <> tshow (n :: Int) <> "m" <> s <> "\ESC[0m"+ purple b = colored b 35+ cyan b = colored b 36+ green b = colored b 32++ commaSep :: Int -> Text+ commaSep =+ fst+ . T.foldr+ ( \x (xs, num :: Int) ->+ if num /= 0 && num `mod` 3 == 0+ then (x `T.cons` ',' `T.cons` xs, num + 1)+ else (x `T.cons` xs, num + 1)+ )+ ("", 0)+ . tshow++ humanReadable :: Integer -> Integer -> Text+ humanReadable den x =+ pack $+ fromJust $+ f 0 "b"+ <|> f 1 "K"+ <|> f 2 "M"+ <|> f 3 "G"+ <|> f 4 "T"+ <|> f 5 "P"+ <|> f 6 "X"+ <|> Just (printf "%db" x)+ where+ f :: Integer -> String -> Maybe String+ f n s+ | x < (den ^ succ n) =+ Just $+ if n == 0+ then printf ("%d" ++ s) x+ else+ printf+ ("%." ++ show (min 3 (pred n)) ++ "f" ++ s)+ (fromIntegral x / (fromIntegral den ^ n :: Double))+ f _ _ = Nothing++execute ::+ Maybe Host ->+ FilePath ->+ [String] ->+ App (ExitCode, NominalDiffTime, String)+execute mhost cmdName args = do+ opts <- ask+ let (name', args') = case mhost of+ Nothing -> (cmdName, args)+ Just h -> remote h (cmdName, args)+ runner p xs =+ liftIO $+ timeFunction (readProcessWithExitCode p xs "")+ debug' $ pack name' <> " " <> T.intercalate " " (map tshow args')+ (diff, (ec, out, err)) <-+ if opts ^. optsDryRun+ then pure (0, (ExitSuccess, "", ""))+ else runner name' args'+ unless (ec == ExitSuccess) $+ errorL $+ "Error running command: "+ <> pack cmdName+ <> " "+ <> pack (ppShow args)+ <> ": "+ <> pack err+ pure (ec, diff, out)+ where+ timeFunction :: IO a -> IO (NominalDiffTime, a)+ timeFunction function = do+ startTime <- getCurrentTime+ a <- function+ endTime <- getCurrentTime+ pure (diffUTCTime endTime startTime, a)++ remote :: Host -> (FilePath, [String]) -> (FilePath, [String])+ remote host (p, xs) =+ ( "ssh",+ unpack (host ^. hostName) : p : xs+ )++-- Utility functions++readYaml :: (FromJSON a) => FilePath -> IO a+readYaml p =+ decodeFileEither p >>= \case+ Left err -> errorL $ pack $ p <> ": " <> prettyPrintParseException err+ Right d -> pure d++expandPath :: FilePath -> IO FilePath+expandPath ['~'] = getHomeDirectory+expandPath ('~' : '/' : p) = (</> p) <$> getHomeDirectory+expandPath p = pure p++expandFilesetPaths :: Fileset -> IO Fileset+expandFilesetPaths fs =+ fs & filesetStores %%~ traverse (\(a, b) -> (,) <$> expandPath a <*> pure b)++directoryContents :: FilePath -> IO [FilePath]+directoryContents p = map (p </>) <$> listDirectory p++lsDirectory :: Maybe Host -> FilePath -> App [FilePath]+lsDirectory mhost path = do+ (_ec, _secs, output) <- execute mhost "ls" ["-1ap", path]+ pure $ lines output \\ ["./", "../"]++asDirectory :: FilePath -> FilePath+asDirectory fp+ | "/" `isSuffixOf` fp = fp+ | otherwise = fp <> "/"++collect :: (Ord b) => (a -> b) -> [a] -> Map b [a]+collect f =+ foldl'+ ( \m x ->+ m+ & at (f x) %~ \case+ Nothing -> Just [x]+ Just xs -> Just (x : xs)+ )+ mempty++fstOf3 :: (a, b, c) -> a+fstOf3 (a, _, _) = a++matchText :: Text -> Text -> Bool+matchText = (=~) `on` unpack++tshow :: (Show a) => a -> Text+tshow = pack . show
Pushme/Options.hs view
@@ -1,108 +1,196 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Pushme.Options where -import Data.Data (Data)-import Data.Monoid-import Data.Typeable (Typeable)-import Options.Applicative hiding (Success, (&))+import Control.Lens hiding (argument)+import Control.Logging+import Data.Aeson hiding (Options)+import Data.Text (Text)+import qualified Data.Text as T+import Options.Applicative hiding (Success) version :: String-version = "2.0.0.1"+version = "3.0.0" copyright :: String-copyright = "2013-4"+copyright = "2013-2025" pushmeSummary :: String pushmeSummary =- "pushme " ++ version ++ ", (C) " ++ copyright ++ " John Wiegley"+ "pushme " ++ version ++ ", (C) " ++ copyright ++ " John Wiegley" +data RsyncOptions = RsyncOptions+ { _rsyncFilters :: Maybe Text,+ _rsyncNoBasicOptions :: Bool,+ _rsyncNoDelete :: Bool,+ _rsyncPreserveAttrs :: Bool,+ _rsyncProtectTopLevel :: Bool,+ _rsyncOptions :: Maybe [Text],+ _rsyncReceiveFrom :: Maybe [Text],+ _rsyncActive :: Bool+ }+ deriving (Show, Eq)++instance FromJSON RsyncOptions where+ parseJSON (Object v) =+ RsyncOptions+ <$> v .:? "Filters"+ <*> v .:? "NoBasicOptions" .!= False+ <*> v .:? "NoDelete" .!= False+ <*> v .:? "PreserveAttrs" .!= False+ <*> v .:? "ProtectTopLevel" .!= False+ <*> v .:? "Options"+ <*> v .:? "ReceiveFrom"+ <*> v .:? "Active" .!= True+ parseJSON _ = errorL "Error parsing Rsync"++instance Semigroup RsyncOptions where+ RsyncOptions a1 b1 c1 d1 e1 f1 g1 h1+ <> RsyncOptions a2 b2 c2 d2 e2 f2 g2 h2 =+ RsyncOptions+ (a2 <|> a1)+ (b2 || b1)+ (c2 || c1)+ (d2 || d1)+ (e2 || e1)+ (f2 <|> f1)+ (g2 <|> g1)+ (h2 && h1)++makeLenses ''RsyncOptions+ data Options = Options- { jobs :: Int- , dryRun :: Bool- , noSync :: Bool- , copyAll :: Bool- , dump :: Bool- , ssh :: String- , rsyncOpt :: String- , checksum :: Bool- , fromName :: String- , configDir :: String- , filesets :: String- , classes :: String- , siUnits :: Bool- , verbose :: Bool- , quiet :: Bool- , cliArgs :: [String]- }- deriving (Data, Typeable, Show, Eq)+ { _optsConfigDir :: FilePath,+ _optsDryRun :: Bool,+ _optsFilesets :: Maybe [Text],+ _optsClasses :: Maybe [Text],+ _optsSiUnits :: Bool,+ _optsVerbose :: Bool,+ _optsNoColor :: Bool,+ _optsRsyncOpts :: Maybe RsyncOptions,+ _optsCliArgs :: [String]+ }+ deriving (Show, Eq) +instance FromJSON Options where+ parseJSON (Object v) =+ Options+ <$> v .:? "Config" .!= "~/.config/pushme"+ <*> v .:? "DryRun" .!= False+ <*> v .:? "Filesets"+ <*> v .:? "Classes"+ <*> v .:? "SIUnits" .!= False+ <*> v .:? "Verbose" .!= False+ <*> v .:? "NoColor" .!= False+ <*> v .:? "GlobalOptions"+ <*> pure []+ parseJSON _ = errorL "Error parsing Options"++instance Semigroup Options where+ Options _a1 b1 c1 d1 e1 f1 g1 h1 i1+ <> Options a2 b2 c2 d2 e2 f2 g2 h2 i2 =+ Options+ a2+ (b2 || b1)+ (c2 <|> c1)+ (d2 <|> d1)+ (e2 || e1)+ (f2 || f1)+ (g2 || g1)+ (h2 <> h1)+ (i2 <|> i1)++makeLenses ''Options++separated :: Char -> ReadM [Text]+separated c = T.split (== c) <$> str+ pushmeOpts :: Parser Options-pushmeOpts = Options- <$> option auto- ( 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- ( long "dump"- <> help "Show all the stores that would be synced")- <*> strOption- ( long "ssh"- <> value ""- <> help "Use a specific ssh command")- <*> strOption- ( long "rsync"- <> value ""- <> help "Use a specific rsync command")+pushmeOpts =+ Options+ <$> strOption+ ( long "config"+ <> value "~/.config/pushme"+ <> help "Config directory (default: ~/.config/pushme)"+ ) <*> switch- ( long "checksum"- <> help "Pass --checksum flag to rsync")- <*> strOption- ( long "from"- <> value ""- <> help "Provide the name of the current host")- <*> strOption- ( long "config"- <> value "~/.pushme"- <> help "Directory containing configuration files (def: ~/.pushme)")- <*> 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)")+ ( short 'n'+ <> long "dry-run"+ <> help "Do not take any actions, just report"+ )+ <*> optional+ ( option+ (separated ',')+ ( short 'f'+ <> long "filesets"+ <> help "File sets to synchronize (comma-separated)"+ )+ )+ <*> optional+ ( option+ (separated ',')+ ( short 'c'+ <> long "classes"+ <> help "Classes to synchronize (comma-separated)"+ )+ ) <*> switch- ( long "si"- <> help "Use 1000 instead of 1024 to divide")+ ( short 's'+ <> long "si-units"+ <> help "Use 1000 instead of 1024 as a divisor"+ ) <*> switch- ( short 'v'- <> long "verbose"- <> help "Report progress verbosely")+ ( short 'v'+ <> long "verbose"+ <> help "Report progress verbosely"+ ) <*> switch- ( short 'q'- <> long "quiet"- <> help "Be a little quieter")- <*> many (argument (eitherReader Right) (metavar "ARGS"))- -- <*> many (argument Just (metavar "ARGS"))+ ( long "no-color"+ <> help "Do not use ANSI colors in report output"+ )+ <*> optional+ ( RsyncOptions+ <$> optional+ ( strOption+ ( long "rsync-filters"+ <> help "rsync filters to pass using --include-from"+ )+ )+ <*> switch+ ( long "rsync-no-basic-options"+ <> help "Do not pass -a (and possibly other basic options)"+ )+ <*> switch+ ( long "rsync-no-delete"+ <> help "Do not pass --delete"+ )+ <*> switch+ ( long "rsync-preserve-attrs"+ <> help "Preserve all attributes (i.e., pass -AXUNHE)"+ )+ <*> switch+ ( long "rsync-protect-top-level"+ <> help "Protect top-level items from deletion"+ )+ <*> optional+ ( option+ (separated ' ')+ ( long "rsync-options"+ <> help "Space-separated list of options to pass to rsync"+ )+ )+ <*> pure Nothing+ <*> pure True+ )+ <*> many (argument (eitherReader Right) (metavar "ARGS")) -optionsDefinition = info+optionsDefinition :: ParserInfo Options+optionsDefinition =+ info (helper <*> pushmeOpts) (fullDesc <> progDesc "" <> header pushmeSummary) +getOptions :: IO Options getOptions = execParser optionsDefinition
README.md view
@@ -1,78 +1,337 @@-This is the script I use for synchronizing data between my machines (and also-to directories on the same machine, externally connected drives, and to and-between ZFS filesystems).+# pushme v3.0.0 -Each "fileset" you wish to synchronize is defined in a YAML file within-`~/.pushme/conf.d`, for example this recipe I use for synchronizing my+ - Name: 'Desktop'- Priority: 12- Class: 'quick,main,sync'- - Stores:- hermes:- Path: /Users/johnw/Desktop- - maia:- Path: /Users/johnw/Desktop- - vulcan:- Path: /Users/johnw/Desktop- +[pushme](https://github.com/jwiegley/pushme) is a wrapper around+[rsync](https://en.wikipedia.org/wiki/Rsync) allowing declarative filesets to+be transferred between machines. The screenshot above shows pushme in action+(where `push` is a script I use to call `pushme` with appropriate arguments+based on which machine I'm running it from).++As each destination completes, pushme displays a color-coded completion message+(e.g., `athena done` in green) so you can track progress across multiple+parallel transfers.++## Configuration++Filesets are declared, one per file, in the directory+`~/.config/pushme/filesets`. An exhaustive set of options are given in the+following `src.yaml` example:++```yaml+# Filesets can be specifically named using -f name1,name2,…+Name: 'src'+# Filesets are transmitted in priority order (lower number = higher priority)+# Default priority is 1000 if not specified+Priority: 50+# Classes allow transferring subsets using -c class1,class2,…+Classes:+ - 'small'++# Define on which machines the fileset is located, where, and if custom+# rsync options apply+Stores:+ hera:+ # The remote pathname on `hera` where this fileset resides+ Path: /Users/johnw/src++ # Filters passed to rsync whenever transferring TO `hera`+ # Uses rsync filter syntax (see Filter Syntax section below)+ Filters: |+ - *~+ # If NoBasicOptions is set, then `-a` is not passed to `rsync`+ NoBasicOptions: false+ # If NoDelete is set, then `--delete` is not passed to `rsync`+ NoDelete: true+ # If PreserveAttrs is set, then `-AXUNHE` is passed to `rsync`. This is+ # not the default.+ PreserveAttrs: true+ # If ProtectTopLevel is set, top-level items are protected from deletion+ # (implemented as --filter "P /*" passed to rsync). This prevents --delete+ # from removing any files/directories at the root level of the destination.+ ProtectTopLevel: false+ # Additional `rsync` options added, in addition to any others. Options:- Rsync:- Filters:- - '- /annex/'+ - "--delete-after"+ # Only transfer here if we are transferring FROM the given machines.+ ReceiveFrom:+ - clio+ # Is this fileset active on this machine? If not, never transfer here.+ # Default is true if not specified.+ Active: true -Filters may also be specified for a specific computer only:+ clio:+ Path: /Users/johnw/src+ ReceiveFrom:+ - hera - Name: 'Desktop'- Priority: 12- Class: 'quick,main,sync'- - Stores:- hermes:- Rsync:- Path: /tank/Archives- Filters:- - '- /annex/'- - maia:- Path: /Users/johnw/Desktop- - vulcan:- Path: /Users/johnw/Desktop+ athena:+ Path: /Users/johnw/src+ ReceiveFrom:+ - hera+ - clio -There are three backends supported for file transfer `Rsync` (the default, if-none is specified), `Zfs`, and `Annex`. When two backends mismatch for a-given machine, `Rsync` is used, otherwise the most optimal method for-synchronizing that particular fileset type is attempted.+ # `tank` is the same machine as `athena`, it just uses a different set of+ # platter-based directories for long-term, ZFS archival storage. By using a+ # separate ssh hostname to refer to `athena` this way, I gain additional+ # flexibility as to which filesets get transferred and how much parallelism+ # is used when receiving files (to reduce fragmentation)+ tank:+ Path: /tank/src+ ReceiveFrom:+ - hera+ - clio -Note that recently I have only been using the `Rsync` method, so the other-backends are not well tested, and should not be used except on trial data at-this time. If you wish to help support them, I am available for assistance.+# In addition to specifying specific options for given targets above, you can+# also specify options here that apply to all targets. Note that each setting+# here may be overridden by target specific settings or command-line options.+Common:+ Filters: |+ # Exclude common build artifacts and temporary files+ - *.agdai+ - *.d+ - *.glob+ - *.hi+ - *.o+ - *~+ - dist/+ - dist-newstyle/+ - node_modules/+``` -Pushme is invoked as follows (`--from` can be omitted, if `hostname` returns-the same string):+### Filter Syntax - pushme --from thisMachine thatMachine+Filters use standard rsync filter rule syntax. Despite being passed via+`--include-from`, patterns can be both includes and excludes. Key points: -This command will synchronize every fileset that contains a backend definition-for both `thisMachine` and `thatMachine`. Here is example output from such a-command, assuming two filesets `home` and `local`:+- **`- pattern`** excludes files matching pattern+- **`+ pattern`** includes files (when combined with excludes)+- **`*`** matches any characters except `/`+- **`**`** matches any characters including `/`+- Patterns starting with **`/`** are anchored to the source directory root+- **First matching rule wins**+- See `man rsync` FILTER RULES section for complete details - foo $ pushme thatMachine- 15:18:44 - [NOTICE] Synchronizing ThisMachine -> ThatMachine- 15:18:44 - [NOTICE] Sending ThisMachine/home → ThatMachine- 15:18:52 - [NOTICE] Sent 151.0M in 131 files (out of 1.37G in 12,418)- 15:20:26 - [NOTICE] Sending ThisMachine/local → ThatMachine- 15:21:02 - [NOTICE] Sent 0b in 0 files (out of 6.45G in 207,453)+**Simple exclude examples:** -Some common options include:+```yaml+Filters: |+ - *~ # Exclude backup files+ - *.o # Exclude object files anywhere+ - /dist/ # Exclude dist/ in root directory only+ - /.cache/ # Exclude .cache/ in root only+ - **/.git/ # Exclude .git/ directories anywhere+``` - $ pushme -c quick bar # only sync filesets with the "quick" class- $ pushme -f home bar # only sync the "home" fileset- $ pushme -n bar # don't do anything, just scan- $ pushme -N bar # don't even scan- $ pushme -v bar # show commands being executed- $ pushme -D bar # show more info than you want to see+**Advanced include/exclude example:**++```yaml+Filters: |+ # Include foo directory, but only some of its children+ + /foo/+ + /foo/bar+ - /foo/* # Exclude all other files in /foo+ - /foo/*/ # Exclude all other directories in /foo+ - /foo/.* # Exclude hidden files in /foo+ - /foo/.*/ # Exclude hidden directories in /foo+```++## Usage++Once you have defined a group of filesets, you may transfer all filesets that+apply from one machine to any others using the basic command:++ pushme SOURCE TARGETS…++For example, I have a desktop `hera`, a laptop `clio`, a server `athena` and a+ZFS drive on `athena` that I reference using the ssh hostname `tank`. Thus I+might use any of the following commands:++ pushme hera clio # update the laptop+ pushme hera clio athena # update the laptop and server+ pushme hera clio athena tank # update both and archival store++### Parallelism++If a machine has multiple cores, you can take advantage of parallelism by+specifying how many simultaneous transfer jobs you'd like to support either+from or to a particular machine:++ pushme hera@24 clio@14 athena@10 tank@1++Filesets are always transferred in priority order (lower numbers first),+independent of how many times a particular fileset may be "in flight" at a+given moment when transferring to multiple machines. This should ensure that+the most important data is always completed first, before transferring other+filesets.++As transfers to each destination complete, pushme displays a completion message+(e.g., `athena done` in green by default).++## Global Configuration++In addition to setting rsync options per-target or common to all targets within+a fileset, you may also define global options using+`~/.config/pushme/config.yaml`:++```yaml+# If DryRun is true, no changes will be made to any target fileset+DryRun: false+# If Filesets is defined here, only these filesets are eligible for transfer+Filesets:+ - 'foo'+# If Classes is defined here, only matching filesets are eligible for transfer+Classes:+ - 'foo'+# If SIUnits is true, report in gigabytes, for example, instead of gibibytes+SIUnits: true+# If Verbose is true, present a great amount of detail+Verbose: false+# If NoColor is true, disable ANSI color codes in output+NoColor: false+# GlobalOptions are like having a Common block in every fileset+GlobalOptions:+ PreserveAttrs: true+ Options:+ - "--include-from=/Users/johnw/.config/ignore.lst"+```++## Command-Line Options++Options may also be specified using the command-line:++| Short | Long | Description |+|-------|------|-------------|+| | `--config DIR` | Config directory (default: `~/.config/pushme`) |+| `-n` | `--dry-run` | Do not take any actions, just report what would happen |+| `-f` | `--filesets LIST` | Comma-separated list of filesets to transfer |+| `-c` | `--classes LIST` | Comma-separated list of classes to transfer |+| `-s` | `--si-units` | Use 1000 instead of 1024 as divisor (GB vs GiB) |+| `-v` | `--verbose` | Report progress verbosely (show full rsync output) |+| | `--no-color` | Disable ANSI color codes in output |+| | `--rsync-filters TEXT` | rsync filter rules to apply globally |+| | `--rsync-no-basic-options` | Do not pass `-a` to rsync |+| | `--rsync-no-delete` | Do not pass `--delete` to rsync |+| | `--rsync-preserve-attrs` | Pass `-AXUNHE` to rsync (preserve all attributes) |+| | `--rsync-protect-top-level` | Protect top-level items from deletion |+| | `--rsync-options LIST` | Space-separated list of options to pass to rsync |++**Examples:**++```bash+pushme --dry-run hera athena+pushme -f src,Documents -v hera clio+pushme --no-color hera athena+pushme --rsync-options "--delete-after --partial" hera clio+```++## Configuration Precedence++When the same option is specified in multiple places, pushme uses the following+precedence order (highest to lowest):++1. **Target-specific options** (in fileset's `Stores.<hostname>` section)+2. **Command-line options** (merged with fileset Common)+3. **Fileset Common** (in fileset's `Common` section)+4. **GlobalOptions** (in `config.yaml`)+5. **Built-in defaults**++### Merging Behavior++Options are merged using the following rules:++- **For Maybe fields** (Filters, Options, ReceiveFrom): Right side wins (later+ definition completely overrides earlier one)+- **For Boolean flags** (NoDelete, PreserveAttrs, etc.): `true` wins if set+ anywhere (OR logic)+- **For Active flag**: Both must be `true` (AND logic)++**Example:** If you specify `Options` in both GlobalOptions and a target-+specific store, only the target-specific Options will be used. They are not+concatenated.++## Output Format++In non-verbose mode (default), pushme displays summary statistics for each+transfer:++```+Sending src → athena: 42.3M in 127 (1.2G in 1,234) [8s]+```++This shows:+- **42.3M** - actual data transferred (after compression/rsync delta)+- **127** - number of files transferred+- **1.2G** - total size of all files examined+- **1,234** - total number of files examined+- **[8s]** - time taken in seconds++With `--verbose`, full rsync output is displayed instead.++With `--no-color`, ANSI color codes are disabled (useful for logging or+terminals that don't support colors).++## Troubleshooting++### See what would be transferred without making changes++Use `--dry-run` to see what would be transferred without making any changes:++```bash+pushme --dry-run hera athena+```++### Debug transfer issues++Use `--verbose` to see detailed rsync output including which files are being+transferred:++```bash+pushme --verbose hera clio+```++With verbose mode, filter rules are also logged before each transfer.++### Color output appears as garbage++If ANSI color codes appear as garbage characters in your terminal or logs, use+`--no-color`:++```bash+pushme --no-color hera athena+```++Or set `NoColor: true` in `~/.config/pushme/config.yaml`.++### Filter rules not working as expected++1. Use `--verbose` to see the filter rules being passed to rsync+2. Test filter rules with rsync directly: `rsync -avn --include-from=filters.txt src/ dest/`+3. Remember that first matching rule wins+4. Check if patterns need to be anchored with `/` prefix++### No filesets found error++Ensure filesets are defined in `~/.config/pushme/filesets/*.yaml` (or your+custom config directory). Each fileset should have a `.yaml` extension.++## Building from Source++Using Nix (recommended):++```bash+nix develop # Enter development shell+nix build # Build the project+```++Using Cabal:++```bash+cabal build+cabal run pushme -- hera athena+```++## License++Copyright (C) 2025 John Wiegley+BSD3 License - see LICENSE file for details
pushme.cabal view
@@ -1,13 +1,15 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.2. -- -- see: https://github.com/sol/hpack ----- hash: abf40cc11ead58c2c28cd6cc91c5b6a82de8e5bdc28651c2f416b9da9fb8b397+-- hash: 93e1ed3e9d5288526ffc15bb5806db0e70174d9becf706a2a98b2293a510c89a name: pushme-version: 2.1.3-synopsis: Tool to synchronize directories with rsync, zfs or git-annex-description: Script I use for synchronizing data among machines.+version: 3.0.0+synopsis: Synchronize multiple filesets across machines using rsync+description: pushme is a wrapper around rsync allowing declarative filesets to be transferred between machines. The screenshot above shows pushme in action (where `push` is a script I use to call `pushme` with appropriate arguments based on which machine I'm running it from). category: System homepage: https://github.com/jwiegley/pushme#readme bug-reports: https://github.com/jwiegley/pushme/issues@@ -16,7 +18,6 @@ license: BSD3 license-file: LICENSE build-type: Simple-cabal-version: >= 1.10 extra-source-files: README.md @@ -28,35 +29,31 @@ main-is: Main.hs other-modules: Pushme.Options- ghc-options: -threaded+ ghc-options: -Wall -Wno-missing-home-modules -threaded -rtsopts -with-rtsopts=-N build-depends:- aeson- , base >=4.7 && <5.0- , bytestring >=0.10 && <0.11- , containers >=0.5 && <0.6- , foldl- , io-storage >=0.3 && <0.4- , lens >=4.9 && <5.0- , logging >=3.0 && <3.1- , monad-logger >=0.3 && <0.4- , old-locale >=1.0 && <1.1- , optparse-applicative >=0.10 && <1.0- , parallel-io >=0.3 && <0.4- , pipes- , pipes-group- , pipes-safe- , pipes-text- , regex-posix >=0.95 && <1.0- , safe >=0.3 && <0.4- , shelly >=1.6 && <2.0- , system-fileio >=0.3 && <0.4- , system-filepath >=0.4 && <0.5- , temporary >=1.2 && <2.0- , text >=1.2 && <1.3- , text-format >=0.3 && <0.4- , time >=1.4 && <2.0- , transformers >=0.3 && <0.6- , unix >=2.6 && <2.8- , unordered-containers >=0.2 && <0.3- , yaml+ aeson >=1.0 && <2.3+ , base >=4.7 && <4.21+ , bytestring >=0.10 && <0.13+ , containers >=0.6 && <0.8+ , directory >=1.2 && <1.4+ , filepath >=1.4 && <1.6+ , foldl ==1.4.*+ , lens >=4.9 && <5.4+ , logging >=3.0.6 && <3.1+ , monad-logger ==0.3.*+ , old-locale ==1.0.*+ , optparse-applicative >=0.10 && <0.19+ , parallel-io ==0.3.*+ , pretty-show ==1.10.*+ , process ==1.6.*+ , regex-posix >=0.95 && <0.97+ , system-fileio ==0.3.*+ , system-filepath ==0.4.*+ , temporary >=1.2 && <1.4+ , text >=1.2 && <2.2+ , time >=1.4 && <1.15+ , transformers >=0.3 && <0.7+ , unix >=2.6 && <2.9+ , unordered-containers ==0.2.*+ , yaml ==0.11.* default-language: Haskell2010