diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -57,6 +57,7 @@ , _rsyncName :: Maybe Text , _rsyncFilters :: [Text] , _rsyncReportMissing :: Bool + , _rsyncNoLinks :: Bool , _rsyncSendOnly :: Bool , _rsyncReceiveOnly :: Bool , _rsyncReceiveFrom :: Maybe [Text] @@ -64,7 +65,7 @@ deriving (Show, Eq) defaultRsync :: FilePath -> Rsync -defaultRsync p = Rsync p Nothing [] False False False Nothing +defaultRsync p = Rsync p Nothing [] False False False False Nothing instance FromJSON FilePath where parseJSON = fmap fromText . parseJSON @@ -75,6 +76,7 @@ <*> v .:? "Host" <*> v .:? "Filters" .!= [] <*> v .:? "ReportMissing" .!= False + <*> v .:? "NoLinks" .!= False <*> v .:? "SendOnly" .!= False <*> v .:? "ReceiveOnly" .!= False <*> v .:? "ReceiveFrom" .!= Nothing @@ -181,6 +183,12 @@ 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' @@ -266,12 +274,12 @@ setLogLevel $ if verbose opts then LevelDebug else LevelInfo setLogTimeFormat "%H:%M:%S" - hosts <- readHostsFile + hosts <- readHostsFile opts processBindings opts hosts `finally` stopGlobalPool -readHostsFile :: IO (Map Text Host) -readHostsFile = do - hostsFile <- getHomePath (".pushme" "hosts") +readHostsFile :: Options -> IO (Map Text Host) +readHostsFile opts = do + hostsFile <- expandPath (decodeString (configDir opts) "hosts") exists <- isFile hostsFile if exists then do @@ -292,13 +300,15 @@ filter (`notElem` [".", "..", ".DS_Store", ".localized"]) names forM_ properNames $ \name -> yield (topPath name) -readFilesets :: IO (Map Text Fileset) -readFilesets = do - confD <- getHomePath (".pushme" "conf.d") +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 ~/.pushme/conf.d/.yml" + <> "using files named " + <> T.pack (encodeString (decodeString (configDir opts) + "conf.d" ".yml")) fmap (M.fromList . map ((^.fsName) &&& id)) $ P.toListM @@ -315,7 +325,7 @@ processBindings :: Options -> Map Text Host -> IO () processBindings opts hosts = do - fsets <- readFilesets + fsets <- readFilesets opts thisHost <- T.init <$> shelly (silently $ cmd "hostname") let dflt = defaultHost (pack (fromName opts)) here = case dflt of @@ -413,9 +423,9 @@ 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 - -- execute (env bnd) "test" ["-d", toTextIgnore path] - -- (== 0) <$> lastExitCode +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 @@ -576,7 +586,8 @@ ] else do let rfs = (srcRsync^.rsyncFilters) <> (destRsync^.rsyncFilters) - go xs = doRsync (fs^.fsName) xs (toTextIgnore src) dest + nol = (srcRsync^.rsyncNoLinks) || (destRsync^.rsyncNoLinks) + go xs = doRsync (fs^.fsName) xs (toTextIgnore src) dest nol case rfs of [] -> go [] @@ -622,8 +633,8 @@ . T.replace "?" "." . T.replace "." "\\." -doRsync :: Text -> [Text] -> Text -> Text -> App () -doRsync label options src dest = do +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 @@ -657,6 +668,7 @@ 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) @@ -713,21 +725,21 @@ Normal -> (cmdName, args) Sudo -> ("sudo", toTextIgnore cmdName:args) SudoAsRoot -> sudoAsRoot cmdName args - (modifier, name'', args'')= case exeRemote of + + (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') - <> ["\""], []) + 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 @@ -738,9 +750,13 @@ if dryRun opts || noSync opts then return "" else do - n <- findCmd name'' + let (sshCmd:sshArgs) = words (encodeString name'') + n <- findCmd (decodeString sshCmd) liftIO $ debug' $ format "{} {}" - [ toTextIgnore n, T.intercalate " " (map tshow args'') ] + [ toTextIgnore n + , T.intercalate " " + (map tshow (map T.pack sshArgs ++ args'')) + ] runner' n args'' where findCmd n @@ -770,8 +786,9 @@ execute_ :: ExeEnv -> FilePath -> [Text] -> App () execute_ env' fp args = void $ execute env' { exeDiscard = True } fp args -getHomePath :: FilePath -> IO FilePath -getHomePath p = ( p) <$> getHomeDirectory +expandPath :: FilePath -> IO FilePath +expandPath (encodeString -> '~':'/':p) = ( decodeString p) <$> getHomeDirectory +expandPath p = return p asDirectory :: FilePath -> FilePath asDirectory (toTextIgnore -> fp) = diff --git a/Pushme/Options.hs b/Pushme/Options.hs new file mode 100644 --- /dev/null +++ b/Pushme/Options.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Pushme.Options where + +import Data.Data (Data) +import Data.Monoid +import Data.Typeable (Typeable) +import Options.Applicative hiding (Success, (&)) + +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 + , configDir :: 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 + ( 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)") + <*> 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")) + +optionsDefinition = info + (helper <*> pushmeOpts) + (fullDesc <> progDesc "" <> header pushmeSummary) + +getOptions = execParser optionsDefinition diff --git a/pushme.cabal b/pushme.cabal --- a/pushme.cabal +++ b/pushme.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.21.2. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: 4dd172a5ea6fa754c4e33bf4e491f4cb405e6b9770e2bc094176b875b320957d +-- hash: abf40cc11ead58c2c28cd6cc91c5b6a82de8e5bdc28651c2f416b9da9fb8b397 name: pushme -version: 2.1.1 +version: 2.1.3 synopsis: Tool to synchronize directories with rsync, zfs or git-annex description: Script I use for synchronizing data among machines. category: System @@ -17,7 +17,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: README.md @@ -28,7 +27,7 @@ executable pushme main-is: Main.hs other-modules: - Paths_pushme + Pushme.Options ghc-options: -threaded build-depends: aeson @@ -49,10 +48,10 @@ , pipes-text , regex-posix >=0.95 && <1.0 , safe >=0.3 && <0.4 - , shelly >=1.6 && <1.8 + , shelly >=1.6 && <2.0 , system-fileio >=0.3 && <0.4 , system-filepath >=0.4 && <0.5 - , temporary >=1.2 && <1.3 + , temporary >=1.2 && <2.0 , text >=1.2 && <1.3 , text-format >=0.3 && <0.4 , time >=1.4 && <2.0