diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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" ".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/.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 diff --git a/Pushme/Options.hs b/Pushme/Options.hs --- a/Pushme/Options.hs +++ b/Pushme/Options.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 +![Image of pushme in operation](./pushall-example.jpg) - 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.` 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 diff --git a/pushme.cabal b/pushme.cabal --- a/pushme.cabal +++ b/pushme.cabal @@ -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