pushme 3.0.0 → 3.1.0
raw patch · 8 files changed
+1190/−483 lines, 8 filesdep +hedgehogdep +pushmedep +tasty
Dependencies added: hedgehog, pushme, tasty, tasty-hedgehog
Files
- LICENSE +0/−28
- LICENSE.md +28/−0
- Main.hs +536/−251
- Pushme/Options.hs +0/−196
- README.md +18/−3
- pushme.cabal +82/−5
- src/Pushme/Options.hs +352/−0
- test/Main.hs +174/−0
− LICENSE
@@ -1,28 +0,0 @@-Copyright (c) 2003-2009, John Wiegley. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--- Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.--- Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.--- Neither the name of New Artisans LLC nor the names of its- contributors may be used to endorse or promote products derived from- this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ LICENSE.md view
@@ -0,0 +1,28 @@+Copyright (c) 2012-2026, John Wiegley. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++- Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++- Neither the name of New Artisans LLC nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -14,9 +15,11 @@ 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.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.ParallelIO (parallel, parallel_, stopGlobalPool)+import Control.Concurrent.QSem (QSem, newQSem, signalQSem, waitQSem)+import Control.Exception (finally) import Control.Lens import Control.Logging import Control.Monad (guard, unless, when)@@ -24,45 +27,54 @@ import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Data.Aeson hiding (Options) import Data.Aeson.Types (Parser)+import qualified Data.ByteString as BS import Data.Function (on)-import Data.List (foldl', isSuffixOf, sortOn, (\\))+import Data.List (isInfixOf, isSuffixOf, sortOn, (\\)) import Data.Map (Map) import qualified Data.Map as M-import Data.Maybe- ( fromJust,- fromMaybe,- maybeToList,- )+import Data.Maybe (+ fromJust,+ fromMaybe,+ maybeToList,+ ) import Data.Text (Text, pack, unpack) import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE 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.Directory (+ doesDirectoryExist,+ getHomeDirectory,+ listDirectory,+ ) import System.Exit (ExitCode (..))-import System.FilePath.Posix- ( takeExtension,- (</>),- )-import System.IO (hClose)+import System.FilePath.Posix (+ takeExtension,+ (</>),+ )+import System.IO (hClose, hPutStr, hSetBinaryMode) import System.IO.Temp (withSystemTempFile) import System.Process hiding (env) import Text.Printf (printf) import Text.Regex.Posix ((=~)) import Text.Show.Pretty (ppShow) +data TransferStatus = TransferSuccess | TransferWarning | TransferError+ deriving (Show, Eq, Ord)++data SyncDirection = Push | Pull+ deriving (Show, Eq, Ord)+ data Fileset = Fileset- { _filesetName :: Text,- _filesetClasses :: Maybe [Text],- _filesetPriority :: Int,- _filesetStores :: Map Text (FilePath, RsyncOptions),- _filesetCommon :: Maybe RsyncOptions+ { _filesetName :: Text+ , _filesetClasses :: Maybe [Text]+ , _filesetPriority :: Int+ , _filesetStores :: Map Text (FilePath, RsyncOptions)+ , _filesetCommon :: Maybe RsyncOptions } deriving (Show, Eq) @@ -72,22 +84,29 @@ decodeEnrichedOptions m = parseM (m ^. at "Path") >>= \case Nothing -> fail "Missing value for Path"- Just path ->+ Just path -> do+ preserveAll <- parseM (m ^. at "PreserveAttrs") (path,) <$> ( RsyncOptions <$> parseM (m ^. at "Filters")+ <*> parseM (m ^. at "ExtraFilters") <*> (fromMaybe False <$> parseM (m ^. at "NoBasicOptions")) <*> (fromMaybe False <$> parseM (m ^. at "NoDelete"))- <*> (fromMaybe False <$> parseM (m ^. at "PreserveAttrs"))+ <*> ((<|> preserveAll) <$> parseM (m ^. at "PreserveACLs"))+ <*> ((<|> preserveAll) <$> parseM (m ^. at "PreserveXattrs"))+ <*> ((<|> preserveAll) <$> parseM (m ^. at "PreserveAtimes"))+ <*> ((<|> preserveAll) <$> parseM (m ^. at "PreserveCrtimes"))+ <*> ((<|> preserveAll) <$> parseM (m ^. at "PreserveHardLinks"))+ <*> ((<|> preserveAll) <$> parseM (m ^. at "PreserveExecutability")) <*> (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+ 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) =@@ -100,8 +119,8 @@ parseJSON _ = errorL "Error parsing Fileset" data Host = Host- { _hostName :: Text,- _hostMaxJobs :: Int+ { _hostName :: Text+ , _hostMaxJobs :: Int } deriving (Show, Eq, Ord) @@ -113,25 +132,116 @@ [n, j] -> Host n (read (unpack j)) _ -> errorL $ "Cannot parse hostname: " <> name +-- | Extract Host from HostRef for compatibility+hostFromRef :: HostRef -> Host+hostFromRef ref =+ let (name, jobs) = ref ^. hostRefActualHost+ in Host name jobs++{- | Parse a host reference from CLI argument, checking aliases first.+Supports @N suffix for overriding MaxJobs on both raw hostnames and aliases.+Examples: "hera@24", "tank@8" (where tank is an alias)+-}+parseHostRef :: Options -> Text -> HostRef+parseHostRef opts name =+ let (baseName, overrideJobs) = case T.split (== '@') name of+ [n] -> (n, Nothing)+ [n, j] -> (n, Just (read (unpack j)))+ _ -> errorL $ "Cannot parse host reference: " <> name+ in case opts ^. optsAliases . at baseName of+ Just alias ->+ let (actualName, actualJobs) = case alias ^. aliasHost of+ h+ | "@" `T.isInfixOf` h ->+ let [n, j] = T.split (== '@') h+ in (n, read (unpack j))+ h -> (h, fromMaybe 1 (alias ^. aliasMaxJobs))+ -- Use override from CLI if provided, otherwise use alias config+ finalJobs = fromMaybe actualJobs overrideJobs+ in HostRef+ { _hostRefLogicalName = baseName+ , _hostRefActualHost = (actualName, finalJobs)+ , _hostRefVariables = alias ^. aliasVariables+ , _hostRefOptions = alias ^. aliasOptions+ }+ Nothing ->+ let host = parseHost baseName+ finalJobs = fromMaybe (host ^. hostMaxJobs) overrideJobs+ in HostRef+ { _hostRefLogicalName = baseName+ , _hostRefActualHost = (baseName, finalJobs)+ , _hostRefVariables = M.empty+ , _hostRefOptions = Nothing+ }++{- | Interpolate all $variable references in a path using the provided variable map.+Variable names must match pattern: $[a-zA-Z_][a-zA-Z0-9_]*+Throws error if a variable is referenced but not defined in the map.+-}+interpolatePath :: Map Text Text -> FilePath -> FilePath+interpolatePath variables path+ | "$" `isInfixOf` path = interpolateText variables path+ | otherwise = path+ where+ -- Regex pattern for variable names: $[a-zA-Z_][a-zA-Z0-9_]*+ varPattern :: String+ varPattern = "\\$[a-zA-Z_][a-zA-Z0-9_]*"++ -- Find all variable references and replace them+ interpolateText :: Map Text Text -> String -> String+ interpolateText vars txt =+ let matches = txt =~ varPattern :: [[String]]+ varRefs = [m | (m : _) <- matches] -- Safe head extraction with pattern match+ in if null varRefs+ then txt+ else foldl (replaceVar vars) txt varRefs++ -- Replace a single variable reference with its value+ replaceVar :: Map Text Text -> String -> String -> String+ replaceVar vars txt varRef =+ let varName = pack $ drop 1 varRef -- Remove leading $ and convert to Text+ in case M.lookup varName vars of+ Nothing ->+ error $+ "Path contains undefined variable "+ <> varRef+ <> " in path: "+ <> path+ <> "\nAvailable variables: "+ <> show (M.keys vars)+ Just value ->+ let result = T.replace (pack varRef) value (pack txt)+ in unpack result+ data Binding = Binding- { _bindingFileset :: Fileset,- _bindingSourceHost :: Host,- _bindingSourcePath :: FilePath,- _bindingTargetHost :: Host,- _bindingTargetPath :: FilePath,- _bindingRsyncOpts :: RsyncOptions+ { _bindingFileset :: Fileset+ , _bindingSourceHost :: HostRef+ , _bindingSourcePath :: FilePath+ , _bindingTargetHost :: HostRef+ , _bindingTargetPath :: FilePath+ , _bindingRsyncOpts :: RsyncOptions+ , _bindingDirection :: SyncDirection } deriving (Show, Eq) makeLenses ''Binding +bindingRemoteHost :: Binding -> HostRef+bindingRemoteHost bnd = case bnd ^. bindingDirection of+ Push -> bnd ^. bindingTargetHost+ Pull -> bnd ^. bindingSourceHost+ isLocal :: Binding -> Bool-isLocal bnd = bnd ^. bindingSourceHost == bnd ^. bindingTargetHost+isLocal bnd =+ fst (bnd ^. bindingSourceHost . hostRefActualHost)+ == fst (bnd ^. bindingTargetHost . hostRefActualHost) remoteHost :: Binding -> Maybe Host remoteHost bnd | isLocal bnd = Nothing- | otherwise = Just (bnd ^. bindingTargetHost)+ | otherwise = case bnd ^. bindingDirection of+ Push -> Just (hostFromRef (bnd ^. bindingTargetHost))+ Pull -> Just (hostFromRef (bnd ^. bindingSourceHost)) type App a = ReaderT Options IO a @@ -141,7 +251,7 @@ configOpts <- readYaml =<< expandPath (cmdLineOpts ^. optsConfigDir </> "config.yaml")- let opts = configOpts <> cmdLineOpts+ let opts = resolveOptionsFilterReferences (configOpts <> cmdLineOpts) setLogLevel $ if opts ^. optsVerbose then LevelDebug else LevelInfo setLogTimeFormat "%H:%M:%S"@@ -161,128 +271,217 @@ case opts ^. optsCliArgs of host : hosts@(_ : _) -> liftIO do fsets <- traverse expandFilesetPaths =<< readFilesets opts- let here = parseHost (pack host)+ -- Determine direction: --reverse flag or auto-detect from hostname+ localHostname <-+ T.toLower . T.takeWhile (/= '.') . T.strip . pack+ <$> readProcess "hostname" ["-s"] ""+ debug' $ "Local hostname: " <> localHostname+ let hereRef = parseHostRef opts (pack host)+ allHostRefs = map (parseHostRef opts . pack) hosts+ resolvedName ref =+ T.toLower $ T.takeWhile (/= '.') $ fst (ref ^. hostRefActualHost)+ matchesLocal ref =+ resolvedName ref == localHostname+ || T.toLower (ref ^. hostRefLogicalName) == localHostname+ -- Auto-detect: if first arg is not local, find the local host+ -- among the remaining args and treat as reverse (pull) mode+ (here, remoteRefs, pullMode)+ | opts ^. optsReverse = (hereRef, allHostRefs, True)+ | not (matchesLocal hereRef) =+ case filter matchesLocal allHostRefs of+ (localRef : _) ->+ (localRef, hereRef : filter (/= localRef) allHostRefs, True)+ [] -> (hereRef, allHostRefs, False)+ | otherwise = (hereRef, allHostRefs, False) bindings =- relevantBindings- opts- here- fsets- (map (parseHost . pack) hosts)+ relevantBindings opts here fsets remoteRefs pullMode+ when pullMode $+ debug' "Reverse mode: pulling from remote hosts" debug' $ "Local host "- <> here ^. hostName+ <> fst (here ^. hostRefActualHost) <> " with "- <> tshow (here ^. hostMaxJobs)- <> " sending jobs"- hereSlots <- newQSem (here ^. hostMaxJobs)+ <> tshow (snd (here ^. hostRefActualHost))+ <> (if pullMode then " receiving" else " sending")+ <> " jobs"+ hereSlots <- newQSem (snd (here ^. hostRefActualHost)) thereSlotsAll <- forM (M.keys bindings) $ \there -> do debug' $ "Remote host "- <> there ^. hostName+ <> fst (there ^. hostRefActualHost) <> " with "- <> tshow (there ^. hostMaxJobs)+ <> tshow (snd (there ^. hostRefActualHost)) <> " receiving jobs"- newQSem (there ^. hostMaxJobs)+ newQSem (snd (there ^. hostRefActualHost)) 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"+ where+ -- Process all bindings for a single destination host+ goHost opts p q (there, bnds) = do+ -- Process all bindings for this host in parallel and collect statuses+ statuses <- parallel (map (go opts p q) bnds)+ -- After all bindings for this host are done, print completion message+ unless (null bnds) $ do+ let overallStatus = maximum statuses -- TransferError > TransferWarning > TransferSuccess+ suffix = case overallStatus of+ TransferSuccess -> ""+ TransferWarning -> " (with warnings)"+ TransferError -> " (with errors)"+ msg = (there ^. hostRefLogicalName) <> " done" <> suffix+ coloredMsg =+ if opts ^. optsNoColor+ then msg+ else case overallStatus of+ TransferSuccess -> "\ESC[32m" <> msg <> "\ESC[0m"+ TransferWarning -> "\ESC[33m" <> msg <> "\ESC[0m"+ TransferError -> "\ESC[31m" <> msg <> "\ESC[0m"+ -- Use log' for completion messages since they're informational+ -- (all transfers done), with color/suffix indicating status+ log' coloredMsg - go opts p q bnd =- bracket_ (waitQSem p) (signalQSem p) $- bracket_ (waitQSem q) (signalQSem q) $- runReaderT (applyBinding bnd) opts+ go :: Options -> QSem -> QSem -> Binding -> IO TransferStatus+ go opts p q bnd = do+ waitQSem p+ (waitQSem q >> runReaderT (applyBinding bnd) opts)+ `finally` (signalQSem q >> signalQSem p) - applyBinding :: Binding -> App ()- applyBinding bnd = do- log' $+ applyBinding :: Binding -> App TransferStatus+ applyBinding bnd = do+ log' $ case bnd ^. bindingDirection of+ Push -> "Sending " <> (bnd ^. bindingFileset . filesetName) <> " → "- <> (bnd ^. bindingTargetHost . hostName)- debug' $ pack (ppShow bnd)- syncStores- bnd- (bnd ^. bindingSourcePath)- (bnd ^. bindingTargetPath)- (bnd ^. bindingRsyncOpts)+ <> (bnd ^. bindingTargetHost . hostRefLogicalName)+ Pull ->+ "Receiving "+ <> (bnd ^. bindingFileset . filesetName)+ <> " ← "+ <> (bnd ^. bindingSourceHost . hostRefLogicalName)+ 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+ relevantBindings ::+ Options ->+ HostRef ->+ Map Text Fileset ->+ [HostRef] ->+ Bool ->+ Map HostRef [Binding]+ relevantBindings opts here fsets hosts pullMode =+ M.map+ (sortOn (^. bindingFileset . filesetPriority))+ (collect bindingRemoteHost bindings)+ where+ bindings :: [Binding]+ bindings = do+ fset <- M.elems fsets+ there <- hosts+ maybeToList $+ if pullMode+ then buildPullBinding fset there+ else buildPushBinding fset there - 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)+ buildPushBinding :: Fileset -> HostRef -> Maybe Binding+ buildPushBinding fset there = do+ (src, _) <- fset ^. filesetStores . at (here ^. hostRefLogicalName)+ (dest, destOpts) <- fset ^. filesetStores . at (there ^. hostRefLogicalName)+ guard $+ not+ ( maybe+ False+ (not . (here ^. hostRefLogicalName `elem`))+ (destOpts ^. rsyncReceiveFrom)+ )+ let !srcPath = interpolatePath (here ^. hostRefVariables) src+ !destPath = interpolatePath (there ^. hostRefVariables) dest+ binding =+ Binding+ { _bindingFileset = fset+ , _bindingSourceHost = here+ , _bindingSourcePath = srcPath+ , _bindingTargetHost = there+ , _bindingTargetPath = destPath+ , _bindingRsyncOpts =+ case opts ^. optsRsyncOpts <> fset ^. filesetCommon of+ Nothing -> destOpts+ Just common -> common <> destOpts+ , _bindingDirection = Push+ }+ guard $ isMatching binding+ guard $ destOpts ^. rsyncActive+ pure binding - 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)+ buildPullBinding :: Fileset -> HostRef -> Maybe Binding+ buildPullBinding fset there = do+ (srcPath0, srcOpts) <- fset ^. filesetStores . at (there ^. hostRefLogicalName)+ (destPath0, destOpts) <- fset ^. filesetStores . at (here ^. hostRefLogicalName)+ -- ReceiveFrom: does local store allow receiving from remote?+ guard $+ not+ ( maybe+ False+ (not . (there ^. hostRefLogicalName `elem`))+ (destOpts ^. rsyncReceiveFrom)+ )+ let !srcPath = interpolatePath (there ^. hostRefVariables) srcPath0+ !destPath = interpolatePath (here ^. hostRefVariables) destPath0+ binding =+ Binding+ { _bindingFileset = fset+ , _bindingSourceHost = there+ , _bindingSourcePath = srcPath+ , _bindingTargetHost = here+ , _bindingTargetPath = destPath+ , _bindingRsyncOpts =+ case opts ^. optsRsyncOpts <> fset ^. filesetCommon of+ Nothing -> destOpts+ Just common -> common <> destOpts+ , _bindingDirection = Pull+ }+ guard $ isMatching binding+ guard $ srcOpts ^. rsyncActive+ guard $ destOpts ^. rsyncActive+ pure binding + isMatching :: Binding -> Bool+ isMatching bnd =+ (null fss || any (matchText (fs ^. filesetName)) fss)+ && (null cls || or (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 (fmap (resolveFilesetFilterReferences opts) . readYaml)+ . filter (\n -> takeExtension n == ".yaml")+ <&> M.fromList . map ((^. filesetName) &&& id)++ resolveFilesetFilterReferences :: Options -> Fileset -> Fileset+ resolveFilesetFilterReferences opts fs =+ let filterSets = opts ^. optsFilterSets+ in fs+ & filesetStores . traverse . _2 %~ resolveRsyncFilterReferences filterSets+ & filesetCommon . _Just %~ resolveRsyncFilterReferences filterSets+ checkDirectory :: Binding -> FilePath -> Bool -> App Bool checkDirectory _ path False = liftIO $ doesDirectoryExist path@@ -294,27 +493,36 @@ (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+ where+ escape :: Text -> Text+ escape x+ | "\"" `T.isInfixOf` x || " " `T.isInfixOf` x =+ "'" <> T.replace "\"" "\\\"" x <> "'"+ | otherwise = x -syncStores :: Binding -> FilePath -> FilePath -> RsyncOptions -> App ()+syncStores :: Binding -> FilePath -> FilePath -> RsyncOptions -> App TransferStatus syncStores bnd src dest roDest = do- exists <-- (&&)- <$> checkDirectory bnd l False- <*> checkDirectory bnd r True+ exists <- case bnd ^. bindingDirection of+ Push ->+ (&&)+ <$> checkDirectory bnd l False+ <*> checkDirectory bnd r True+ Pull ->+ (&&)+ <$> checkDirectory bnd l True+ <*> checkDirectory bnd r False 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+ let (localDir, remoteDir) = case bnd ^. bindingDirection of+ Push -> (l, r)+ Pull -> (r, l)+ warn $ "Either local directory missing: " <> pack localDir+ warn $ "OR remote directory missing: " <> pack remoteDir+ pure TransferError+ where+ (asDirectory -> l) = src+ (asDirectory -> r) = dest invokeRsync :: Binding ->@@ -322,54 +530,74 @@ RsyncOptions -> Maybe Host -> FilePath ->- App ()+ App TransferStatus invokeRsync bnd src roDest host dest = do opts <- ask withProtected $ \args1 ->- withFilters "Filters" (roDest ^. rsyncFilters) $ \args2 ->+ withFilters "Filters" (combineFilters (roDest ^. rsyncFilters) (roDest ^. rsyncExtraFilters)) $ \args2 -> doRsync- ( bnd ^. bindingTargetHost . hostName+ ( bindingRemoteHost bnd ^. hostRefLogicalName <> "/" <> bnd ^. bindingFileset . filesetName ) (rsyncArguments opts (args1 ++ args2))- where- withProtected k- | roDest ^. rsyncProtectTopLevel =- k ["--filter", "P /*"]- | otherwise = k []+ 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]+ 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))- ]+ rsyncArguments :: Options -> [Text] -> [Text]+ rsyncArguments opts args =+ ["-a" | not (roDest ^. rsyncNoBasicOptions)]+ <> ["-s"]+ <> ["--delete" | not (roDest ^. rsyncNoDelete)]+ <> ["-A" | roDest ^. rsyncPreserveACLs == Just True]+ <> ["-X" | roDest ^. rsyncPreserveXattrs == Just True]+ <> ["-U" | roDest ^. rsyncPreserveAtimes == Just True]+ <> ["-N" | roDest ^. rsyncPreserveCrtimes == Just True]+ <> ["-H" | roDest ^. rsyncPreserveHardLinks == Just True]+ <> ["-E" | roDest ^. rsyncPreserveExecutability == Just True]+ <> ["-n" | opts ^. optsDryRun]+ <> ( if opts ^. optsVerbose+ then ["-v"]+ else ["--stats"]+ )+ <> args+ <> fromMaybe [] (roDest ^. rsyncOptions)+ <> fromMaybe [] (bindingRemoteHost bnd ^. hostRefOptions)+ <> case bnd ^. bindingDirection of+ Push ->+ [ pack src+ , case host ^? _Just . hostName of+ Nothing -> pack dest+ Just h -> h <> ":" <> pack dest+ ]+ Pull ->+ [ case host ^? _Just . hostName of+ Nothing -> pack src+ Just h -> h <> ":" <> pack src+ , pack dest+ ] -doRsync :: Text -> [Text] -> App ()+doRsync :: Text -> [Text] -> App TransferStatus doRsync label args = do opts <- ask (ec, diff, output) <- execute Nothing "rsync" (map unpack args)+ let status = case ec of+ ExitSuccess -> TransferSuccess+ ExitFailure 23 -> TransferWarning -- Partial transfer+ ExitFailure 24 -> TransferWarning -- Vanished source files+ _ -> TransferError when (ec == ExitSuccess && not (opts ^. optsDryRun)) $ if opts ^. optsVerbose then liftIO $ putStr output@@ -407,52 +635,53 @@ <> 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+ pure status+ 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+ 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+ 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+ 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 ->@@ -466,34 +695,90 @@ Just h -> remote h (cmdName, args) runner p xs = liftIO $- timeFunction (readProcessWithExitCode p xs "")+ timeFunction (readProcessWithExitCodeLenient 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: "+ when (ec /= ExitSuccess) $ do+ let errLines = lines err+ numLines = length errLines+ truncatedErr =+ if numLines > 10+ then+ unlines (take 5 errLines)+ <> "... ("+ <> show (numLines - 10)+ <> " more lines) ...\n"+ <> unlines (drop (numLines - 5) errLines)+ else err+ -- Note: Using warn' instead of errorL' because we want to log the error+ -- but not throw an exception - the transfer status is tracked separately+ warn' $+ "Command failed: " <> pack cmdName <> " " <> pack (ppShow args) <> ": "- <> pack err+ <> pack truncatedErr 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)+ where+ -- Use binary I/O and lenient UTF-8 decoding to handle arbitrary byte sequences+ -- from rsync (e.g., filenames with non-UTF-8 characters)+ readProcessWithExitCodeLenient ::+ FilePath -> [String] -> String -> IO (ExitCode, String, String)+ readProcessWithExitCodeLenient cmd cmdArgs stdin = do+ let cp =+ (proc cmd cmdArgs)+ { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ (Just hIn, Just hOut, Just hErr, ph) <- createProcess cp - remote :: Host -> (FilePath, [String]) -> (FilePath, [String])- remote host (p, xs) =- ( "ssh",- unpack (host ^. hostName) : p : xs- )+ -- Set binary mode to avoid encoding issues+ hSetBinaryMode hOut True+ hSetBinaryMode hErr True+ hSetBinaryMode hIn True++ -- Write stdin and close+ hPutStr hIn stdin+ hClose hIn++ -- Read stdout and stderr concurrently to avoid deadlock+ outMVar <- newEmptyMVar+ errMVar <- newEmptyMVar++ _ <- forkIO $ do+ outBytes <- BS.hGetContents hOut+ let outStr = unpack $ TE.decodeUtf8With TEE.lenientDecode outBytes+ putMVar outMVar outStr++ _ <- forkIO $ do+ errBytes <- BS.hGetContents hErr+ let errStr = unpack $ TE.decodeUtf8With TEE.lenientDecode errBytes+ putMVar errMVar errStr++ -- Wait for both threads to finish+ outStr <- takeMVar outMVar+ errStr <- takeMVar errMVar++ exitCode <- waitForProcess ph+ pure (exitCode, outStr, errStr)++ 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
− Pushme/Options.hs
@@ -1,196 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--module Pushme.Options where--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 = "3.0.0"--copyright :: String-copyright = "2013-2025"--pushmeSummary :: String-pushmeSummary =- "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- { _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- <$> strOption- ( long "config"- <> value "~/.config/pushme"- <> help "Config directory (default: ~/.config/pushme)"- )- <*> switch- ( 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- ( short 's'- <> long "si-units"- <> help "Use 1000 instead of 1024 as a divisor"- )- <*> switch- ( short 'v'- <> long "verbose"- <> help "Report progress verbosely"- )- <*> switch- ( 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 :: ParserInfo Options-optionsDefinition =- info- (helper <*> pushmeOpts)- (fullDesc <> progDesc "" <> header pushmeSummary)--getOptions :: IO Options-getOptions = execParser optionsDefinition
README.md view
@@ -1,4 +1,4 @@-# pushme v3.0.0+# pushme v3.1.0  @@ -194,8 +194,23 @@ PreserveAttrs: true Options: - "--include-from=/Users/johnw/.config/ignore.lst"+# Named filter sets can be referenced by Filters or ExtraFilters as $name+Filters:+ srcFilters: |+ - *.o+ - dist-newstyle/+ - result+ - result-* ``` +Then a fileset can reuse that filter block anywhere `Filters` or+`ExtraFilters` is accepted:++```yaml+Common:+ Filters: $srcFilters+```+ ## Command-Line Options Options may also be specified using the command-line:@@ -333,5 +348,5 @@ ## License -Copyright (C) 2025 John Wiegley-BSD3 License - see LICENSE file for details+Copyright (C) 2012-2026 John Wiegley+BSD3 License - see LICENSE.md for details
pushme.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.2.+-- This file has been generated from package.yaml by hpack version 0.38.3. -- -- see: https://github.com/sol/hpack ----- hash: 93e1ed3e9d5288526ffc15bb5806db0e70174d9becf706a2a98b2293a510c89a+-- hash: e7cca68ebf44c964ff3417c2fb2c7748cb9f6d64fa5bf53af159c95ea5c65276 name: pushme-version: 3.0.0+version: 3.1.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@@ -16,7 +16,7 @@ author: John Wiegley maintainer: johnw@newartisans.com license: BSD3-license-file: LICENSE+license-file: LICENSE.md build-type: Simple extra-source-files: README.md@@ -25,10 +25,46 @@ type: git location: https://github.com/jwiegley/pushme +library+ exposed-modules:+ Pushme.Options+ other-modules:+ Paths_pushme+ hs-source-dirs:+ src+ ghc-options: -Wall -Wno-missing-home-modules+ build-depends:+ 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+ executable pushme main-is: Main.hs other-modules:- Pushme.Options+ Paths_pushme ghc-options: -Wall -Wno-missing-home-modules -threaded -rtsopts -with-rtsopts=-N build-depends: aeson >=1.0 && <2.3@@ -46,9 +82,50 @@ , parallel-io ==0.3.* , pretty-show ==1.10.* , process ==1.6.*+ , pushme , 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++test-suite pushme-tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_pushme+ hs-source-dirs:+ test+ ghc-options: -Wall -Wno-missing-home-modules -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ 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.*+ , hedgehog+ , 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.*+ , pushme+ , regex-posix >=0.95 && <0.97+ , system-fileio ==0.3.*+ , system-filepath ==0.4.*+ , tasty+ , tasty-hedgehog , temporary >=1.2 && <1.4 , text >=1.2 && <2.2 , time >=1.4 && <1.15
+ src/Pushme/Options.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Pushme.Options where++import Control.Lens hiding (argument)+import Control.Logging+import Control.Monad (forM_, when)+import Data.Aeson hiding (Options)+import Data.Aeson.Types (modifyFailure)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Text (Text, pack, unpack)+import qualified Data.Text as T+import Options.Applicative hiding (Success)+import Text.Regex.Posix ((=~))++version :: String+version = "3.1.0"++copyright :: String+copyright = "2012-2026"++pushmeSummary :: String+pushmeSummary =+ "pushme " ++ version ++ ", (C) " ++ copyright ++ " John Wiegley"++data RsyncOptions = RsyncOptions+ { _rsyncFilters :: Maybe Text+ , _rsyncExtraFilters :: Maybe Text+ , _rsyncNoBasicOptions :: Bool+ , _rsyncNoDelete :: Bool+ , _rsyncPreserveACLs :: Maybe Bool -- -A+ , _rsyncPreserveXattrs :: Maybe Bool -- -X+ , _rsyncPreserveAtimes :: Maybe Bool -- -U+ , _rsyncPreserveCrtimes :: Maybe Bool -- -N+ , _rsyncPreserveHardLinks :: Maybe Bool -- -H+ , _rsyncPreserveExecutability :: Maybe Bool -- -E+ , _rsyncProtectTopLevel :: Bool+ , _rsyncOptions :: Maybe [Text]+ , _rsyncReceiveFrom :: Maybe [Text]+ , _rsyncActive :: Bool+ }+ deriving (Show, Eq)++instance FromJSON RsyncOptions where+ parseJSON (Object v) = do+ preserveAll <- v .:? "PreserveAttrs"+ RsyncOptions+ <$> v .:? "Filters"+ <*> v .:? "ExtraFilters"+ <*> v .:? "NoBasicOptions" .!= False+ <*> v .:? "NoDelete" .!= False+ <*> ((<|> preserveAll) <$> v .:? "PreserveACLs")+ <*> ((<|> preserveAll) <$> v .:? "PreserveXattrs")+ <*> ((<|> preserveAll) <$> v .:? "PreserveAtimes")+ <*> ((<|> preserveAll) <$> v .:? "PreserveCrtimes")+ <*> ((<|> preserveAll) <$> v .:? "PreserveHardLinks")+ <*> ((<|> preserveAll) <$> v .:? "PreserveExecutability")+ <*> 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 i1 j1 k1 l1 m1 n1+ <> RsyncOptions a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 =+ RsyncOptions+ (a2 <|> a1) -- Filters+ (combineFilters b1 b2) -- ExtraFilters+ (c2 || c1) -- NoBasicOptions+ (d2 || d1) -- NoDelete+ (e2 <|> e1) -- PreserveACLs+ (f2 <|> f1) -- PreserveXattrs+ (g2 <|> g1) -- PreserveAtimes+ (h2 <|> h1) -- PreserveCrtimes+ (i2 <|> i1) -- PreserveHardLinks+ (j2 <|> j1) -- PreserveExecutability+ (k2 || k1) -- ProtectTopLevel+ (l2 <|> l1) -- Options+ (m2 <|> m1) -- ReceiveFrom+ (n2 && n1) -- Active++combineFilters :: Maybe Text -> Maybe Text -> Maybe Text+combineFilters Nothing Nothing = Nothing+combineFilters (Just a) Nothing = Just a+combineFilters Nothing (Just b) = Just b+combineFilters (Just a) (Just b) = Just (a <> "\n" <> b)++makeLenses ''RsyncOptions++{- | Interpolate all $filterSet references in rsync filter text.+Variable names must match pattern: $[a-zA-Z_][a-zA-Z0-9_]*.+-}+interpolateFilterReferences :: Map Text Text -> Text -> Text+interpolateFilterReferences filterSets filters+ | "$" `T.isInfixOf` filters = foldl replaceFilter filters filterRefs+ | otherwise = filters+ where+ varPattern :: String+ varPattern = "\\$[a-zA-Z_][a-zA-Z0-9_]*"++ filterRefs :: [String]+ filterRefs =+ [m | (m : _) <- unpack filters =~ varPattern :: [[String]]]++ replaceFilter :: Text -> String -> Text+ replaceFilter acc filterRef =+ let filterName = pack $ drop 1 filterRef+ in case M.lookup filterName filterSets of+ Nothing ->+ error $+ "Filter contains undefined filter set "+ <> filterRef+ <> "\nAvailable filter sets: "+ <> show (M.keys filterSets)+ Just filterText ->+ T.replace (pack filterRef) filterText acc++resolveRsyncFilterReferences :: Map Text Text -> RsyncOptions -> RsyncOptions+resolveRsyncFilterReferences filterSets opts =+ opts+ & rsyncFilters . _Just %~ interpolateFilterReferences filterSets+ & rsyncExtraFilters . _Just %~ interpolateFilterReferences filterSets++-- | Alias definition for host names with optional configuration overrides+data Alias = Alias+ { _aliasName :: Text+ , _aliasHost :: Text+ , _aliasMaxJobs :: Maybe Int+ , _aliasVariables :: Map Text Text+ , _aliasOptions :: Maybe [Text]+ }+ deriving (Show, Eq)++instance FromJSON Alias where+ parseJSON (Object v) = modifyFailure addContext $ do+ -- Parse Variables if present+ variables <- v .:? "Variables" .!= M.empty+ -- Check for legacy Prefix field and merge it+ legacyPrefix <- v .:? "Prefix"+ let finalVariables = case legacyPrefix of+ Just prefix -> M.insert "prefix" (pack prefix) variables+ Nothing -> variables+ -- Explicitly parse Host to provide better error message+ mHost <- v .:? "Host"+ host <- case mHost of+ Nothing -> fail "Missing required field 'Host' in alias definition"+ Just h -> pure h+ Alias "" host -- Name will be filled in from the Map key+ <$> v .:? "MaxJobs"+ <*> pure finalVariables+ <*> v .:? "Options"+ where+ addContext msg = "Error parsing Alias: " ++ msg+ parseJSON _ = errorL "Error parsing Alias"++makeLenses ''Alias++-- Note: Host type is defined in Main.hs as:+-- data Host = Host { _hostName :: Text, _hostMaxJobs :: Int }++-- | Host reference combining logical name (for fileset matching) with actual host details+data HostRef = HostRef+ { _hostRefLogicalName :: Text+ , _hostRefActualHost :: (Text, Int) -- (hostName, maxJobs) - avoiding circular dependency+ , _hostRefVariables :: Map Text Text+ , _hostRefOptions :: Maybe [Text] -- Per-host rsync options from alias+ }+ deriving (Show, Eq, Ord)++makeLenses ''HostRef++data Options = Options+ { _optsConfigDir :: FilePath+ , _optsDryRun :: Bool+ , _optsFilesets :: Maybe [Text]+ , _optsClasses :: Maybe [Text]+ , _optsSiUnits :: Bool+ , _optsVerbose :: Bool+ , _optsNoColor :: Bool+ , _optsReverse :: Bool+ , _optsRsyncOpts :: Maybe RsyncOptions+ , _optsAliases :: Map Text Alias+ , _optsFilterSets :: Map Text Text+ , _optsCliArgs :: [String]+ }+ deriving (Show, Eq)++instance FromJSON Options where+ parseJSON (Object v) = do+ aliasMap <- v .:? "Aliases" .!= M.empty+ -- Fill in the _aliasName field from the Map keys+ let aliasMapWithNames = M.mapWithKey (\k a -> a{_aliasName = k}) aliasMap+ -- Validate that all aliases have a non-empty Host field+ forM_ (M.toList aliasMapWithNames) $ \(name, alias) ->+ when (T.null (alias ^. aliasHost)) $+ fail $+ "Alias '" ++ unpack name ++ "' is missing required field 'Host'"+ Options+ <$> v .:? "Config" .!= "~/.config/pushme"+ <*> v .:? "DryRun" .!= False+ <*> v .:? "Filesets"+ <*> v .:? "Classes"+ <*> v .:? "SIUnits" .!= False+ <*> v .:? "Verbose" .!= False+ <*> v .:? "NoColor" .!= False+ <*> v .:? "Reverse" .!= False+ <*> v .:? "GlobalOptions"+ <*> pure aliasMapWithNames+ <*> v .:? "Filters" .!= M.empty+ <*> pure []+ parseJSON _ = errorL "Error parsing Options"++instance Semigroup Options where+ Options _a1 b1 c1 d1 e1 f1 g1 g1r h1 i1 j1 k1+ <> Options a2 b2 c2 d2 e2 f2 g2 g2r h2 i2 j2 k2 =+ Options+ a2+ (b2 || b1)+ (c2 <|> c1)+ (d2 <|> d1)+ (e2 || e1)+ (f2 || f1)+ (g2 || g1)+ (g2r || g1r)+ (h2 <> h1)+ (i2 <> i1) -- Right-biased merge: right Map wins on key conflicts+ (j2 <> j1)+ (k2 <|> k1)++makeLenses ''Options++resolveOptionsFilterReferences :: Options -> Options+resolveOptionsFilterReferences opts =+ opts+ & optsRsyncOpts . _Just %~ resolveRsyncFilterReferences (opts ^. optsFilterSets)++separated :: Char -> ReadM [Text]+separated c = T.split (== c) <$> str++pushmeOpts :: Parser Options+pushmeOpts =+ Options+ <$> strOption+ ( long "config"+ <> value "~/.config/pushme"+ <> help "Config directory (default: ~/.config/pushme)"+ )+ <*> switch+ ( 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+ ( short 's'+ <> long "si-units"+ <> help "Use 1000 instead of 1024 as a divisor"+ )+ <*> switch+ ( short 'v'+ <> long "verbose"+ <> help "Report progress verbosely"+ )+ <*> switch+ ( long "no-color"+ <> help "Do not use ANSI colors in report output"+ )+ <*> switch+ ( short 'R'+ <> long "reverse"+ <> help "Pull from remote hosts instead of pushing to them"+ )+ <*> optional+ ( ( \filters noBasic noDelete preserveAll protectTop opts ->+ let mPreserve = if preserveAll then Just True else Nothing+ in RsyncOptions+ filters+ Nothing+ noBasic+ noDelete+ mPreserve+ mPreserve+ mPreserve+ mPreserve+ mPreserve+ mPreserve+ protectTop+ opts+ Nothing+ True+ )+ <$> 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 (-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 M.empty -- Aliases come from config file, not CLI+ <*> pure M.empty -- Filter sets come from config file, not CLI+ <*> many (argument (eitherReader Right) (metavar "ARGS"))++optionsDefinition :: ParserInfo Options+optionsDefinition =+ info+ (helper <*> pushmeOpts)+ (fullDesc <> progDesc "" <> header pushmeSummary)++getOptions :: IO Options+getOptions = execParser optionsDefinition
+ test/Main.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Data.ByteString.Char8 as B+import qualified Data.Map.Strict as M+import Data.Text (Text)+import Data.Yaml (ParseException, decodeEither')+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Pushme.Options+import Test.Tasty+import Test.Tasty.Hedgehog++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+ testGroup+ "pushme"+ [ testGroup+ "combineFilters"+ [ testProperty "Nothing is left identity" prop_combineFilters_leftId+ , testProperty "Nothing is right identity" prop_combineFilters_rightId+ , testProperty "associative" prop_combineFilters_assoc+ , testProperty "both Just concatenates with newline" prop_combineFilters_concat+ ]+ , testGroup+ "RsyncOptions Semigroup"+ [ testProperty "associative" prop_rsyncOptions_assoc+ ]+ , testGroup+ "filter set references"+ [ testProperty "interpolates a named filter set" prop_filterReference_exact+ , testProperty "resolves Filters and ExtraFilters" prop_resolveRsyncFilterReferences+ , testProperty "parses and resolves config filter sets" prop_optionsParseFilterSets+ ]+ ]++-- Generators++genText :: Gen Text+genText = Gen.text (Range.linear 0 50) Gen.alphaNum++genMaybeText :: Gen (Maybe Text)+genMaybeText = Gen.maybe genText++genMaybeTextList :: Gen (Maybe [Text])+genMaybeTextList = Gen.maybe (Gen.list (Range.linear 0 5) genText)++genMaybeBool :: Gen (Maybe Bool)+genMaybeBool = Gen.maybe Gen.bool++genRsyncOptions :: Gen RsyncOptions+genRsyncOptions =+ RsyncOptions+ <$> genMaybeText+ <*> genMaybeText+ <*> Gen.bool+ <*> Gen.bool+ <*> genMaybeBool -- PreserveACLs+ <*> genMaybeBool -- PreserveXattrs+ <*> genMaybeBool -- PreserveAtimes+ <*> genMaybeBool -- PreserveCrtimes+ <*> genMaybeBool -- PreserveHardLinks+ <*> genMaybeBool -- PreserveExecutability+ <*> Gen.bool+ <*> genMaybeTextList+ <*> genMaybeTextList+ <*> Gen.bool++emptyRsyncOptions :: RsyncOptions+emptyRsyncOptions =+ RsyncOptions+ Nothing+ Nothing+ False+ False+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ False+ Nothing+ Nothing+ True++-- combineFilters properties++prop_combineFilters_leftId :: Property+prop_combineFilters_leftId = property $ do+ x <- forAll genMaybeText+ combineFilters Nothing x === x++prop_combineFilters_rightId :: Property+prop_combineFilters_rightId = property $ do+ x <- forAll genMaybeText+ combineFilters x Nothing === x++prop_combineFilters_assoc :: Property+prop_combineFilters_assoc = property $ do+ a <- forAll genMaybeText+ b <- forAll genMaybeText+ c <- forAll genMaybeText+ combineFilters (combineFilters a b) c === combineFilters a (combineFilters b c)++prop_combineFilters_concat :: Property+prop_combineFilters_concat = property $ do+ a <- forAll genText+ b <- forAll genText+ combineFilters (Just a) (Just b) === Just (a <> "\n" <> b)++-- RsyncOptions Semigroup properties++prop_rsyncOptions_assoc :: Property+prop_rsyncOptions_assoc = property $ do+ a <- forAll genRsyncOptions+ b <- forAll genRsyncOptions+ c <- forAll genRsyncOptions+ (a <> b) <> c === a <> (b <> c)++-- Filter set reference properties++prop_filterReference_exact :: Property+prop_filterReference_exact =+ property $+ interpolateFilterReferences+ (M.fromList [("srcFilters", "- dist/\n- result")])+ "$srcFilters"+ === "- dist/\n- result"++prop_resolveRsyncFilterReferences :: Property+prop_resolveRsyncFilterReferences = property $ do+ let filterSets =+ M.fromList+ [ ("commonFilters", "- dist/")+ , ("extraFilters", "- .cache/")+ ]+ resolved =+ resolveRsyncFilterReferences+ filterSets+ emptyRsyncOptions+ { _rsyncFilters = Just "$commonFilters"+ , _rsyncExtraFilters = Just "- tmp/\n$extraFilters"+ }+ _rsyncFilters resolved === Just "- dist/"+ _rsyncExtraFilters resolved === Just "- tmp/\n- .cache/"++prop_optionsParseFilterSets :: Property+prop_optionsParseFilterSets = property $+ case decodeEither' configYaml :: Either ParseException Options of+ Left err -> do+ annotateShow err+ failure+ Right opts -> do+ _optsFilterSets opts+ === M.fromList [("srcFilters", "- dist/\n- result\n")]+ fmap _rsyncFilters (_optsRsyncOpts (resolveOptionsFilterReferences opts))+ === Just (Just "- dist/\n- result\n")+ where+ configYaml =+ B.pack $+ unlines+ [ "Filters:"+ , " srcFilters: |"+ , " - dist/"+ , " - result"+ , "GlobalOptions:"+ , " Filters: $srcFilters"+ ]