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