pushme 2.0.2 → 2.1.1
raw patch · 2 files changed
+135/−180 lines, 2 filesdep ~aesondep ~shellydep ~time
Dependency ranges changed: aeson, shelly, time, yaml
Files
- Main.hs +76/−132
- pushme.cabal +59/−48
Main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-}@@ -11,149 +10,61 @@ 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 hiding (argument)+import Control.Lens import Control.Logging import Control.Monad import Control.Monad.Trans.Reader-import Data.Aeson+import Data.Aeson hiding (Options) import qualified Data.ByteString as B (readFile) import Data.Char (isDigit)-import Data.Data (Data) 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.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.Typeable (Typeable) import Data.Yaml (decode) import Filesystem import Filesystem.Path.CurrentOS hiding (null, concat) import GHC.Conc (setNumCapabilities)-import Options.Applicative hiding (Success, (&)) import Pipes as P import qualified Pipes.Group as P import qualified Pipes.Prelude as P-import Pipes.Safe as P hiding (try, finally)+import Pipes.Safe as P hiding (finally) import qualified Pipes.Text as Text-import qualified Pipes.Text.Encoding 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 ((</>), find, trace)+import Shelly.Lifted hiding ((</>)) import Text.Printf (printf) import Text.Regex.Posix ((=~)) --import Debug.Trace -version :: String-version = "2.0.0.1"--copyright :: String-copyright = "2013-4"--pushmeSummary :: String-pushmeSummary =- "pushme " ++ version ++ ", (C) " ++ copyright ++ " John Wiegley"--data Options = Options- { jobs :: Int- , dryRun :: Bool- , noSync :: Bool- , copyAll :: Bool- , dump :: Bool- , ssh :: String- , rsyncOpt :: String- , checksum :: Bool- , fromName :: String- , filesets :: String- , classes :: String- , siUnits :: Bool- , verbose :: Bool- , quiet :: Bool- , cliArgs :: [String]- }- deriving (Data, Typeable, Show, Eq)--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")- <*> switch- ( long "checksum"- <> help "Pass --checksum flag to rsync")- <*> strOption- ( long "from"- <> value ""- <> help "Provide the name of the current host")- <*> strOption- ( short 'f'- <> long "filesets"- <> value ""- <> help "Synchronize the given fileset(s) (comma-sep)")- <*> strOption- ( short 'c'- <> long "classes"- <> value ""- <> help "Filesets classes to synchronize (comma-sep)")- <*> switch- ( long "si"- <> help "Use 1000 instead of 1024 to divide")- <*> switch- ( 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"))- data Rsync = Rsync { _rsyncPath :: FilePath , _rsyncName :: Maybe Text , _rsyncFilters :: [Text] , _rsyncReportMissing :: Bool+ , _rsyncSendOnly :: Bool+ , _rsyncReceiveOnly :: Bool+ , _rsyncReceiveFrom :: Maybe [Text] } deriving (Show, Eq) defaultRsync :: FilePath -> Rsync-defaultRsync p = Rsync p Nothing [] False+defaultRsync p = Rsync p Nothing [] False False False Nothing instance FromJSON FilePath where parseJSON = fmap fromText . parseJSON@@ -164,6 +75,9 @@ <*> v .:? "Host" <*> v .:? "Filters" .!= [] <*> v .:? "ReportMissing" .!= False+ <*> v .:? "SendOnly" .!= False+ <*> v .:? "ReceiveOnly" .!= False+ <*> v .:? "ReceiveFrom" .!= Nothing parseJSON _ = errorL "Error parsing Rsync" makeLenses ''Rsync@@ -209,7 +123,7 @@ makePrisms ''StorageScheme -data Store = Store+newtype Store = Store { _schemes :: Map Text StorageScheme } deriving (Show, Eq) @@ -265,6 +179,10 @@ 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' "ReceiveFrom" xs =+ fs' & stores.traverse.rsyncScheme.rsyncReceiveFrom <>~ fromJSON' xs k fs' _ _ = fs' f fs "Zfs" = const fs@@ -338,7 +256,7 @@ main :: IO () main = withStdoutLogging $ do- opts <- execParser optsDef+ opts <- getOptions when (dryRun opts || noSync opts) $ warn' "`--dryrun' specified, no changes will be made!"@@ -350,10 +268,6 @@ hosts <- readHostsFile processBindings opts hosts `finally` stopGlobalPool- where- optsDef = info- (helper <*> pushmeOpts)- (fullDesc <> progDesc "" <> header pushmeSummary) readHostsFile :: IO (Map Text Host) readHostsFile = do@@ -404,7 +318,9 @@ fsets <- readFilesets thisHost <- T.init <$> shelly (silently $ cmd "hostname") let dflt = defaultHost (pack (fromName opts))- here = hosts^.at thisHost.non dflt.hostName+ 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_@@ -415,14 +331,14 @@ -> [Binding] relevantBindings opts thisHost hosts fsets = sortBy (comparing (^.fileset.fsPriority))- $ filter matching- $ catMaybes+ . filter matching'+ . catMaybes $ createBinding <$> M.elems fsets <*> pure thisHost <*> map pack (cliArgs opts) where- matching bnd =+ matching' bnd = (T.null fss || matchText fss (fs^.fsName)) && (T.null cls || matchText cls (fs^.fsClass)) where@@ -497,7 +413,7 @@ checkDirectory :: Binding -> FilePath -> Bool -> App Bool checkDirectory _ path False = test_d path checkDirectory (isLocal -> True) path True = test_d path-checkDirectory bnd path True = return True -- do+checkDirectory _bnd _path True = return True -- do -- execute (env bnd) "test" ["-d", toTextIgnore path] -- (== 0) <$> lastExitCode @@ -603,9 +519,9 @@ let p = toTextIgnore $ (zfs^.zfsPath) </> ".zfs" </> "snapshot" fmap lastMay $ sort- <$> map (read . unpack)- <$> filter (T.all isDigit)- <$> T.lines+ . map (read . unpack)+ . filter (T.all isDigit)+ . T.lines <$> execute env' "ls" ["-1", p] syncUsingRsync :: Binding -> Store -> Store -> App ()@@ -615,15 +531,17 @@ if exists1 && exists2 then rsync- (bnd^.fileset)+ bnd (fromMaybe (defaultRsync l) (s1^?rsyncScheme)) l (fromMaybe (defaultRsync r) (s2^?rsyncScheme)) (case h of Nothing -> toTextIgnore r- Just targ -> format "{}:{}" [targ, escape (toTextIgnore r)])+ Just targ -> format "{}:{}" [targ, toTextIgnore r]) - else liftIO $ warn $ "Remote directory missing: " <> 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@@ -634,21 +552,44 @@ Just (asDirectory -> l) = getStorePath bnd s1 False Just (asDirectory -> r) = getStorePath bnd s2 True -rsync :: Fileset -> Rsync -> FilePath -> Rsync -> Text -> App ()-rsync fs srcRsync src destRsync dest = do- let rfs = (srcRsync^.rsyncFilters) <> (destRsync^.rsyncFilters)- go xs = doRsync (fs^.fsName) xs (toTextIgnore src) dest- case rfs of- [] -> go []+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)+ go xs = doRsync (fs^.fsName) xs (toTextIgnore src) dest+ case rfs of+ [] -> go [] - filters -> do- when (srcRsync^.rsyncReportMissing) $- liftIO $ reportMissingFiles fs srcRsync+ 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]+ 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 =@@ -722,7 +663,9 @@ then rsyncCmd else "rsync") | toRemote] <> options- <> [src, dest]+ <> [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@@ -796,7 +739,8 @@ then return "" else do n <- findCmd name''- liftIO $ debug' $ format "{} {}" [toTextIgnore n, tshow args'']+ liftIO $ debug' $ format "{} {}"+ [ toTextIgnore n, T.intercalate " " (map tshow args'') ] runner' n args'' where findCmd n
pushme.cabal view
@@ -1,52 +1,63 @@-Name: pushme-Version: 2.0.2-Synopsis: Tool to synchronize directories with rsync, zfs or git-annex-Homepage: https://github.com/jwiegley/pushme-License: BSD3-License-file: LICENSE-Author: John Wiegley-Maintainer: John Wiegley <johnw@newartisans.com>-Category: Development-Build-type: Simple-Cabal-version: >= 1.8-Description: Script I use for synchronizing my data among machines.+-- This file has been generated from package.yaml by hpack version 0.21.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4dd172a5ea6fa754c4e33bf4e491f4cb405e6b9770e2bc094176b875b320957d -Extra-Source-Files: README.md+name: pushme+version: 2.1.1+synopsis: Tool to synchronize directories with rsync, zfs or git-annex+description: Script I use for synchronizing data among machines.+category: System+homepage: https://github.com/jwiegley/pushme#readme+bug-reports: https://github.com/jwiegley/pushme/issues+author: John Wiegley+maintainer: johnw@newartisans.com+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10 -Executable pushme- Main-is: Main.hs- Ghc-options: -threaded- Build-depends:- base >= 4.7 && < 5.0- , aeson >= 0.7 && < 0.12- , bytestring >= 0.10 && < 0.11- , pipes- , pipes-group- , pipes-safe- , pipes-text- , foldl- , containers >= 0.5 && < 0.6- , 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- , regex-posix >= 0.95 && < 1.0- , safe >= 0.3 && < 0.4- , shelly >= 1.6 && < 1.7- , system-fileio >= 0.3 && < 0.4- , system-filepath >= 0.4 && < 0.5- , temporary >= 1.2 && < 1.3- , text >= 1.2 && < 1.3- , text-format >= 0.3 && < 0.4- , time >= 1.4 && < 1.7- , transformers >= 0.3 && < 0.6- , unix >= 2.6 && < 2.8- , unordered-containers >= 0.2 && < 0.3- , yaml >= 0.8 && < 0.9+extra-source-files:+ README.md -Source-repository head- type: git+source-repository head+ type: git location: https://github.com/jwiegley/pushme++executable pushme+ main-is: Main.hs+ other-modules:+ Paths_pushme+ ghc-options: -threaded+ 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 && <1.8+ , system-fileio >=0.3 && <0.4+ , system-filepath >=0.4 && <0.5+ , temporary >=1.2 && <1.3+ , 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+ default-language: Haskell2010