diff options
116 files changed, 1607 insertions, 1135 deletions
diff --git a/Build/mdwn2man b/Build/mdwn2man index 87094069f..171218db0 100755 --- a/Build/mdwn2man +++ b/Build/mdwn2man @@ -45,7 +45,7 @@ while (<>) { if ($inNAME) { # make lexgrog happy - s/^git-annex /git-annex-/; + s/^git-annex (\w)/git-annex-$1/; } if ($_ eq ".SH NAME\n") { $inNAME=1; diff --git a/CmdLine.hs b/CmdLine.hs index cd7a1a986..492a3b75f 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -1,6 +1,6 @@ {- git-annex command line parsing and dispatch - - - Copyright 2010-2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2015 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,10 +13,11 @@ module CmdLine ( shutdown ) where +import qualified Options.Applicative as O +import qualified Options.Applicative.Help as H import qualified Control.Exception as E import qualified Data.Map as M import Control.Exception (throw) -import System.Console.GetOpt #ifndef mingw32_HOST_OS import System.Posix.Signals #endif @@ -32,48 +33,81 @@ import Command import Types.Messages {- Runs the passed command line. -} -dispatch :: Bool -> CmdParams -> [Command] -> [Option] -> [(String, String)] -> String -> IO Git.Repo -> IO () -dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do +dispatch :: Bool -> CmdParams -> [Command] -> [GlobalOption] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () +dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progdesc = do setupConsole - case getOptCmd args cmd commonoptions of - Right (flags, params) -> go flags params - =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) - Left parseerr -> error parseerr + go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) where - go flags params (Right g) = do + go (Right g) = do state <- Annex.new g Annex.eval state $ do checkEnvironment - when fuzzy $ - inRepo $ autocorrect . Just forM_ fields $ uncurry Annex.setField + (cmd, seek, globalconfig) <- parsewith cmdparser + (\a -> inRepo $ a . Just) when (cmdnomessages cmd) $ Annex.setOutput QuietOutput - sequence_ flags + getParsed globalconfig whenM (annexDebug <$> Annex.getGitConfig) $ liftIO enableDebugOutput startup - performCommandAction cmd params $ + performCommandAction cmd seek $ shutdown $ cmdnocommit cmd - go _flags params (Left e) = do - when fuzzy $ - autocorrect =<< Git.Config.global - maybe (throw e) (\a -> a params) (cmdnorepo cmd) - err msg = msg ++ "\n\n" ++ usage header allcmds - cmd = Prelude.head cmds - (fuzzy, cmds, name, args) = findCmd fuzzyok allargs allcmds err - autocorrect = Git.AutoCorrect.prepare name cmdname cmds + go (Left norepo) = do + (_, a, _globalconfig) <- parsewith + (fromMaybe (throw norepo) . cmdnorepo) + (\a -> a =<< Git.Config.global) + a + + parsewith getparser ingitrepo = + case parseCmd progname progdesc globaloptions allargs allcmds getparser of + O.Failure _ -> do + -- parse failed, so fall back to + -- fuzzy matching, or to showing usage + when fuzzy $ + ingitrepo autocorrect + liftIO (O.handleParseResult (parseCmd progname progdesc globaloptions correctedargs allcmds getparser)) + res -> liftIO (O.handleParseResult res) + where + autocorrect = Git.AutoCorrect.prepare (fromJust inputcmdname) cmdname cmds + (fuzzy, cmds, inputcmdname, args) = findCmd fuzzyok allargs allcmds + name + | fuzzy = case cmds of + (c:_) -> Just (cmdname c) + _ -> inputcmdname + | otherwise = inputcmdname + correctedargs = case name of + Nothing -> allargs + Just n -> n:args + +{- Parses command line, selecting one of the commands from the list. -} +parseCmd :: String -> String -> [GlobalOption] -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v, GlobalSetter) +parseCmd progname progdesc globaloptions allargs allcmds getparser = + O.execParserPure (O.prefs O.idm) pinfo allargs + where + pinfo = O.info (O.helper <*> subcmds) (O.progDescDoc (Just intro)) + subcmds = O.hsubparser $ mconcat $ map mkcommand allcmds + mkcommand c = O.command (cmdname c) $ O.info (mkparser c) $ O.fullDesc + <> O.header (synopsis (progname ++ " " ++ cmdname c) (cmddesc c)) + <> O.footer ("For details, run: " ++ progname ++ " help " ++ cmdname c) + mkparser c = (,,) + <$> pure c + <*> getparser c + <*> combineGlobalOptions globaloptions + synopsis n d = n ++ " - " ++ d + intro = mconcat $ concatMap (\l -> [H.text l, H.line]) + (synopsis progname progdesc : commandList allcmds) {- Parses command line params far enough to find the Command to run, and - returns the remaining params. - Does fuzzy matching if necessary, which may result in multiple Commands. -} -findCmd :: Bool -> CmdParams -> [Command] -> (String -> String) -> (Bool, [Command], String, CmdParams) -findCmd fuzzyok argv cmds err - | isNothing name = error $ err "missing command" - | not (null exactcmds) = (False, exactcmds, fromJust name, args) - | fuzzyok && not (null inexactcmds) = (True, inexactcmds, fromJust name, args) - | otherwise = error $ err $ "unknown command " ++ fromJust name +findCmd :: Bool -> CmdParams -> [Command] -> (Bool, [Command], Maybe String, CmdParams) +findCmd fuzzyok argv cmds + | not (null exactcmds) = ret (False, exactcmds) + | fuzzyok && not (null inexactcmds) = ret (True, inexactcmds) + | otherwise = ret (False, []) where + ret (fuzzy, matches) = (fuzzy, matches, name, args) (name, args) = findname argv [] findname [] c = (Nothing, reverse c) findname (a:as) c @@ -84,18 +118,6 @@ findCmd fuzzyok argv cmds err Nothing -> [] Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds -{- Parses command line options, and returns actions to run to configure flags - - and the remaining parameters for the command. -} -getOptCmd :: CmdParams -> Command -> [Option] -> Either String ([Annex ()], CmdParams) -getOptCmd argv cmd commonoptions = check $ - getOpt Permute (commonoptions ++ cmdoptions cmd) argv - where - check (flags, rest, []) = Right (flags, rest) - check (_, _, errs) = Left $ unlines - [ concat errs - , commandUsage cmd - ] - {- Actions to perform each time ran. -} startup :: Annex () startup = diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index 2838e4ff8..15064fe42 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -22,11 +22,11 @@ import Data.Either {- Runs a command, starting with the check stage, and then - the seek stage. Finishes by running the continutation, and - then showing a count of any failures. -} -performCommandAction :: Command -> CmdParams -> Annex () -> Annex () -performCommandAction Command { cmdseek = seek, cmdcheck = c, cmdname = name } params cont = do +performCommandAction :: Command -> CommandSeek -> Annex () -> Annex () +performCommandAction Command { cmdcheck = c, cmdname = name } seek cont = do mapM_ runCheck c Annex.changeState $ \s -> s { Annex.errcounter = 0 } - seek params + seek finishCommandActions cont showerrcount =<< Annex.getState Annex.errcounter diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs index 836472eb0..24f942978 100644 --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -20,7 +20,7 @@ type Batchable t = BatchMode -> t -> CommandStart -- In batch mode, one line at a time is read, parsed, and a reply output to -- stdout. In non batch mode, the command's parameters are parsed and -- a reply output for each. -batchable :: ((t -> CommandStart) -> CommandSeek) -> Batchable t -> CommandSeek +batchable :: ((t -> CommandStart) -> CmdParams -> CommandSeek) -> Batchable t -> CmdParams -> CommandSeek batchable seeker starter params = ifM (getOptionFlag batchOption) ( batchloop , seeker (starter NoBatch) params diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 354f451e7..68a9e27ca 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -15,15 +15,17 @@ import Command import Utility.Env import Annex.Ssh +import qualified Command.Help import qualified Command.Add import qualified Command.Unannex import qualified Command.Drop import qualified Command.Move import qualified Command.Copy import qualified Command.Get -import qualified Command.LookupKey -import qualified Command.ContentLocation -import qualified Command.ExamineKey +import qualified Command.Fsck +--import qualified Command.LookupKey +--import qualified Command.ContentLocation +--import qualified Command.ExamineKey import qualified Command.FromKey import qualified Command.RegisterUrl import qualified Command.SetKey @@ -34,7 +36,7 @@ import qualified Command.SetPresentKey import qualified Command.ReadPresentKey import qualified Command.CheckPresentKey import qualified Command.ReKey -import qualified Command.MetaData +--import qualified Command.MetaData import qualified Command.View import qualified Command.VAdd import qualified Command.VFilter @@ -46,7 +48,6 @@ import qualified Command.Init import qualified Command.Describe import qualified Command.InitRemote import qualified Command.EnableRemote -import qualified Command.Fsck import qualified Command.Expire import qualified Command.Repair import qualified Command.Unused @@ -56,14 +57,14 @@ import qualified Command.Unlock import qualified Command.Lock import qualified Command.PreCommit import qualified Command.Find -import qualified Command.FindRef +--import qualified Command.FindRef import qualified Command.Whereis -import qualified Command.List -import qualified Command.Log +--import qualified Command.List +--import qualified Command.Log import qualified Command.Merge import qualified Command.ResolveMerge -import qualified Command.Info -import qualified Command.Status +--import qualified Command.Info +--import qualified Command.Status import qualified Command.Migrate import qualified Command.Uninit import qualified Command.Reinit @@ -71,37 +72,36 @@ import qualified Command.NumCopies import qualified Command.Trust import qualified Command.Untrust import qualified Command.Semitrust -import qualified Command.Dead +--import qualified Command.Dead import qualified Command.Group import qualified Command.Wanted import qualified Command.GroupWanted import qualified Command.Required import qualified Command.Schedule import qualified Command.Ungroup -import qualified Command.Vicfg +--import qualified Command.Vicfg import qualified Command.Sync -import qualified Command.Mirror -import qualified Command.AddUrl +--import qualified Command.Mirror +--import qualified Command.AddUrl #ifdef WITH_FEED -import qualified Command.ImportFeed +--import qualified Command.ImportFeed #endif import qualified Command.RmUrl -import qualified Command.Import +--import qualified Command.Import import qualified Command.Map import qualified Command.Direct import qualified Command.Indirect import qualified Command.Upgrade -import qualified Command.Forget +--import qualified Command.Forget import qualified Command.Proxy import qualified Command.DiffDriver -import qualified Command.Undo +--import qualified Command.Undo import qualified Command.Version -import qualified Command.Help #ifdef WITH_ASSISTANT -import qualified Command.Watch -import qualified Command.Assistant +--import qualified Command.Watch +--import qualified Command.Assistant #ifdef WITH_WEBAPP -import qualified Command.WebApp +--import qualified Command.WebApp #endif #ifdef WITH_XMPP import qualified Command.XMPPGit @@ -111,29 +111,32 @@ import qualified Command.RemoteDaemon import qualified Command.Test #ifdef WITH_TESTSUITE import qualified Command.FuzzTest -import qualified Command.TestRemote +--import qualified Command.TestRemote #endif #ifdef WITH_EKG import System.Remote.Monitoring #endif cmds :: [Command] -cmds = concat - [ Command.Add.cmd +cmds = + [ Command.Help.cmd + , Command.Add.cmd , Command.Get.cmd , Command.Drop.cmd , Command.Move.cmd , Command.Copy.cmd + , Command.Fsck.cmd , Command.Unlock.cmd + , Command.Unlock.editcmd , Command.Lock.cmd , Command.Sync.cmd - , Command.Mirror.cmd - , Command.AddUrl.cmd +-- , Command.Mirror.cmd +-- , Command.AddUrl.cmd #ifdef WITH_FEED - , Command.ImportFeed.cmd +-- , Command.ImportFeed.cmd #endif , Command.RmUrl.cmd - , Command.Import.cmd +-- , Command.Import.cmd , Command.Init.cmd , Command.Describe.cmd , Command.InitRemote.cmd @@ -147,17 +150,17 @@ cmds = concat , Command.Trust.cmd , Command.Untrust.cmd , Command.Semitrust.cmd - , Command.Dead.cmd +-- , Command.Dead.cmd , Command.Group.cmd , Command.Wanted.cmd , Command.GroupWanted.cmd , Command.Required.cmd , Command.Schedule.cmd , Command.Ungroup.cmd - , Command.Vicfg.cmd - , Command.LookupKey.cmd - , Command.ContentLocation.cmd - , Command.ExamineKey.cmd +-- , Command.Vicfg.cmd +-- , Command.LookupKey.cmd +-- , Command.ContentLocation.cmd +-- , Command.ExamineKey.cmd , Command.FromKey.cmd , Command.RegisterUrl.cmd , Command.SetKey.cmd @@ -168,44 +171,42 @@ cmds = concat , Command.ReadPresentKey.cmd , Command.CheckPresentKey.cmd , Command.ReKey.cmd - , Command.MetaData.cmd +-- , Command.MetaData.cmd , Command.View.cmd , Command.VAdd.cmd , Command.VFilter.cmd , Command.VPop.cmd , Command.VCycle.cmd , Command.Fix.cmd - , Command.Fsck.cmd , Command.Expire.cmd , Command.Repair.cmd , Command.Unused.cmd , Command.DropUnused.cmd , Command.AddUnused.cmd , Command.Find.cmd - , Command.FindRef.cmd +-- , Command.FindRef.cmd , Command.Whereis.cmd - , Command.List.cmd - , Command.Log.cmd +-- , Command.List.cmd +-- , Command.Log.cmd , Command.Merge.cmd , Command.ResolveMerge.cmd - , Command.Info.cmd - , Command.Status.cmd +-- , Command.Info.cmd +-- , Command.Status.cmd , Command.Migrate.cmd , Command.Map.cmd , Command.Direct.cmd , Command.Indirect.cmd , Command.Upgrade.cmd - , Command.Forget.cmd +-- , Command.Forget.cmd , Command.Proxy.cmd , Command.DiffDriver.cmd - , Command.Undo.cmd +-- , Command.Undo.cmd , Command.Version.cmd - , Command.Help.cmd #ifdef WITH_ASSISTANT - , Command.Watch.cmd - , Command.Assistant.cmd +-- , Command.Watch.cmd +-- , Command.Assistant.cmd #ifdef WITH_WEBAPP - , Command.WebApp.cmd +-- , Command.WebApp.cmd #endif #ifdef WITH_XMPP , Command.XMPPGit.cmd @@ -215,13 +216,10 @@ cmds = concat , Command.Test.cmd #ifdef WITH_TESTSUITE , Command.FuzzTest.cmd - , Command.TestRemote.cmd +-- , Command.TestRemote.cmd #endif ] -header :: String -header = "git-annex command [option ...]" - run :: [String] -> IO () run args = do #ifdef WITH_EKG @@ -229,7 +227,9 @@ run args = do #endif go envmodes where - go [] = dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get + go [] = dispatch True args cmds gitAnnexGlobalOptions [] Git.CurrentRepo.get + "git-annex" + "manage files with git, without checking their contents in" go ((v, a):rest) = maybe (go rest) a =<< getEnv v envmodes = [ (sshOptionsEnv, runSshOptions args) diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 320268f6a..f95a4d03e 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -1,4 +1,4 @@ -{- git-annex options +{- git-annex command-line option parsing - - Copyright 2010-2015 Joey Hess <id@joeyh.name> - @@ -7,7 +7,7 @@ module CmdLine.GitAnnex.Options where -import System.Console.GetOpt +import Options.Applicative import Common.Annex import qualified Git.Config @@ -15,63 +15,155 @@ import Git.Types import Types.TrustLevel import Types.NumCopies import Types.Messages +import Types.Key +import Types.Command +import Types.DeferredParse +import Types.DesktopNotify import qualified Annex import qualified Remote import qualified Limit import qualified Limit.Wanted import CmdLine.Option import CmdLine.Usage +import CmdLine.GlobalSetter --- Options that are accepted by all git-annex sub-commands, +-- Global options that are accepted by all git-annex sub-commands, -- although not always used. -gitAnnexOptions :: [Option] -gitAnnexOptions = commonOptions ++ - [ Option ['N'] ["numcopies"] (ReqArg setnumcopies paramNumber) - "override default number of copies" - , Option [] ["trust"] (trustArg Trusted) - "override trust setting" - , Option [] ["semitrust"] (trustArg SemiTrusted) - "override trust setting back to default" - , Option [] ["untrust"] (trustArg UnTrusted) - "override trust setting to untrusted" - , Option ['c'] ["config"] (ReqArg setgitconfig "NAME=VALUE") - "override git configuration setting" - , Option [] ["user-agent"] (ReqArg setuseragent paramName) - "override default User-Agent" - , Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier")) - "Trust Amazon Glacier inventory" +gitAnnexGlobalOptions :: [GlobalOption] +gitAnnexGlobalOptions = commonGlobalOptions ++ + [ globalSetter setnumcopies $ option auto + ( long "numcopies" <> short 'N' <> metavar paramNumber + <> help "override default number of copies" + <> hidden + ) + , globalSetter (Remote.forceTrust Trusted) $ strOption + ( long "trust" <> metavar paramRemote + <> help "override trust setting" + <> hidden + ) + , globalSetter (Remote.forceTrust SemiTrusted) $ strOption + ( long "semitrust" <> metavar paramRemote + <> help "override trust setting back to default" + <> hidden + ) + , globalSetter (Remote.forceTrust UnTrusted) $ strOption + ( long "untrust" <> metavar paramRemote + <> help "override trust setting to untrusted" + <> hidden + ) + , globalSetter setgitconfig $ strOption + ( long "config" <> short 'c' <> metavar "NAME=VALUE" + <> help "override git configuration setting" + <> hidden + ) + , globalSetter setuseragent $ strOption + ( long "user-agent" <> metavar paramName + <> help "override default User-Agent" + <> hidden + ) + , globalFlag (Annex.setFlag "trustglacier") + ( long "trust-glacier" + <> help "Trust Amazon Glacier inventory" + <> hidden + ) + , globalFlag (setdesktopnotify mkNotifyFinish) + ( long "notify-finish" + <> help "show desktop notification after transfer finishes" + <> hidden + ) + , globalFlag (setdesktopnotify mkNotifyStart) + ( long "notify-start" + <> help "show desktop notification after transfer completes" + <> hidden + ) ] where - trustArg t = ReqArg (Remote.forceTrust t) paramRemote - setnumcopies v = maybe noop - (\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n }) - (readish v) + setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n } setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } setgitconfig v = inRepo (Git.Config.store v) >>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }) >>= Annex.changeGitRepo + setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } --- Options for matching on annexed keys, rather than work tree files. -keyOptions :: [Option] -keyOptions = [ allOption, unusedOption, keyOption] +{- Parser that accepts all non-option params. -} +cmdParams :: CmdParamsDesc -> Parser CmdParams +cmdParams paramdesc = many $ argument str + ( metavar paramdesc + -- Let bash completion complete files + <> action "file" + ) -allOption :: Option -allOption = Option ['A'] ["all"] (NoArg (Annex.setFlag "all")) - "operate on all versions of all files" +parseAutoOption :: Parser Bool +parseAutoOption = switch + ( long "auto" <> short 'a' + <> help "automatic mode" + ) -unusedOption :: Option -unusedOption = Option ['U'] ["unused"] (NoArg (Annex.setFlag "unused")) - "operate on files found by last run of git-annex unused" +parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote) +parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p -keyOption :: Option -keyOption = Option [] ["key"] (ReqArg (Annex.setField "key") paramKey) - "operate on specified key" +data FromToOptions + = FromRemote (DeferredParse Remote) + | ToRemote (DeferredParse Remote) -incompleteOption :: Option -incompleteOption = flagOption [] "incomplete" "resume previous downloads" +instance DeferredParseClass FromToOptions where + finishParse (FromRemote v) = FromRemote <$> finishParse v + finishParse (ToRemote v) = ToRemote <$> finishParse v + +parseFromToOptions :: Parser FromToOptions +parseFromToOptions = + (FromRemote <$> parseFromOption) + <|> (ToRemote <$> parseToOption) + +parseFromOption :: Parser (DeferredParse Remote) +parseFromOption = parseRemoteOption $ strOption + ( long "from" <> short 'f' <> metavar paramRemote + <> help "source remote" + ) + +parseToOption :: Parser (DeferredParse Remote) +parseToOption = parseRemoteOption $ strOption + ( long "to" <> short 't' <> metavar paramRemote + <> help "destination remote" + ) + +-- Options for acting on keys, rather than work tree files. +data KeyOptions + = WantAllKeys + | WantUnusedKeys + | WantSpecificKey Key + | WantIncompleteKeys + +parseKeyOptions :: Bool -> Parser KeyOptions +parseKeyOptions allowincomplete = if allowincomplete + then base + <|> flag' WantIncompleteKeys + ( long "incomplete" + <> help "resume previous downloads" + ) + else base + where + base = parseAllOption + <|> flag' WantUnusedKeys + ( long "unused" <> short 'U' + <> help "operate on files found by last run of git-annex unused" + ) + <|> (WantSpecificKey <$> option (str >>= parseKey) + ( long "key" <> metavar paramKey + <> help "operate on specified key" + )) + +parseAllOption :: Parser KeyOptions +parseAllOption = flag' WantAllKeys + ( long "all" <> short 'A' + <> help "operate on all versions of all files" + ) + +parseKey :: Monad m => String -> m Key +parseKey = maybe (fail "invalid key") return . file2key -- Options to match properties of annexed files. -annexedMatchingOptions :: [Option] +annexedMatchingOptions :: [GlobalOption] annexedMatchingOptions = concat [ nonWorkTreeMatchingOptions' , fileMatchingOptions' @@ -80,84 +172,116 @@ annexedMatchingOptions = concat ] -- Matching options that don't need to examine work tree files. -nonWorkTreeMatchingOptions :: [Option] +nonWorkTreeMatchingOptions :: [GlobalOption] nonWorkTreeMatchingOptions = nonWorkTreeMatchingOptions' ++ combiningOptions -nonWorkTreeMatchingOptions' :: [Option] +nonWorkTreeMatchingOptions' :: [GlobalOption] nonWorkTreeMatchingOptions' = - [ Option ['i'] ["in"] (ReqArg Limit.addIn paramRemote) - "match files present in a remote" - , Option ['C'] ["copies"] (ReqArg Limit.addCopies paramNumber) - "skip files with fewer copies" - , Option [] ["lackingcopies"] (ReqArg (Limit.addLackingCopies False) paramNumber) - "match files that need more copies" - , Option [] ["approxlackingcopies"] (ReqArg (Limit.addLackingCopies True) paramNumber) - "match files that need more copies (faster)" - , Option ['B'] ["inbackend"] (ReqArg Limit.addInBackend paramName) - "match files using a key-value backend" - , Option [] ["inallgroup"] (ReqArg Limit.addInAllGroup paramGroup) - "match files present in all remotes in a group" - , Option [] ["metadata"] (ReqArg Limit.addMetaData "FIELD=VALUE") - "match files with attached metadata" - , Option [] ["want-get"] (NoArg Limit.Wanted.addWantGet) - "match files the repository wants to get" - , Option [] ["want-drop"] (NoArg Limit.Wanted.addWantDrop) - "match files the repository wants to drop" + [ globalSetter Limit.addIn $ strOption + ( long "in" <> short 'i' <> metavar paramRemote + <> help "match files present in a remote" + <> hidden + ) + , globalSetter Limit.addCopies $ strOption + ( long "copies" <> short 'C' <> metavar paramRemote + <> help "skip files with fewer copies" + <> hidden + ) + , globalSetter (Limit.addLackingCopies False) $ strOption + ( long "lackingcopies" <> metavar paramNumber + <> help "match files that need more copies" + <> hidden + ) + , globalSetter (Limit.addLackingCopies True) $ strOption + ( long "approxlackingcopies" <> metavar paramNumber + <> help "match files that need more copies (faster)" + <> hidden + ) + , globalSetter Limit.addInBackend $ strOption + ( long "inbackend" <> short 'B' <> metavar paramName + <> help "match files using a key-value backend" + <> hidden + ) + , globalSetter Limit.addInAllGroup $ strOption + ( long "inallgroup" <> metavar paramGroup + <> help "match files present in all remotes in a group" + <> hidden + ) + , globalSetter Limit.addMetaData $ strOption + ( long "metadata" <> metavar "FIELD=VALUE" + <> help "match files with attached metadata" + <> hidden + ) + , globalFlag Limit.Wanted.addWantGet + ( long "want-get" + <> help "match files the repository wants to get" + <> hidden + ) + , globalFlag Limit.Wanted.addWantDrop + ( long "want-drop" + <> help "match files the repository wants to drop" + <> hidden + ) ] -- Options to match files which may not yet be annexed. -fileMatchingOptions :: [Option] +fileMatchingOptions :: [GlobalOption] fileMatchingOptions = fileMatchingOptions' ++ combiningOptions -fileMatchingOptions' :: [Option] +fileMatchingOptions' :: [GlobalOption] fileMatchingOptions' = - [ Option ['x'] ["exclude"] (ReqArg Limit.addExclude paramGlob) - "skip files matching the glob pattern" - , Option ['I'] ["include"] (ReqArg Limit.addInclude paramGlob) - "limit to files matching the glob pattern" - , Option [] ["largerthan"] (ReqArg Limit.addLargerThan paramSize) - "match files larger than a size" - , Option [] ["smallerthan"] (ReqArg Limit.addSmallerThan paramSize) - "match files smaller than a size" + [ globalSetter Limit.addExclude $ strOption + ( long "exclude" <> short 'x' <> metavar paramGlob + <> help "skip files matching the glob pattern" + <> hidden + ) + , globalSetter Limit.addInclude $ strOption + ( long "include" <> short 'I' <> metavar paramGlob + <> help "limit to files matching the glob pattern" + <> hidden + ) + , globalSetter Limit.addLargerThan $ strOption + ( long "largerthan" <> metavar paramSize + <> help "match files larger than a size" + <> hidden + ) + , globalSetter Limit.addSmallerThan $ strOption + ( long "smallerthan" <> metavar paramSize + <> help "match files smaller than a size" + <> hidden + ) ] -combiningOptions :: [Option] -combiningOptions = +combiningOptions :: [GlobalOption] +combiningOptions = [ longopt "not" "negate next option" , longopt "and" "both previous and next option must match" , longopt "or" "either previous or next option must match" - , shortopt "(" "open group of options" - , shortopt ")" "close group of options" + , shortopt '(' "open group of options" + , shortopt ')' "close group of options" ] where - longopt o = Option [] [o] $ NoArg $ Limit.addToken o - shortopt o = Option o [] $ NoArg $ Limit.addToken o - -fromOption :: Option -fromOption = fieldOption ['f'] "from" paramRemote "source remote" - -toOption :: Option -toOption = fieldOption ['t'] "to" paramRemote "destination remote" + longopt o h = globalFlag (Limit.addToken o) ( long o <> help h <> hidden ) + shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h <> hidden ) -fromToOptions :: [Option] -fromToOptions = [fromOption, toOption] - -jsonOption :: Option -jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput)) - "enable JSON output" - -jobsOption :: Option -jobsOption = Option ['J'] ["jobs"] (ReqArg set paramNumber) - "enable concurrent jobs" - where - set s = case readish s of - Nothing -> error "Bad --jobs number" - Just n -> Annex.setOutput (ParallelOutput n) +jsonOption :: GlobalOption +jsonOption = globalFlag (Annex.setOutput JSONOutput) + ( long "json" <> short 'j' + <> help "enable JSON output" + <> hidden + ) -timeLimitOption :: Option -timeLimitOption = Option ['T'] ["time-limit"] - (ReqArg Limit.addTimeLimit paramTime) - "stop after the specified amount of time" +jobsOption :: GlobalOption +jobsOption = globalSetter (Annex.setOutput . ParallelOutput) $ + option auto + ( long "jobs" <> short 'J' <> metavar paramNumber + <> help "enable concurrent jobs" + <> hidden + ) -autoOption :: Option -autoOption = flagOption ['a'] "auto" "automatic mode" +timeLimitOption :: GlobalOption +timeLimitOption = globalSetter Limit.addTimeLimit $ strOption + ( long "time-limit" <> short 'T' <> metavar paramTime + <> help "stop after the specified amount of time" + <> hidden + ) diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index adf6da04e..074257ac5 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -8,15 +8,14 @@ module CmdLine.GitAnnexShell where import System.Environment -import System.Console.GetOpt import Common.Annex import qualified Git.Construct import qualified Git.Config import CmdLine +import CmdLine.GlobalSetter import Command import Annex.UUID -import Annex (setField) import CmdLine.GitAnnexShell.Fields import Utility.UserInfo import Remote.GCrypt (getGCryptUUID) @@ -34,7 +33,7 @@ import qualified Command.NotifyChanges import qualified Command.GCryptSetup cmds_readonly :: [Command] -cmds_readonly = concat +cmds_readonly = [ gitAnnexShellCheck Command.ConfigList.cmd , gitAnnexShellCheck Command.InAnnex.cmd , gitAnnexShellCheck Command.SendKey.cmd @@ -43,7 +42,7 @@ cmds_readonly = concat ] cmds_notreadonly :: [Command] -cmds_notreadonly = concat +cmds_notreadonly = [ gitAnnexShellCheck Command.RecvKey.cmd , gitAnnexShellCheck Command.DropKey.cmd , gitAnnexShellCheck Command.Commit.cmd @@ -55,10 +54,13 @@ cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly where adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c } -options :: [OptDescr (Annex ())] -options = commonOptions ++ - [ Option [] ["uuid"] (ReqArg checkUUID paramUUID) "local repository uuid" - ] +globalOptions :: [GlobalOption] +globalOptions = + globalSetter checkUUID (strOption + ( long "uuid" <> metavar paramUUID + <> help "local repository uuid" + )) + : commonGlobalOptions where checkUUID expected = getUUID >>= check where @@ -74,9 +76,6 @@ options = commonOptions ++ unexpected expected s = error $ "expected repository UUID " ++ expected ++ " but found " ++ s -header :: String -header = "git-annex-shell [-c] command [parameters ...] [option ...]" - run :: [String] -> IO () run [] = failure -- skip leading -c options, passed by eg, ssh @@ -100,12 +99,12 @@ builtin cmd dir params = do checkNotReadOnly cmd checkDirectory $ Just dir let (params', fieldparams, opts) = partitionParams params - fields = filter checkField $ parseFields fieldparams - cmds' = map (newcmd $ unwords opts) cmds - dispatch False (cmd : params') cmds' options fields header mkrepo + rsyncopts = ("RsyncOptions", unwords opts) + fields = rsyncopts : filter checkField (parseFields fieldparams) + dispatch False (cmd : params') cmds globalOptions fields mkrepo + "git-annex-shell" + "Restricted login shell for git-annex only SSH access" where - addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k - newcmd opts c = c { cmdseek = addrsyncopts opts (cmdseek c) } mkrepo = do r <- Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath Git.Config.read r @@ -143,14 +142,16 @@ parseFields = map (separate (== '=')) {- Only allow known fields to be set, ignore others. - Make sure that field values make sense. -} checkField :: (String, String) -> Bool -checkField (field, value) - | field == fieldName remoteUUID = fieldCheck remoteUUID value - | field == fieldName associatedFile = fieldCheck associatedFile value - | field == fieldName direct = fieldCheck direct value +checkField (field, val) + | field == fieldName remoteUUID = fieldCheck remoteUUID val + | field == fieldName associatedFile = fieldCheck associatedFile val + | field == fieldName direct = fieldCheck direct val | otherwise = False failure :: IO () -failure = error $ "bad parameters\n\n" ++ usage header cmds +failure = error $ "bad parameters\n\n" ++ usage h cmds + where + h = "git-annex-shell [-c] command [parameters ...] [option ...]" checkNotLimited :: IO () checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED" @@ -200,8 +201,8 @@ checkEnv var = do {- Modifies a Command to check that it is run in either a git-annex - repository, or a repository with a gcrypt-id set. -} -gitAnnexShellCheck :: [Command] -> [Command] -gitAnnexShellCheck = map $ addCheck okforshell . dontCheck repoExists +gitAnnexShellCheck :: Command -> Command +gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists where okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $ error "Not a git-annex or gcrypt repository." diff --git a/CmdLine/GlobalSetter.hs b/CmdLine/GlobalSetter.hs new file mode 100644 index 000000000..831a8b440 --- /dev/null +++ b/CmdLine/GlobalSetter.hs @@ -0,0 +1,24 @@ +{- git-annex global options + - + - Copyright 2015 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module CmdLine.GlobalSetter where + +import Types.DeferredParse +import Common +import Annex + +import Options.Applicative + +globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> GlobalOption +globalFlag setter = flag' (DeferredParse setter) + +globalSetter :: (v -> Annex ()) -> Parser v -> GlobalOption +globalSetter setter parser = DeferredParse . setter <$> parser + +combineGlobalOptions :: [GlobalOption] -> Parser GlobalSetter +combineGlobalOptions l = DeferredParse . sequence_ . map getParsed + <$> many (foldl1 (<|>) l) diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs index 0cda34ba1..4e201cbd4 100644 --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -5,45 +5,55 @@ - Licensed under the GNU GPL version 3 or higher. -} -module CmdLine.Option ( - commonOptions, - flagOption, - fieldOption, - optionName, - optionParam, - ArgDescr(..), - OptDescr(..), -) where +module CmdLine.Option where -import System.Console.GetOpt +import Options.Applicative import Common.Annex +import CmdLine.Usage +import CmdLine.GlobalSetter import qualified Annex import Types.Messages -import Types.DesktopNotify -import CmdLine.Usage - --- Options accepted by both git-annex and git-annex-shell sub-commands. -commonOptions :: [Option] -commonOptions = - [ Option [] ["force"] (NoArg (setforce True)) - "allow actions that may lose annexed data" - , Option ['F'] ["fast"] (NoArg (setfast True)) - "avoid slow operations" - , Option ['q'] ["quiet"] (NoArg (Annex.setOutput QuietOutput)) - "avoid verbose output" - , Option ['v'] ["verbose"] (NoArg (Annex.setOutput NormalOutput)) - "allow verbose output (default)" - , Option ['d'] ["debug"] (NoArg setdebug) - "show debug messages" - , Option [] ["no-debug"] (NoArg unsetdebug) - "don't show debug messages" - , Option ['b'] ["backend"] (ReqArg setforcebackend paramName) - "specify key-value backend to use" - , Option [] ["notify-finish"] (NoArg (setdesktopnotify mkNotifyFinish)) - "show desktop notification after transfer finishes" - , Option [] ["notify-start"] (NoArg (setdesktopnotify mkNotifyStart)) - "show desktop notification after transfer completes" +import Types.DeferredParse + +-- Global options accepted by both git-annex and git-annex-shell sub-commands. +commonGlobalOptions :: [GlobalOption] +commonGlobalOptions = + [ globalFlag (setforce True) + ( long "force" + <> help "allow actions that may lose annexed data" + <> hidden + ) + , globalFlag (setfast True) + ( long "fast" <> short 'F' + <> help "avoid slow operations" + <> hidden + ) + , globalFlag (Annex.setOutput QuietOutput) + ( long "quiet" <> short 'q' + <> help "avoid verbose output" + <> hidden + ) + , globalFlag (Annex.setOutput NormalOutput) + ( long "verbose" <> short 'v' + <> help "allow verbose output (default)" + <> hidden + ) + , globalFlag setdebug + ( long "debug" <> short 'd' + <> help "show debug messages" + <> hidden + ) + , globalFlag unsetdebug + ( long "no-debug" + <> help "don't show debug messages" + <> hidden + ) + , globalSetter setforcebackend $ strOption + ( long "backend" <> short 'b' <> metavar paramName + <> help "specify key-value backend to use" + <> hidden + ) ] where setforce v = Annex.changeState $ \s -> s { Annex.force = v } @@ -51,21 +61,3 @@ commonOptions = setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True } unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False } - setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } - -{- An option that sets a flag. -} -flagOption :: String -> String -> String -> Option -flagOption short opt description = - Option short [opt] (NoArg (Annex.setFlag opt)) description - -{- An option that sets a field. -} -fieldOption :: String -> String -> String -> String -> Option -fieldOption short opt paramdesc description = - Option short [opt] (ReqArg (Annex.setField opt) paramdesc) description - -{- The flag or field name used for an option. -} -optionName :: Option -> String -optionName (Option _ o _ _) = Prelude.head o - -optionParam :: Option -> String -optionParam o = "--" ++ optionName o diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 47e2c79bc..e67c3b908 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -22,18 +22,18 @@ import qualified Git.LsFiles as LsFiles import qualified Git.LsTree as LsTree import Git.FilePath import qualified Limit -import CmdLine.Option +import CmdLine.GitAnnex.Options import CmdLine.Action import Logs.Location import Logs.Unused import Annex.CatFile import Annex.Content -withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek +withFilesInGit :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek withFilesInGit a params = seekActions $ prepFiltered a $ seekHelper LsFiles.inRepo params -withFilesInGitNonRecursive :: (FilePath -> CommandStart) -> CommandSeek +withFilesInGitNonRecursive :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek withFilesInGitNonRecursive a params = ifM (Annex.getState Annex.force) ( withFilesInGit a params , if null params @@ -54,7 +54,7 @@ withFilesInGitNonRecursive a params = ifM (Annex.getState Annex.force) _ -> needforce needforce = error "Not recursively setting metadata. Use --force to do that." -withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CommandSeek +withFilesNotInGit :: Bool -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek withFilesNotInGit skipdotfiles a params | skipdotfiles = do {- dotfiles are not acted on unless explicitly listed -} @@ -73,7 +73,7 @@ withFilesNotInGit skipdotfiles a params go l = seekActions $ prepFiltered a $ return $ concat $ segmentPaths params l -withFilesInRefs :: (FilePath -> Key -> CommandStart) -> CommandSeek +withFilesInRefs :: (FilePath -> Key -> CommandStart) -> CmdParams -> CommandSeek withFilesInRefs a = mapM_ go where go r = do @@ -87,7 +87,7 @@ withFilesInRefs a = mapM_ go Just k -> whenM (matcher $ MatchingKey k) $ commandAction $ a f k -withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek +withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CmdParams -> CommandSeek withPathContents a params = do matcher <- Limit.getMatcher seekActions $ map a <$> (filterM (checkmatch matcher) =<< ps) @@ -103,27 +103,27 @@ withPathContents a params = do , matchFile = relf } -withWords :: ([String] -> CommandStart) -> CommandSeek +withWords :: ([String] -> CommandStart) -> CmdParams -> CommandSeek withWords a params = seekActions $ return [a params] -withStrings :: (String -> CommandStart) -> CommandSeek +withStrings :: (String -> CommandStart) -> CmdParams -> CommandSeek withStrings a params = seekActions $ return $ map a params -withPairs :: ((String, String) -> CommandStart) -> CommandSeek +withPairs :: ((String, String) -> CommandStart) -> CmdParams -> CommandSeek withPairs a params = seekActions $ return $ map a $ pairs [] params where pairs c [] = reverse c pairs c (x:y:xs) = pairs ((x,y):c) xs pairs _ _ = error "expected pairs" -withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek +withFilesToBeCommitted :: (String -> CommandStart) -> CmdParams -> CommandSeek withFilesToBeCommitted a params = seekActions $ prepFiltered a $ seekHelper LsFiles.stagedNotDeleted params -withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek +withFilesUnlocked :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged -withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CommandSeek +withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged {- Unlocked files have changed type from a symlink to a regular file. @@ -131,7 +131,7 @@ withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged - Furthermore, unlocked files used to be a git-annex symlink, - not some other sort of symlink. -} -withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CommandSeek +withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (FilePath -> CommandStart) -> CmdParams -> CommandSeek withFilesUnlocked' typechanged a params = seekActions $ prepFiltered a unlockedfiles where @@ -142,25 +142,16 @@ isUnlocked f = liftIO (notSymlink f) <&&> (isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f) {- Finds files that may be modified. -} -withFilesMaybeModified :: (FilePath -> CommandStart) -> CommandSeek +withFilesMaybeModified :: (FilePath -> CommandStart) -> CmdParams -> CommandSeek withFilesMaybeModified a params = seekActions $ prepFiltered a $ seekHelper LsFiles.modified params -withKeys :: (Key -> CommandStart) -> CommandSeek +withKeys :: (Key -> CommandStart) -> CmdParams -> CommandSeek withKeys a params = seekActions $ return $ map (a . parse) params where parse p = fromMaybe (error "bad key") $ file2key p -{- Gets the value of a field options, which is fed into - - a conversion function. - -} -getOptionField :: Option -> (Maybe String -> Annex a) -> Annex a -getOptionField option converter = converter <=< Annex.getField $ optionName option - -getOptionFlag :: Option -> Annex Bool -getOptionFlag option = Annex.getFlag (optionName option) - -withNothing :: CommandStart -> CommandSeek +withNothing :: CommandStart -> CmdParams -> CommandSeek withNothing a [] = seekActions $ return [a] withNothing _ _ = error "This command takes no parameters." @@ -171,40 +162,34 @@ withNothing _ _ = error "This command takes no parameters." - - Otherwise falls back to a regular CommandSeek action on - whatever params were passed. -} -withKeyOptions :: Bool -> (Key -> CommandStart) -> CommandSeek -> CommandSeek -withKeyOptions auto keyop = withKeyOptions' auto $ \getkeys -> do +withKeyOptions :: Maybe KeyOptions -> Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek +withKeyOptions ko auto keyaction = withKeyOptions' ko auto $ \getkeys -> do matcher <- Limit.getMatcher seekActions $ map (process matcher) <$> getkeys where process matcher k = ifM (matcher $ MatchingKey k) - ( keyop k + ( keyaction k , return Nothing ) -withKeyOptions' :: Bool -> (Annex [Key] -> Annex ()) -> CommandSeek -> CommandSeek -withKeyOptions' auto keyop fallbackop params = do +withKeyOptions' :: Maybe KeyOptions -> Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek +withKeyOptions' ko auto keyaction fallbackaction params = do bare <- fromRepo Git.repoIsLocalBare - allkeys <- Annex.getFlag "all" - unused <- Annex.getFlag "unused" - incomplete <- Annex.getFlag "incomplete" - specifickey <- Annex.getField "key" when (auto && bare) $ error "Cannot use --auto in a bare repository" - case (allkeys, unused, incomplete, null params, specifickey) of - (False , False , False , True , Nothing) + case (null params, ko) of + (True, Nothing) | bare -> go auto loggedKeys - | otherwise -> fallbackop params - (False , False , False , _ , Nothing) -> fallbackop params - (True , False , False , True , Nothing) -> go auto loggedKeys - (False , True , False , True , Nothing) -> go auto unusedKeys' - (False , False , True , True , Nothing) -> go auto incompletekeys - (False , False , False , True , Just ks) -> case file2key ks of - Nothing -> error "Invalid key" - Just k -> go auto $ return [k] - _ -> error "Can only specify one of file names, --all, --unused, --key, or --incomplete" + | otherwise -> fallbackaction params + (False, Nothing) -> fallbackaction params + (True, Just WantAllKeys) -> go auto loggedKeys + (True, Just WantUnusedKeys) -> go auto unusedKeys' + (True, Just (WantSpecificKey k)) -> go auto $ return [k] + (True, Just WantIncompleteKeys) -> go auto incompletekeys + (False, Just _) -> error "Can only specify one of file names, --all, --unused, --key, or --incomplete" where go True _ = error "Cannot use --auto with --all or --unused or --key or --incomplete" - go False getkeys = keyop getkeys + go False getkeys = keyaction getkeys incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart] diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs index ad1d4e583..a6cc90a71 100644 --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -1,6 +1,6 @@ {- git-annex usage messages - - - Copyright 2010-2011 Joey Hess <id@joeyh.name> + - Copyright 2010-2015 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -8,17 +8,17 @@ module CmdLine.Usage where import Common.Annex - import Types.Command -import System.Console.GetOpt - usageMessage :: String -> String usageMessage s = "Usage: " ++ s -{- Usage message with lists of commands by section. -} usage :: String -> [Command] -> String -usage header cmds = unlines $ usageMessage header : concatMap go [minBound..] +usage header cmds = unlines $ usageMessage header : commandList cmds + +{- Commands listed by section, with breif usage and description. -} +commandList :: [Command] -> [String] +commandList cmds = concatMap go [minBound..] where go section | null cs = [] @@ -42,23 +42,10 @@ usage header cmds = unlines $ usageMessage header : concatMap go [minBound..] longest f = foldl max 0 $ map (length . f) cmds scmds = sort cmds -{- Usage message for a single command. -} -commandUsage :: Command -> String -commandUsage cmd = unlines - [ usageInfo header (cmdoptions cmd) - , "To see additional options common to all commands, run: git annex help options" - ] - where - header = usageMessage $ unwords - [ "git-annex" - , cmdname cmd - , cmdparamdesc cmd - , "[option ...]" - ] {- Descriptions of params used in usage messages. -} paramPaths :: String -paramPaths = paramOptional $ paramRepeating paramPath -- most often used +paramPaths = paramRepeating paramPath -- most often used paramPath :: String paramPath = "PATH" paramKey :: String @@ -114,6 +101,6 @@ paramNothing = "" paramRepeating :: String -> String paramRepeating s = s ++ " ..." paramOptional :: String -> String -paramOptional s = "[" ++ s ++ "]" +paramOptional s = s paramPair :: String -> String -> String paramPair a b = a ++ " " ++ b diff --git a/Command.hs b/Command.hs index 35034a494..bee63bb74 100644 --- a/Command.hs +++ b/Command.hs @@ -1,16 +1,18 @@ {- git-annex command infrastructure - - - Copyright 2010-2014 Joey Hess <id@joeyh.name> + - Copyright 2010-2015 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} module Command ( command, + withParams, + (<--<), noRepo, noCommit, noMessages, - withOptions, + withGlobalOptions, next, stop, stopUnless, @@ -25,16 +27,38 @@ import qualified Backend import qualified Git import Types.Command as ReExported import Types.Option as ReExported +import Types.DeferredParse as ReExported import CmdLine.Seek as ReExported import Checks as ReExported import CmdLine.Usage as ReExported import CmdLine.Action as ReExported import CmdLine.Option as ReExported +import CmdLine.GlobalSetter as ReExported import CmdLine.GitAnnex.Options as ReExported +import Options.Applicative as ReExported hiding (command) -{- Generates a normal command -} -command :: String -> String -> CommandSeek -> CommandSection -> String -> Command -command = Command [] Nothing commonChecks False False +import qualified Options.Applicative as O + +{- Generates a normal Command -} +command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command +command name section desc paramdesc mkparser = + Command commonChecks False False name paramdesc + section desc (mkparser paramdesc) Nothing + +{- Simple option parser that takes all non-option params as-is. -} +withParams :: (CmdParams -> v) -> CmdParamsDesc -> O.Parser v +withParams mkseek paramdesc = mkseek <$> cmdParams paramdesc + +{- Uses the supplied option parser, which yields a deferred parse, + - and calls finishParse on the result before passing it to the + - CommandSeek constructor. -} +(<--<) :: DeferredParseClass a + => (a -> CommandSeek) + -> (CmdParamsDesc -> Parser a) + -> CmdParamsDesc + -> Parser CommandSeek +(<--<) mkseek optparser paramsdesc = + (mkseek <=< finishParse) <$> optparser paramsdesc {- Indicates that a command doesn't need to commit any changes to - the git-annex branch. -} @@ -48,12 +72,21 @@ noMessages c = c { cmdnomessages = True } {- Adds a fallback action to a command, that will be run if it's used - outside a git repository. -} -noRepo :: (CmdParams -> IO ()) -> Command -> Command -noRepo a c = c { cmdnorepo = Just a } +noRepo :: (String -> O.Parser (IO ())) -> Command -> Command +noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) } -{- Adds options to a command. -} -withOptions :: [Option] -> Command -> Command -withOptions o c = c { cmdoptions = cmdoptions c ++ o } +{- Adds global options to a command's option parser, and modifies its seek + - option to first run actions for them. + -} +withGlobalOptions :: [GlobalOption] -> Command -> Command +withGlobalOptions os c = c { cmdparser = apply <$> mixin (cmdparser c) } + where + mixin p = (,) + <$> p + <*> combineGlobalOptions os + apply (seek, globalsetters) = do + void $ getParsed globalsetters + seek {- For start and perform stages to indicate what step to run next. -} next :: a -> Annex (Maybe a) diff --git a/Command/Add.hs b/Command/Add.hs index 5f6f06cdb..11682207e 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -34,28 +34,35 @@ import Utility.Tmp import Control.Exception (IOException) -cmd :: [Command] -cmd = [notBareRepo $ withOptions addOptions $ - command "add" paramPaths seek SectionCommon "add files to annex"] +cmd :: Command +cmd = notBareRepo $ withGlobalOptions fileMatchingOptions $ + command "add" SectionCommon "add files to annex" + paramPaths (seek <$$> optParser) -addOptions :: [Option] -addOptions = includeDotFilesOption : fileMatchingOptions +data AddOptions = AddOptions + { addThese :: CmdParams + , includeDotFiles :: Bool + } -includeDotFilesOption :: Option -includeDotFilesOption = flagOption [] "include-dotfiles" "don't skip dotfiles" +optParser :: CmdParamsDesc -> Parser AddOptions +optParser desc = AddOptions + <$> cmdParams desc + <*> switch + ( long "include-dotfiles" + <> help "don't skip dotfiles" + ) {- Add acts on both files not checked into git yet, and unlocked files. - - In direct mode, it acts on any files that have changed. -} -seek :: CommandSeek -seek ps = do +seek :: AddOptions -> CommandSeek +seek o = do matcher <- largeFilesMatcher - let go a = flip a ps $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force) + let go a = flip a (addThese o) $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force) ( start file , startSmall file ) - skipdotfiles <- not <$> Annex.getFlag (optionName includeDotFilesOption) - go $ withFilesNotInGit skipdotfiles + go $ withFilesNotInGit (not $ includeDotFiles o) ifM isDirect ( go withFilesMaybeModified , go withFilesUnlocked @@ -70,8 +77,8 @@ startSmall file = do performAdd :: FilePath -> CommandPerform performAdd file = do - params <- forceParams - Annex.Queue.addCommand "add" (params++[Param "--"]) [file] + ps <- forceParams + Annex.Queue.addCommand "add" (ps++[Param "--"]) [file] next $ return True {- The add subcommand annexes a file, generating a key for it using a @@ -278,8 +285,8 @@ addLink :: FilePath -> Key -> Maybe InodeCache -> Annex () addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig) ( do _ <- link file key mcache - params <- forceParams - Annex.Queue.addCommand "add" (params++[Param "--"]) [file] + ps <- forceParams + Annex.Queue.addCommand "add" (ps++[Param "--"]) [file] , do l <- link file key mcache addAnnexLink l file diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index 4aab8d017..2b315eada 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -14,11 +14,13 @@ import qualified Command.Add import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) import Types.Key -cmd :: [Command] -cmd = [notDirect $ command "addunused" (paramRepeating paramNumRange) - seek SectionMaintenance "add back unused files"] +cmd :: Command +cmd = notDirect $ + command "addunused" SectionMaintenance + "add back unused files" + (paramRepeating paramNumRange) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withUnusedMaps start start :: UnusedMaps -> Int -> CommandStart diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index fda2a99e0..45edca283 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -37,10 +37,10 @@ import Annex.Quvi import qualified Utility.Quvi as Quvi #endif -cmd :: [Command] -cmd = [notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption, rawOption] $ - command "addurl" (paramRepeating paramUrl) seek - SectionCommon "add urls to annex"] +cmd :: Command +cmd = notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption, rawOption] $ + command "addurl" SectionCommon "add urls to annex" + (paramRepeating paramUrl) (withParams seek) fileOption :: Option fileOption = fieldOption [] "file" paramFile "specify what file the url is added to" @@ -54,7 +54,7 @@ relaxedOption = flagOption [] "relaxed" "skip size check" rawOption :: Option rawOption = flagOption [] "raw" "disable special handling for torrents, quvi, etc" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek us = do optfile <- getOptionField fileOption return relaxed <- getOptionFlag relaxedOption diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 8a916aa55..08e96da07 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -19,10 +19,12 @@ import Assistant.Install import System.Environment -cmd :: [Command] -cmd = [noRepo checkNoRepoOpts $ dontCheck repoExists $ withOptions options $ - notBareRepo $ command "assistant" paramNothing seek SectionCommon - "automatically sync changes"] +cmd :: Command +cmd = dontCheck repoExists $ withOptions options $ notBareRepo $ + noRepo (withParams checkNoRepoOpts) $ + command "assistant" SectionCommon + "automatically sync changes" + paramNothing (withParams seek) options :: [Option] options = @@ -42,7 +44,7 @@ autoStopOption = flagOption [] "autostop" "stop in known repositories" startDelayOption :: Option startDelayOption = fieldOption [] "startdelay" paramNumber "delay before running startup scan" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do stopdaemon <- getOptionFlag Command.Watch.stopOption foreground <- getOptionFlag Command.Watch.foregroundOption diff --git a/Command/CheckPresentKey.hs b/Command/CheckPresentKey.hs index ad61ba3c0..6a38f8501 100644 --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -14,11 +14,14 @@ import qualified Remote import Annex import Types.Messages -cmd :: [Command] -cmd = [noCommit $ command "checkpresentkey" (paramPair paramKey paramRemote) seek - SectionPlumbing "check if key is present in remote"] +cmd :: Command +cmd = noCommit $ + command "checkpresentkey" SectionPlumbing + "check if key is present in remote" + (paramPair paramKey paramRemote) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Commit.hs b/Command/Commit.hs index 73f9e2d5e..52b88d2b3 100644 --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -12,11 +12,12 @@ import Command import qualified Annex.Branch import qualified Git -cmd :: [Command] -cmd = [command "commit" paramNothing seek - SectionPlumbing "commits any staged changes to the git-annex branch"] +cmd :: Command +cmd = command "commit" SectionPlumbing + "commits any staged changes to the git-annex branch" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index 33b348b07..95498ba20 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -15,11 +15,13 @@ import qualified Annex.Branch import qualified Git.Config import Remote.GCrypt (coreGCryptId) -cmd :: [Command] -cmd = [noCommit $ command "configlist" paramNothing seek - SectionPlumbing "outputs relevant git configuration"] +cmd :: Command +cmd = noCommit $ + command "configlist" SectionPlumbing + "outputs relevant git configuration" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs index 10879f5b1..bca73f926 100644 --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -12,12 +12,13 @@ import Command import CmdLine.Batch import Annex.Content -cmd :: [Command] -cmd = [withOptions [batchOption] $ noCommit $ noMessages $ - command "contentlocation" (paramRepeating paramKey) seek - SectionPlumbing "looks up content for a key"] +cmd :: Command +cmd = withOptions [batchOption] $ noCommit $ noMessages $ + command "contentlocation" SectionPlumbing + "looks up content for a key" + (paramRepeating paramKey) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = batchable withKeys start start :: Batchable Key diff --git a/Command/Copy.hs b/Command/Copy.hs index 5cfdabb4e..1c817f67c 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -14,33 +14,44 @@ import qualified Remote import Annex.Wanted import Annex.NumCopies -cmd :: [Command] -cmd = [withOptions copyOptions $ command "copy" paramPaths seek - SectionCommon "copy content of files to/from another repository"] - -copyOptions :: [Option] -copyOptions = Command.Move.moveOptions ++ [autoOption] - -seek :: CommandSeek -seek ps = do - to <- getOptionField toOption Remote.byNameWithUUID - from <- getOptionField fromOption Remote.byNameWithUUID - auto <- getOptionFlag autoOption - withKeyOptions auto - (Command.Move.startKey to from False) - (withFilesInGit $ whenAnnexed $ start auto to from) - ps +cmd :: Command +cmd = command "copy" SectionCommon + "copy content of files to/from another repository" + paramPaths (seek <--< optParser) + +data CopyOptions = CopyOptions + { moveOptions :: Command.Move.MoveOptions + , autoMode :: Bool + } + +optParser :: CmdParamsDesc -> Parser CopyOptions +optParser desc = CopyOptions + <$> Command.Move.optParser desc + <*> parseAutoOption + +instance DeferredParseClass CopyOptions where + finishParse v = CopyOptions + <$> finishParse (moveOptions v) + <*> pure (autoMode v) + +seek :: CopyOptions -> CommandSeek +seek o = withKeyOptions (Command.Move.keyOptions $ moveOptions o) (autoMode o) + (Command.Move.startKey (moveOptions o) False) + (withFilesInGit $ whenAnnexed $ start o) + (Command.Move.moveFiles $ moveOptions o) {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or - sending non-preferred content. -} -start :: Bool -> Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart -start auto to from file key = stopUnless shouldCopy $ - Command.Move.start to from False file key +start :: CopyOptions -> FilePath -> Key -> CommandStart +start o file key = stopUnless shouldCopy $ + Command.Move.start (moveOptions o) False file key where shouldCopy - | auto = want <||> numCopiesCheck file key (<) + | autoMode o = want <||> numCopiesCheck file key (<) | otherwise = return True - want = case to of - Nothing -> wantGet False (Just key) (Just file) - Just r -> wantSend False (Just key) (Just file) (Remote.uuid r) + want = case Command.Move.fromToOptions (moveOptions o) of + ToRemote _ -> + wantGet False (Just key) (Just file) + FromRemote dest -> (Remote.uuid <$> getParsed dest) >>= + wantSend False (Just key) (Just file) diff --git a/Command/Dead.hs b/Command/Dead.hs index 7e62b6db0..e487b3b5e 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -16,16 +16,16 @@ import Command.Trust (trustCommand) import Logs.Location import Remote (keyLocations) -cmd :: [Command] -cmd = [withOptions [keyOption] $ - command "dead" (paramRepeating paramRemote) seek - SectionSetup "hide a lost repository or key"] +cmd :: Command +cmd = withOptions [keyOption] $ + command "dead" SectionSetup "hide a lost repository or key" + (paramRepeating paramRemote) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = maybe (trustCommand "dead" DeadTrusted ps) (flip seekKey ps) =<< Annex.getField "key" -seekKey :: String -> CommandSeek +seekKey :: String -> CmdParams -> CommandSeek seekKey ks = case file2key ks of Nothing -> error "Invalid key" Just key -> withNothing (startKey key) diff --git a/Command/Describe.hs b/Command/Describe.hs index 56a73334d..ca0bac4e8 100644 --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -12,11 +12,13 @@ import Command import qualified Remote import Logs.UUID -cmd :: [Command] -cmd = [command "describe" (paramPair paramRemote paramDesc) seek - SectionSetup "change description of a repository"] +cmd :: Command +cmd = command "describe" SectionSetup + "change description of a repository" + (paramPair paramRemote paramDesc) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs index f6ef77ecd..2313e5f0d 100644 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -13,12 +13,13 @@ import Annex.Content import Annex.Link import Git.Types -cmd :: [Command] -cmd = [dontCheck repoExists $ - command "diffdriver" ("[-- cmd --]") seek - SectionPlumbing "external git diff driver shim"] +cmd :: Command +cmd = dontCheck repoExists $ + command "diffdriver" SectionPlumbing + "external git diff driver shim" + ("-- cmd --") (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Direct.hs b/Command/Direct.hs index 1a6b2cb05..162780dd5 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -15,12 +15,12 @@ import qualified Git.Branch import Config import Annex.Direct -cmd :: [Command] -cmd = [notBareRepo $ noDaemonRunning $ - command "direct" paramNothing seek - SectionSetup "switch repository to direct mode"] +cmd :: Command +cmd = notBareRepo $ noDaemonRunning $ + command "direct" SectionSetup "switch repository to direct mode" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/Drop.hs b/Command/Drop.hs index 698dd7bad..feb89b70e 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -22,45 +22,60 @@ import Annex.Notification import qualified Data.Set as S -cmd :: [Command] -cmd = [withOptions (dropOptions) $ command "drop" paramPaths seek - SectionCommon "indicate content of files not currently wanted"] - -dropOptions :: [Option] -dropOptions = dropFromOption : annexedMatchingOptions ++ [autoOption] ++ keyOptions - -dropFromOption :: Option -dropFromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote" - -seek :: CommandSeek -seek ps = do - from <- getOptionField dropFromOption Remote.byNameWithUUID - auto <- getOptionFlag autoOption - withKeyOptions auto - (startKeys auto from) - (withFilesInGit $ whenAnnexed $ start auto from) - ps - -start :: Bool -> Maybe Remote -> FilePath -> Key -> CommandStart -start auto from file key = start' auto from key (Just file) - -start' :: Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart -start' auto from key afile = checkDropAuto auto from afile key $ \numcopies -> - stopUnless want $ - case from of - Nothing -> startLocal afile numcopies key Nothing - Just remote -> do - u <- getUUID - if Remote.uuid remote == u - then startLocal afile numcopies key Nothing - else startRemote afile numcopies key remote - where - want - | auto = wantDrop False (Remote.uuid <$> from) (Just key) afile - | otherwise = return True - -startKeys :: Bool -> Maybe Remote -> Key -> CommandStart -startKeys auto from key = start' auto from key Nothing +cmd :: Command +cmd = withGlobalOptions annexedMatchingOptions $ + command "drop" SectionCommon + "remove content of files from repository" + paramPaths (seek <$$> optParser) + +data DropOptions = DropOptions + { dropFiles :: CmdParams + , dropFrom :: Maybe (DeferredParse Remote) + , autoMode :: Bool + , keyOptions :: Maybe KeyOptions + } + +optParser :: CmdParamsDesc -> Parser DropOptions +optParser desc = DropOptions + <$> cmdParams desc + <*> optional parseDropFromOption + <*> parseAutoOption + <*> optional (parseKeyOptions False) + +parseDropFromOption :: Parser (DeferredParse Remote) +parseDropFromOption = parseRemoteOption $ strOption + ( long "from" <> short 'f' <> metavar paramRemote + <> help "drop content from a remote" + ) + +seek :: DropOptions -> CommandSeek +seek o = withKeyOptions (keyOptions o) (autoMode o) + (startKeys o) + (withFilesInGit $ whenAnnexed $ start o) + (dropFiles o) + +start :: DropOptions -> FilePath -> Key -> CommandStart +start o file key = start' o key (Just file) + +start' :: DropOptions -> Key -> AssociatedFile -> CommandStart +start' o key afile = do + from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o) + checkDropAuto (autoMode o) from afile key $ \numcopies -> + stopUnless (want from) $ + case from of + Nothing -> startLocal afile numcopies key Nothing + Just remote -> do + u <- getUUID + if Remote.uuid remote == u + then startLocal afile numcopies key Nothing + else startRemote afile numcopies key remote + where + want from + | autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile + | otherwise = return True + +startKeys :: DropOptions -> Key -> CommandStart +startKeys o key = start' o key Nothing startLocal :: AssociatedFile -> NumCopies -> Key -> Maybe Remote -> CommandStart startLocal afile numcopies key knownpresentremote = stopUnless (inAnnex key) $ do @@ -164,10 +179,10 @@ requiredContent = do {- In auto mode, only runs the action if there are enough - copies on other semitrusted repositories. -} checkDropAuto :: Bool -> Maybe Remote -> AssociatedFile -> Key -> (NumCopies -> CommandStart) -> CommandStart -checkDropAuto auto mremote afile key a = go =<< maybe getNumCopies getFileNumCopies afile +checkDropAuto automode mremote afile key a = go =<< maybe getNumCopies getFileNumCopies afile where go numcopies - | auto = do + | automode = do locs <- Remote.keyLocations key uuid <- getUUID let remoteuuid = fromMaybe uuid $ Remote.uuid <$> mremote diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 890a79466..5d44f0fcd 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -13,11 +13,14 @@ import qualified Annex import Logs.Location import Annex.Content -cmd :: [Command] -cmd = [noCommit $ command "dropkey" (paramRepeating paramKey) seek - SectionPlumbing "drops annexed content for specified keys"] +cmd :: Command +cmd = noCommit $ + command "dropkey" SectionPlumbing + "drops annexed content for specified keys" + (paramRepeating paramKey) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withKeys start start :: Key -> CommandStart diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index d441a4bd2..98fcef6ea 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -9,34 +9,42 @@ module Command.DropUnused where import Common.Annex import Command -import qualified Annex import qualified Command.Drop import qualified Remote import qualified Git import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) import Annex.NumCopies -cmd :: [Command] -cmd = [withOptions [Command.Drop.dropFromOption] $ - command "dropunused" (paramRepeating paramNumRange) - seek SectionMaintenance "drop unused file content"] +cmd :: Command +cmd = command "dropunused" SectionMaintenance + "drop unused file content" + (paramRepeating paramNumRange) (seek <$$> optParser) -seek :: CommandSeek -seek ps = do +data DropUnusedOptions = DropUnusedOptions + { rangesToDrop :: CmdParams + , dropFrom :: Maybe (DeferredParse Remote) + } + +optParser :: CmdParamsDesc -> Parser DropUnusedOptions +optParser desc = DropUnusedOptions + <$> cmdParams desc + <*> optional (Command.Drop.parseDropFromOption) + +seek :: DropUnusedOptions -> CommandSeek +seek o = do numcopies <- getNumCopies - withUnusedMaps (start numcopies) ps + from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o) + withUnusedMaps (start from numcopies) (rangesToDrop o) -start :: NumCopies -> UnusedMaps -> Int -> CommandStart -start numcopies = startUnused "dropunused" (perform numcopies) (performOther gitAnnexBadLocation) (performOther gitAnnexTmpObjectLocation) +start :: Maybe Remote -> NumCopies -> UnusedMaps -> Int -> CommandStart +start from numcopies = startUnused "dropunused" (perform from numcopies) (performOther gitAnnexBadLocation) (performOther gitAnnexTmpObjectLocation) -perform :: NumCopies -> Key -> CommandPerform -perform numcopies key = maybe droplocal dropremote =<< Remote.byNameWithUUID =<< from - where - dropremote r = do +perform :: Maybe Remote -> NumCopies -> Key -> CommandPerform +perform from numcopies key = case from of + Just r -> do showAction $ "from " ++ Remote.name r Command.Drop.performRemote key Nothing numcopies r - droplocal = Command.Drop.performLocal key Nothing numcopies Nothing - from = Annex.getField $ optionName Command.Drop.dropFromOption + Nothing -> Command.Drop.performLocal key Nothing numcopies Nothing performOther :: (Key -> Git.Repo -> FilePath) -> Key -> CommandPerform performOther filespec key = do diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index db3ec2b37..1d4c4af5e 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -15,12 +15,13 @@ import qualified Command.InitRemote as InitRemote import qualified Data.Map as M -cmd :: [Command] -cmd = [command "enableremote" +cmd :: Command +cmd = command "enableremote" SectionSetup + "enables use of an existing special remote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) - seek SectionSetup "enables use of an existing special remote"] + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs index 05db9817a..e0a1d9747 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -11,15 +11,16 @@ import Common.Annex import Command import CmdLine.Batch import qualified Utility.Format -import Command.Find (formatOption, getFormat, showFormatted, keyVars) +import Command.Find (FindOptions(..), showFormatted, keyVars) import Types.Key -cmd :: [Command] -cmd = [noCommit $ noMessages $ withOptions [formatOption, jsonOption, batchOption] $ - command "examinekey" (paramRepeating paramKey) seek - SectionPlumbing "prints information from a key"] +cmd :: Command +cmd = noCommit $ noMessages $ withOptions [formatOption, jsonOption, batchOption] $ + command "examinekey" SectionPlumbing + "prints information from a key" + (paramRepeating paramKey) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do format <- getFormat batchable withKeys (start format) ps diff --git a/Command/Expire.hs b/Command/Expire.hs index f4d1a06e3..1e67d1d2a 100644 --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -20,29 +20,40 @@ import Utility.HumanTime import Data.Time.Clock.POSIX import qualified Data.Map as M -cmd :: [Command] -cmd = [withOptions [activityOption, noActOption] $ command "expire" paramExpire seek - SectionMaintenance "expire inactive repositories"] +cmd :: Command +cmd = command "expire" SectionMaintenance + "expire inactive repositories" + paramExpire (seek <$$> optParser) paramExpire :: String paramExpire = (paramRepeating $ paramOptional paramRemote ++ ":" ++ paramTime) -activityOption :: Option -activityOption = fieldOption [] "activity" "Name" "specify activity" +data ExpireOptions = ExpireOptions + { expireParams :: CmdParams + , activityOption :: Maybe Activity + , noActOption :: Bool + } -noActOption :: Option -noActOption = flagOption [] "no-act" "don't really do anything" +optParser :: CmdParamsDesc -> Parser ExpireOptions +optParser desc = ExpireOptions + <$> cmdParams desc + <*> optional (option (str >>= parseActivity) + ( long "activity" <> metavar paramName + <> help "specify activity that prevents expiry" + )) + <*> switch + ( long "no-act" + <> help "don't really do anything" + ) -seek :: CommandSeek -seek ps = do - expire <- parseExpire ps - wantact <- getOptionField activityOption (pure . parseActivity) - noact <- getOptionFlag noActOption - actlog <- lastActivities wantact +seek :: ExpireOptions -> CommandSeek +seek o = do + expire <- parseExpire (expireParams o) + actlog <- lastActivities (activityOption o) u <- getUUID us <- filter (/= u) . M.keys <$> uuidMap descs <- uuidMap - seekActions $ pure $ map (start expire noact actlog descs) us + seekActions $ pure $ map (start expire (noActOption o) actlog descs) us start :: Expire -> Bool -> Log Activity -> M.Map UUID String -> UUID -> CommandStart start (Expire expire) noact actlog descs u = @@ -97,10 +108,9 @@ parseExpire ps = do Nothing -> error $ "bad expire time: " ++ s Just d -> Just (now - durationToPOSIXTime d) -parseActivity :: Maybe String -> Maybe Activity -parseActivity Nothing = Nothing -parseActivity (Just s) = case readish s of - Nothing -> error $ "Unknown activity. Choose from: " ++ +parseActivity :: Monad m => String -> m Activity +parseActivity s = case readish s of + Nothing -> fail $ "Unknown activity. Choose from: " ++ unwords (map show [minBound..maxBound :: Activity]) - Just v -> Just v + Just v -> return v diff --git a/Command/Find.hs b/Command/Find.hs index 236824643..dd82bd401 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -14,34 +14,41 @@ import Common.Annex import Command import Annex.Content import Limit -import qualified Annex import qualified Utility.Format import Utility.DataUnits import Types.Key -cmd :: [Command] -cmd = [withOptions annexedMatchingOptions $ mkCommand $ - command "find" paramPaths seek SectionQuery "lists available files"] +cmd :: Command +cmd = withGlobalOptions annexedMatchingOptions $ mkCommand $ + command "find" SectionQuery "lists available files" + paramPaths (seek <$$> optParser) mkCommand :: Command -> Command -mkCommand = noCommit . noMessages . withOptions [formatOption, print0Option, jsonOption] +mkCommand = noCommit . noMessages . withGlobalOptions [jsonOption] -formatOption :: Option -formatOption = fieldOption [] "format" paramFormat "control format of output" +data FindOptions = FindOptions + { findThese :: CmdParams + , formatOption :: Maybe Utility.Format.Format + } -getFormat :: Annex (Maybe Utility.Format.Format) -getFormat = getOptionField formatOption $ return . fmap Utility.Format.gen +optParser :: CmdParamsDesc -> Parser FindOptions +optParser desc = FindOptions + <$> cmdParams desc + <*> optional parseFormatOption -print0Option :: Option -print0Option = Option [] ["print0"] (NoArg set) - "terminate output with null" - where - set = Annex.setField (optionName formatOption) "${file}\0" +parseFormatOption :: Parser Utility.Format.Format +parseFormatOption = + option (Utility.Format.gen <$> str) + ( long "format" <> metavar paramFormat + <> help "control format of output" + ) + <|> flag' (Utility.Format.gen "${file}\0") + ( long "print0" + <> help "output filenames terminated with nulls" + ) -seek :: CommandSeek -seek ps = do - format <- getFormat - withFilesInGit (whenAnnexed $ start format) ps +seek :: FindOptions -> CommandSeek +seek o = withFilesInGit (whenAnnexed $ start (formatOption o)) (findThese o) start :: Maybe Utility.Format.Format -> FilePath -> Key -> CommandStart start format file key = do diff --git a/Command/FindRef.hs b/Command/FindRef.hs index e7f7eae6d..cd7583b96 100644 --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -10,12 +10,13 @@ module Command.FindRef where import Command import qualified Command.Find as Find -cmd :: [Command] -cmd = [withOptions nonWorkTreeMatchingOptions $ Find.mkCommand $ - command "findref" paramRef seek SectionPlumbing - "lists files in a git ref"] +cmd :: Command +cmd = withOptions nonWorkTreeMatchingOptions $ Find.mkCommand $ + command "findref" SectionPlumbing + "lists files in a git ref" + paramRef (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek refs = do format <- Find.getFormat Find.start format `withFilesInRefs` refs diff --git a/Command/Fix.hs b/Command/Fix.hs index c4e5e52ee..abaedb30b 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -18,12 +18,13 @@ import Utility.Touch #endif #endif -cmd :: [Command] -cmd = [notDirect $ noCommit $ withOptions annexedMatchingOptions $ - command "fix" paramPaths seek - SectionMaintenance "fix up symlinks to point to annexed content"] +cmd :: Command +cmd = notDirect $ noCommit $ withGlobalOptions annexedMatchingOptions $ + command "fix" SectionMaintenance + "fix up symlinks to point to annexed content" + paramPaths (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withFilesInGit $ whenAnnexed start {- Fixes the symlink to an annexed file. -} diff --git a/Command/Forget.hs b/Command/Forget.hs index 94a1fb421..24789fe44 100644 --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -15,9 +15,11 @@ import qualified Annex import Data.Time.Clock.POSIX -cmd :: [Command] -cmd = [withOptions forgetOptions $ command "forget" paramNothing seek - SectionMaintenance "prune git-annex branch history"] +cmd :: Command +cmd = withOptions forgetOptions $ + command "forget" SectionMaintenance + "prune git-annex branch history" + paramNothing (withParams seek) forgetOptions :: [Option] forgetOptions = [dropDeadOption] @@ -25,7 +27,7 @@ forgetOptions = [dropDeadOption] dropDeadOption :: Option dropDeadOption = flagOption [] "drop-dead" "drop references to dead repositories" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do dropdead <- getOptionFlag dropDeadOption withNothing (start dropdead) ps diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 51389b770..6a3fe3a4a 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -19,12 +19,13 @@ import qualified Backend.URL import Network.URI -cmd :: [Command] -cmd = [notDirect $ notBareRepo $ - command "fromkey" (paramPair paramKey paramPath) seek - SectionPlumbing "adds a file using a specific key"] +cmd :: Command +cmd = notDirect $ notBareRepo $ + command "fromkey" SectionPlumbing "adds a file using a specific key" + (paramPair paramKey paramPath) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do force <- Annex.getState Annex.force withWords (start force) ps diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 8988100b8..0e0c49d78 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -40,40 +40,57 @@ import qualified Database.Fsck as FsckDb import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) -cmd :: [Command] -cmd = [withOptions fsckOptions $ command "fsck" paramPaths seek - SectionMaintenance "check for problems"] - -fsckFromOption :: Option -fsckFromOption = fieldOption ['f'] "from" paramRemote "check remote" - -startIncrementalOption :: Option -startIncrementalOption = flagOption ['S'] "incremental" "start an incremental fsck" - -moreIncrementalOption :: Option -moreIncrementalOption = flagOption ['m'] "more" "continue an incremental fsck" - -incrementalScheduleOption :: Option -incrementalScheduleOption = fieldOption [] "incremental-schedule" paramTime - "schedule incremental fscking" - -fsckOptions :: [Option] -fsckOptions = - [ fsckFromOption - , startIncrementalOption - , moreIncrementalOption - , incrementalScheduleOption - ] ++ keyOptions ++ annexedMatchingOptions - -seek :: CommandSeek -seek ps = do - from <- getOptionField fsckFromOption Remote.byNameWithUUID +cmd :: Command +cmd = withGlobalOptions annexedMatchingOptions $ + command "fsck" SectionMaintenance + "find and fix problems" + paramPaths (seek <$$> optParser) + +data FsckOptions = FsckOptions + { fsckFiles :: CmdParams + , fsckFromOption :: Maybe (DeferredParse Remote) + , incrementalOpt :: Maybe IncrementalOpt + , keyOptions :: Maybe KeyOptions + } + +data IncrementalOpt + = StartIncrementalO + | MoreIncrementalO + | ScheduleIncrementalO Duration + +optParser :: CmdParamsDesc -> Parser FsckOptions +optParser desc = FsckOptions + <$> cmdParams desc + <*> optional (parseRemoteOption $ strOption + ( long "from" <> short 'f' <> metavar paramRemote + <> help "check remote" + )) + <*> optional parseincremental + <*> optional (parseKeyOptions False) + where + parseincremental = + flag' StartIncrementalO + ( long "incremental" <> short 'S' + <> help "start an incremental fsck" + ) + <|> flag' MoreIncrementalO + ( long "more" <> short 'm' + <> help "continue an incremental fsck" + ) + <|> (ScheduleIncrementalO <$> option (str >>= parseDuration) + ( long "incremental-schedule" <> metavar paramTime + <> help "schedule incremental fscking" + )) + +seek :: FsckOptions -> CommandSeek +seek o = do + from <- maybe (pure Nothing) (Just <$$> getParsed) (fsckFromOption o) u <- maybe getUUID (pure . Remote.uuid) from - i <- getIncremental u - withKeyOptions False + i <- prepIncremental u (incrementalOpt o) + withKeyOptions (keyOptions o) False (\k -> startKey i k =<< getNumCopies) (withFilesInGit $ whenAnnexed $ start from i) - ps + (fsckFiles o) withFsckDb i FsckDb.closeDb void $ tryIO $ recordActivity Fsck u @@ -497,37 +514,26 @@ getStartTime u = do data Incremental = StartIncremental FsckDb.FsckHandle | ContIncremental FsckDb.FsckHandle | NonIncremental -getIncremental :: UUID -> Annex Incremental -getIncremental u = do - i <- maybe (return False) (checkschedule . parseDuration) - =<< Annex.getField (optionName incrementalScheduleOption) - starti <- getOptionFlag startIncrementalOption - morei <- getOptionFlag moreIncrementalOption - case (i, starti, morei) of - (False, False, False) -> return NonIncremental - (False, True, False) -> startIncremental - (False ,False, True) -> contIncremental - (True, False, False) -> - maybe startIncremental (const contIncremental) - =<< getStartTime u - _ -> error "Specify only one of --incremental, --more, or --incremental-schedule" - where - startIncremental = do - recordStartTime u - ifM (FsckDb.newPass u) - ( StartIncremental <$> FsckDb.openDb u - , error "Cannot start a new --incremental fsck pass; another fsck process is already running." - ) - contIncremental = ContIncremental <$> FsckDb.openDb u - - checkschedule Nothing = error "bad --incremental-schedule value" - checkschedule (Just delta) = do - Annex.addCleanup FsckCleanup $ do - v <- getStartTime u - case v of - Nothing -> noop - Just started -> do - now <- liftIO getPOSIXTime - when (now - realToFrac started >= durationToPOSIXTime delta) $ - resetStartTime u - return True +prepIncremental :: UUID -> Maybe IncrementalOpt -> Annex Incremental +prepIncremental _ Nothing = pure NonIncremental +prepIncremental u (Just StartIncrementalO) = do + recordStartTime u + ifM (FsckDb.newPass u) + ( StartIncremental <$> FsckDb.openDb u + , error "Cannot start a new --incremental fsck pass; another fsck process is already running." + ) +prepIncremental u (Just MoreIncrementalO) = + ContIncremental <$> FsckDb.openDb u +prepIncremental u (Just (ScheduleIncrementalO delta)) = do + Annex.addCleanup FsckCleanup $ do + v <- getStartTime u + case v of + Nothing -> noop + Just started -> do + now <- liftIO getPOSIXTime + when (now - realToFrac started >= durationToPOSIXTime delta) $ + resetStartTime u + started <- getStartTime u + prepIncremental u $ Just $ case started of + Nothing -> StartIncrementalO + Just _ -> MoreIncrementalO diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index d6c9e1ac1..fd888e0df 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -20,11 +20,13 @@ import System.Random (getStdRandom, random, randomR) import Test.QuickCheck import Control.Concurrent -cmd :: [Command] -cmd = [ notBareRepo $ command "fuzztest" paramNothing seek SectionTesting - "generates fuzz test files"] +cmd :: Command +cmd = notBareRepo $ + command "fuzztest" SectionTesting + "generates fuzz test files" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart @@ -53,9 +55,9 @@ guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $ fuzz :: Handle -> Annex () fuzz logh = do - action <- genFuzzAction - record logh $ flip Started action - result <- tryNonAsync $ runFuzzAction action + fuzzer <- genFuzzAction + record logh $ flip Started fuzzer + result <- tryNonAsync $ runFuzzAction fuzzer record logh $ flip Finished $ either (const False) (const True) result diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs index 7a7f8ae50..5c2686635 100644 --- a/Command/GCryptSetup.hs +++ b/Command/GCryptSetup.hs @@ -13,12 +13,13 @@ import Annex.UUID import qualified Remote.GCrypt import qualified Git -cmd :: [Command] -cmd = [dontCheck repoExists $ noCommit $ - command "gcryptsetup" paramValue seek - SectionPlumbing "sets up gcrypt repository"] +cmd :: Command +cmd = dontCheck repoExists $ noCommit $ + command "gcryptsetup" SectionPlumbing + "sets up gcrypt repository" + paramValue (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withStrings start start :: String -> CommandStart diff --git a/Command/Get.hs b/Command/Get.hs index d39b3890f..324ff2752 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -16,28 +16,39 @@ import Annex.NumCopies import Annex.Wanted import qualified Command.Move -cmd :: [Command] -cmd = [withOptions getOptions $ command "get" paramPaths seek - SectionCommon "make content of annexed files available"] +cmd :: Command +cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $ + command "get" SectionCommon + "make content of annexed files available" + paramPaths (seek <$$> optParser) -getOptions :: [Option] -getOptions = fromOption : autoOption : jobsOption : annexedMatchingOptions - ++ incompleteOption : keyOptions +data GetOptions = GetOptions + { getFiles :: CmdParams + , getFrom :: Maybe (DeferredParse Remote) + , autoMode :: Bool + , keyOptions :: Maybe KeyOptions + } -seek :: CommandSeek -seek ps = do - from <- getOptionField fromOption Remote.byNameWithUUID - auto <- getOptionFlag autoOption - withKeyOptions auto +optParser :: CmdParamsDesc -> Parser GetOptions +optParser desc = GetOptions + <$> cmdParams desc + <*> optional parseFromOption + <*> parseAutoOption + <*> optional (parseKeyOptions True) + +seek :: GetOptions -> CommandSeek +seek o = do + from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) + withKeyOptions (keyOptions o) (autoMode o) (startKeys from) - (withFilesInGit $ whenAnnexed $ start auto from) - ps + (withFilesInGit $ whenAnnexed $ start o from) + (getFiles o) -start :: Bool -> Maybe Remote -> FilePath -> Key -> CommandStart -start auto from file key = start' expensivecheck from key (Just file) +start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart +start o from file key = start' expensivecheck from key (Just file) where expensivecheck - | auto = numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file) + | autoMode o = numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file) | otherwise = return True startKeys :: Maybe Remote -> Key -> CommandStart diff --git a/Command/Group.hs b/Command/Group.hs index 820f6ab17..6543fa2fb 100644 --- a/Command/Group.hs +++ b/Command/Group.hs @@ -15,11 +15,11 @@ import Types.Group import qualified Data.Set as S -cmd :: [Command] -cmd = [command "group" (paramPair paramRemote paramDesc) seek - SectionSetup "add a repository to a group"] +cmd :: Command +cmd = command "group" SectionSetup "add a repository to a group" + (paramPair paramRemote paramDesc) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/GroupWanted.hs b/Command/GroupWanted.hs index 5cdf785d7..0565344b1 100644 --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -12,11 +12,13 @@ import Command import Logs.PreferredContent import Command.Wanted (performGet, performSet) -cmd :: [Command] -cmd = [command "groupwanted" (paramPair paramGroup (paramOptional paramExpression)) seek - SectionSetup "get or set groupwanted expression"] +cmd :: Command +cmd = command "groupwanted" SectionSetup + "get or set groupwanted expression" + (paramPair paramGroup (paramOptional paramExpression)) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Help.hs b/Command/Help.hs index 2af39ac9a..a44dcb234 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -19,13 +19,15 @@ import qualified Command.Sync import qualified Command.Whereis import qualified Command.Fsck -import System.Console.GetOpt - -cmd :: [Command] -cmd = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "help" (paramOptional "COMMAND") seek SectionCommon "display help"] +cmd :: Command +cmd = noCommit $ dontCheck repoExists $ + noRepo (parseparams startNoRepo) $ + command "help" SectionCommon "display help" + "COMMAND" (parseparams seek) + where + parseparams = withParams -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart @@ -37,17 +39,13 @@ startNoRepo :: CmdParams -> IO () startNoRepo = start' start' :: [String] -> IO () -start' ["options"] = showCommonOptions start' [c] = showGitHelp c start' _ = showGeneralHelp -showCommonOptions :: IO () -showCommonOptions = putStrLn $ usageInfo "Common options:" gitAnnexOptions - showGeneralHelp :: IO () showGeneralHelp = putStrLn $ unlines [ "The most frequently used git-annex commands are:" - , unlines $ map cmdline $ concat + , unlines $ map cmdline $ [ Command.Init.cmd , Command.Add.cmd , Command.Drop.cmd @@ -58,9 +56,8 @@ showGeneralHelp = putStrLn $ unlines , Command.Whereis.cmd , Command.Fsck.cmd ] - , "Run 'git-annex' for a complete command list." - , "Run 'git-annex help command' for help on a specific command." - , "Run `git annex help options' for a list of common options." + , "For a complete command list, run: git-annex" + , "For help on a specific command, run: git-annex help COMMAND" ] where cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c diff --git a/Command/Import.hs b/Command/Import.hs index acf3bc01f..684641ea3 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -22,11 +22,13 @@ import Annex.NumCopies import Types.TrustLevel import Logs.Trust -cmd :: [Command] -cmd = [withOptions opts $ notBareRepo $ command "import" paramPaths seek - SectionCommon "move and add files from outside git working copy"] +cmd :: Command +cmd = withOptions opts $ notBareRepo $ + command "import" SectionCommon + "move and add files from outside git working copy" + paramPaths (withParams seek) -opts :: [Option] +opts :: [GlobalOption] opts = duplicateModeOptions ++ fileMatchingOptions data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates @@ -60,7 +62,7 @@ getDuplicateMode = go . catMaybes <$> mapM getflag [minBound..maxBound] go ms = error $ "cannot combine " ++ unwords (map (optionParam . fromJust . associatedOption) ms) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do mode <- getDuplicateMode repopath <- liftIO . absPath =<< fromRepo Git.repoPath diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index 4bc3f52f4..5e4869b30 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -43,15 +43,15 @@ import Types.MetaData import Logs.MetaData import Annex.MetaData -cmd :: [Command] -cmd = [notBareRepo $ withOptions [templateOption, relaxedOption, rawOption] $ - command "importfeed" (paramRepeating paramUrl) seek - SectionCommon "import files from podcast feeds"] +cmd :: Command +cmd = notBareRepo $ withOptions [templateOption, relaxedOption, rawOption] $ + command "importfeed" SectionCommon "import files from podcast feeds" + (paramRepeating paramUrl) (withParams seek) templateOption :: Option templateOption = fieldOption [] "template" paramFormat "template for filenames" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do tmpl <- getOptionField templateOption return relaxed <- getOptionFlag relaxedOption diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs index 8e792c4bb..c00f18ead 100644 --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -11,11 +11,14 @@ import Common.Annex import Command import Annex.Content -cmd :: [Command] -cmd = [noCommit $ command "inannex" (paramRepeating paramKey) seek - SectionPlumbing "checks if keys are present in the annex"] +cmd :: Command +cmd = noCommit $ + command "inannex" SectionPlumbing + "checks if keys are present in the annex" + (paramRepeating paramKey) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withKeys start start :: Key -> CommandStart diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 1d703d2f3..c12c91a48 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -22,12 +22,12 @@ import Annex.CatFile import Annex.Init import qualified Command.Add -cmd :: [Command] -cmd = [notBareRepo $ noDaemonRunning $ - command "indirect" paramNothing seek - SectionSetup "switch repository to indirect mode"] +cmd :: Command +cmd = notBareRepo $ noDaemonRunning $ + command "indirect" SectionSetup "switch repository to indirect mode" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/Info.hs b/Command/Info.hs index e6e0194ce..9b9e8f6ca 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -78,12 +78,13 @@ emptyStatInfo = StatInfo Nothing Nothing M.empty Nothing -- a state monad for running Stats in type StatState = StateT StatInfo Annex -cmd :: [Command] -cmd = [noCommit $ dontCheck repoExists $ withOptions (jsonOption : bytesOption : annexedMatchingOptions) $ - command "info" (paramOptional $ paramRepeating paramItem) seek SectionQuery - "shows information about the specified item or the repository as a whole"] +cmd :: Command +cmd = noCommit $ dontCheck repoExists $ withOptions (jsonOption : bytesOption : annexedMatchingOptions) $ + command "info" SectionQuery + "shows information about the specified item or the repository as a whole" + (paramRepeating paramItem) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart @@ -134,8 +135,8 @@ fileInfo file k = showCustom (unwords ["info", file]) $ do remoteInfo :: Remote -> Annex () remoteInfo r = showCustom (unwords ["info", Remote.name r]) $ do - info <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r - l <- selStats (remote_fast_stats r ++ info) (uuid_slow_stats (Remote.uuid r)) + i <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r + l <- selStats (remote_fast_stats r ++ i) (uuid_slow_stats (Remote.uuid r)) evalStateT (mapM_ showStat l) emptyStatInfo return True diff --git a/Command/Init.hs b/Command/Init.hs index 23203b035..0f32f1ba1 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -11,11 +11,12 @@ import Common.Annex import Command import Annex.Init -cmd :: [Command] -cmd = [dontCheck repoExists $ - command "init" paramDesc seek SectionSetup "initialize git-annex"] +cmd :: Command +cmd = dontCheck repoExists $ + command "init" SectionSetup "initialize git-annex" + paramDesc (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 7831fe22a..a3a946944 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -19,12 +19,13 @@ import Logs.Trust import Data.Ord -cmd :: [Command] -cmd = [command "initremote" +cmd :: Command +cmd = command "initremote" SectionSetup + "creates a special (non-git) remote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) - seek SectionSetup "creates a special (non-git) remote"] + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/List.hs b/Command/List.hs index b9b3a376c..723f53b46 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -23,15 +23,16 @@ import Annex.UUID import qualified Annex import Git.Types (RemoteName) -cmd :: [Command] -cmd = [noCommit $ withOptions (allrepos : annexedMatchingOptions) $ - command "list" paramPaths seek - SectionQuery "show which remotes contain files"] +cmd :: Command +cmd = noCommit $ withOptions (allrepos : annexedMatchingOptions) $ + command "list" SectionQuery + "show which remotes contain files" + paramPaths (withParams seek) allrepos :: Option allrepos = flagOption [] "allrepos" "show all repositories, not only remotes" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do list <- getList printHeader list diff --git a/Command/Lock.hs b/Command/Lock.hs index 720169506..7711ec3b8 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -12,12 +12,13 @@ import Command import qualified Annex.Queue import qualified Annex -cmd :: [Command] -cmd = [notDirect $ withOptions annexedMatchingOptions $ - command "lock" paramPaths seek SectionCommon - "undo unlock command"] +cmd :: Command +cmd = notDirect $ withGlobalOptions annexedMatchingOptions $ + command "lock" SectionCommon + "undo unlock command" + paramPaths (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do withFilesUnlocked start ps withFilesUnlockedToBeCommitted start ps diff --git a/Command/Log.hs b/Command/Log.hs index 495c43c5a..eb740b249 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -38,11 +38,12 @@ data RefChange = RefChange type Outputter = Bool -> POSIXTime -> [UUID] -> Annex () -cmd :: [Command] -cmd = [withOptions options $ - command "log" paramPaths seek SectionQuery "shows location log"] +cmd :: Command +cmd = withGlobalOptions options $ + command "log" SectionQuery "shows location log" + paramPaths (withParams seek) -options :: [Option] +options :: [GlobalOption] options = passthruOptions ++ [gourceOption] ++ annexedMatchingOptions passthruOptions :: [Option] @@ -56,7 +57,7 @@ passthruOptions = map odate ["since", "after", "until", "before"] ++ gourceOption :: Option gourceOption = flagOption [] "gource" "format output for gource" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do m <- Remote.uuidDescriptions zone <- liftIO getCurrentTimeZone diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs index 6e7f07049..021dc963b 100644 --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -13,12 +13,13 @@ import CmdLine.Batch import Annex.CatFile import Types.Key -cmd :: [Command] -cmd = [withOptions [batchOption] $ notBareRepo $ noCommit $ noMessages $ - command "lookupkey" (paramRepeating paramFile) seek - SectionPlumbing "looks up key used for file"] +cmd :: Command +cmd = withOptions [batchOption] $ notBareRepo $ noCommit $ noMessages $ + command "lookupkey" SectionPlumbing + "looks up key used for file" + (paramRepeating paramFile) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = batchable withStrings start start :: Batchable String diff --git a/Command/Map.hs b/Command/Map.hs index 75af591d5..955010809 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -25,12 +25,13 @@ import qualified Utility.Dot as Dot -- a link from the first repository to the second (its remote) data Link = Link Git.Repo Git.Repo -cmd :: [Command] -cmd = [dontCheck repoExists $ - command "map" paramNothing seek SectionQuery - "generate map of repositories"] +cmd :: Command +cmd = dontCheck repoExists $ + command "map" SectionQuery + "generate map of repositories" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/Merge.hs b/Command/Merge.hs index 28e3bbb4d..8ea4e79e4 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -13,11 +13,12 @@ import qualified Annex.Branch import qualified Git.Branch import Command.Sync (prepMerge, mergeLocal) -cmd :: [Command] -cmd = [command "merge" paramNothing seek SectionMaintenance - "automatically merge changes from remotes"] +cmd :: Command +cmd = command "merge" SectionMaintenance + "automatically merge changes from remotes" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do withNothing mergeBranch ps withNothing mergeSynced ps diff --git a/Command/MetaData.hs b/Command/MetaData.hs index 10093ab08..3b38c8b95 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -16,10 +16,11 @@ import Logs.MetaData import qualified Data.Set as S import Data.Time.Clock.POSIX -cmd :: [Command] -cmd = [withOptions metaDataOptions $ - command "metadata" paramPaths seek - SectionMetaData "sets or gets metadata of a file"] +cmd :: Command +cmd = withOptions metaDataOptions $ + command "metadata" + SectionMetaData "sets or gets metadata of a file" + paramPaths (withParams seek) metaDataOptions :: [Option] metaDataOptions = @@ -52,7 +53,7 @@ untagOption = Option ['u'] ["untag"] (ReqArg mkmod "TAG") "remove a tag" where mkmod = storeModMeta . AddMeta tagMetaField . mkMetaValue (CurrentlySet False) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do modmeta <- Annex.getState Annex.modmeta getfield <- getOptionField getOption $ \ms -> diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 6ffe354d5..d1c7902d7 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -18,12 +18,13 @@ import qualified Command.ReKey import qualified Command.Fsck import qualified Annex -cmd :: [Command] -cmd = [notDirect $ withOptions annexedMatchingOptions $ - command "migrate" paramPaths seek - SectionUtility "switch data to different backend"] +cmd :: Command +cmd = notDirect $ withGlobalOptions annexedMatchingOptions $ + command "migrate" SectionUtility + "switch data to different backend" + paramPaths (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withFilesInGit $ whenAnnexed start start :: FilePath -> Key -> CommandStart diff --git a/Command/Mirror.hs b/Command/Mirror.hs index 535dc64b6..f0880e87e 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -16,14 +16,16 @@ import qualified Remote import Annex.Content import Annex.NumCopies -cmd :: [Command] -cmd = [withOptions mirrorOptions $ command "mirror" paramPaths seek - SectionCommon "mirror content of files to/from another repository"] +cmd :: Command +cmd = withOptions mirrorOptions $ + command "mirror" SectionCommon + "mirror content of files to/from another repository" + paramPaths (withParams seek) mirrorOptions :: [Option] mirrorOptions = fromToOptions ++ [jobsOption] ++ annexedMatchingOptions ++ keyOptions -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do to <- getOptionField toOption Remote.byNameWithUUID from <- getOptionField fromOption Remote.byNameWithUUID diff --git a/Command/Move.hs b/Command/Move.hs index 6867052de..d95bce6ab 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -17,35 +17,47 @@ import Annex.UUID import Annex.Transfer import Logs.Presence -cmd :: [Command] -cmd = [withOptions moveOptions $ command "move" paramPaths seek - SectionCommon "move content of files to/from another repository"] - -moveOptions :: [Option] -moveOptions = fromToOptions ++ [jobsOption] ++ keyOptions ++ annexedMatchingOptions - -seek :: CommandSeek -seek ps = do - to <- getOptionField toOption Remote.byNameWithUUID - from <- getOptionField fromOption Remote.byNameWithUUID - withKeyOptions False - (startKey to from True) - (withFilesInGit $ whenAnnexed $ start to from True) - ps - -start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> Key -> CommandStart -start to from move = start' to from move . Just - -startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart -startKey to from move = start' to from move Nothing - -start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart -start' to from move afile key = do - case (from, to) of - (Nothing, Nothing) -> error "specify either --from or --to" - (Nothing, Just dest) -> toStart dest move afile key - (Just src, Nothing) -> fromStart src move afile key - _ -> error "only one of --from or --to can be specified" +cmd :: Command +cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $ + command "move" SectionCommon + "move content of files to/from another repository" + paramPaths (seek <--< optParser) + +data MoveOptions = MoveOptions + { moveFiles :: CmdParams + , fromToOptions :: FromToOptions + , keyOptions :: Maybe KeyOptions + } + +optParser :: CmdParamsDesc -> Parser MoveOptions +optParser desc = MoveOptions + <$> cmdParams desc + <*> parseFromToOptions + <*> optional (parseKeyOptions False) + +instance DeferredParseClass MoveOptions where + finishParse v = MoveOptions + <$> pure (moveFiles v) + <*> finishParse (fromToOptions v) + <*> pure (keyOptions v) + +seek :: MoveOptions -> CommandSeek +seek o = withKeyOptions (keyOptions o) False + (startKey o True) + (withFilesInGit $ whenAnnexed $ start o True) + (moveFiles o) + +start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart +start o move = start' o move . Just + +startKey :: MoveOptions -> Bool -> Key -> CommandStart +startKey o move = start' o move Nothing + +start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> CommandStart +start' o move afile key = + case fromToOptions o of + FromRemote src -> fromStart move afile key =<< getParsed src + ToRemote dest -> toStart move afile key =<< getParsed dest showMoveAction :: Bool -> Key -> AssociatedFile -> Annex () showMoveAction move = showStart' (if move then "move" else "copy") @@ -59,8 +71,8 @@ showMoveAction move = showStart' (if move then "move" else "copy") - A file's content can be moved even if there are insufficient copies to - allow it to be dropped. -} -toStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart -toStart dest move afile key = do +toStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart +toStart move afile key dest = do u <- getUUID ishere <- inAnnex key if not ishere || u == Remote.uuid dest @@ -122,8 +134,8 @@ toPerform dest move key afile fastcheck isthere = - If the current repository already has the content, it is still removed - from the remote. -} -fromStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart -fromStart src move afile key +fromStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart +fromStart move afile key src | move = go | otherwise = stopUnless (not <$> inAnnex key) go where diff --git a/Command/NotifyChanges.hs b/Command/NotifyChanges.hs index 7ec6072dd..091208349 100644 --- a/Command/NotifyChanges.hs +++ b/Command/NotifyChanges.hs @@ -19,11 +19,13 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM -cmd :: [Command] -cmd = [noCommit $ command "notifychanges" paramNothing seek SectionPlumbing - "sends notification when git refs are changed"] +cmd :: Command +cmd = noCommit $ + command "notifychanges" SectionPlumbing + "sends notification when git refs are changed" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs index 1e710f561..1a3dd3dad 100644 --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -13,11 +13,12 @@ import Command import Annex.NumCopies import Types.Messages -cmd :: [Command] -cmd = [command "numcopies" paramNumber seek - SectionSetup "configure desired number of copies"] +cmd :: Command +cmd = command "numcopies" SectionSetup + "configure desired number of copies" + paramNumber (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index f4dcff269..2d62b51f3 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -28,11 +28,13 @@ import qualified Git.LsFiles as Git import qualified Data.Set as S -cmd :: [Command] -cmd = [command "pre-commit" paramPaths seek SectionPlumbing - "run by git pre-commit hook"] +cmd :: Command +cmd = command "pre-commit" SectionPlumbing + "run by git pre-commit hook" + paramPaths + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = lockPreCommitHook $ ifM isDirect ( do -- update direct mode mappings for committed files diff --git a/Command/Proxy.hs b/Command/Proxy.hs index 8c11bf770..3c487b9b5 100644 --- a/Command/Proxy.hs +++ b/Command/Proxy.hs @@ -17,12 +17,13 @@ import qualified Git.Sha import qualified Git.Ref import qualified Git.Branch -cmd :: [Command] -cmd = [notBareRepo $ - command "proxy" ("-- git command") seek - SectionPlumbing "safely bypass direct mode guard"] +cmd :: Command +cmd = notBareRepo $ + command "proxy" SectionPlumbing + "safely bypass direct mode guard" + ("-- git command") (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 980b27f5a..597be57a5 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -18,12 +18,14 @@ import Logs.Location import Utility.CopyFile import qualified Remote -cmd :: [Command] -cmd = [notDirect $ command "rekey" - (paramOptional $ paramRepeating $ paramPair paramPath paramKey) - seek SectionPlumbing "change keys used for files"] +cmd :: Command +cmd = notDirect $ + command "rekey" SectionPlumbing + "change keys used for files" + (paramRepeating $ paramPair paramPath paramKey) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withPairs start start :: (FilePath, String) -> CommandStart diff --git a/Command/ReadPresentKey.hs b/Command/ReadPresentKey.hs index 8125ddf7e..2b0b51fe3 100644 --- a/Command/ReadPresentKey.hs +++ b/Command/ReadPresentKey.hs @@ -12,11 +12,14 @@ import Command import Logs.Location import Types.Key -cmd :: [Command] -cmd = [noCommit $ command "readpresentkey" (paramPair paramKey paramUUID) seek - SectionPlumbing "read records of where key is present"] +cmd :: Command +cmd = noCommit $ + command "readpresentkey" SectionPlumbing + "read records of where key is present" + (paramPair paramKey paramUUID) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 8572596d2..a49efce2f 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -20,11 +20,12 @@ import qualified Types.Key import qualified Types.Backend import qualified Backend -cmd :: [Command] -cmd = [noCommit $ command "recvkey" paramKey seek - SectionPlumbing "runs rsync in server mode to receive content"] +cmd :: Command +cmd = noCommit $ command "recvkey" SectionPlumbing + "runs rsync in server mode to receive content" + paramKey (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withKeys start start :: Key -> CommandStart diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs index 4282db58a..16489c094 100644 --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -15,12 +15,14 @@ import Logs.Web import Annex.UUID import Command.FromKey (mkKey) -cmd :: [Command] -cmd = [notDirect $ notBareRepo $ - command "registerurl" (paramPair paramKey paramUrl) seek - SectionPlumbing "registers an url for a key"] - -seek :: CommandSeek +cmd :: Command +cmd = notDirect $ notBareRepo $ + command "registerurl" + SectionPlumbing "registers an url for a key" + (paramPair paramKey paramUrl) + (withParams seek) + +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Reinit.hs b/Command/Reinit.hs index f201c66bb..0d144e945 100644 --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -14,11 +14,14 @@ import Annex.UUID import Types.UUID import qualified Remote -cmd :: [Command] -cmd = [dontCheck repoExists $ - command "reinit" (paramUUID ++ "|" ++ paramDesc) seek SectionUtility "initialize repository, reusing old UUID"] +cmd :: Command +cmd = dontCheck repoExists $ + command "reinit" SectionUtility + "initialize repository, reusing old UUID" + (paramUUID ++ "|" ++ paramDesc) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Reinject.hs b/Command/Reinject.hs index de7f6eb3d..76e1420ff 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -14,11 +14,12 @@ import Annex.Content import qualified Command.Fsck import qualified Backend -cmd :: [Command] -cmd = [command "reinject" (paramPair "SRC" "DEST") seek - SectionUtility "sets content of annexed file"] +cmd :: Command +cmd = command "reinject" SectionUtility + "sets content of annexed file" + (paramPair "SRC" "DEST") (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [FilePath] -> CommandStart diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs index 2e3d62555..962189da1 100644 --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -11,11 +11,13 @@ import Common.Annex import Command import RemoteDaemon.Core -cmd :: [Command] -cmd = [noCommit $ command "remotedaemon" paramNothing seek SectionPlumbing - "detects when remotes have changed, and fetches from them"] +cmd :: Command +cmd = noCommit $ + command "remotedaemon" SectionPlumbing + "detects when remotes have changed, and fetches from them" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/Repair.hs b/Command/Repair.hs index d41a074c0..f4c92b02f 100644 --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -16,11 +16,13 @@ import qualified Git.Ref import Git.Types import Annex.Version -cmd :: [Command] -cmd = [noCommit $ dontCheck repoExists $ - command "repair" paramNothing seek SectionMaintenance "recover broken git repository"] +cmd :: Command +cmd = noCommit $ dontCheck repoExists $ + command "repair" SectionMaintenance + "recover broken git repository" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/Required.hs b/Command/Required.hs index 3d9c59279..3cc053b55 100644 --- a/Command/Required.hs +++ b/Command/Required.hs @@ -11,7 +11,7 @@ import Command import Logs.PreferredContent import qualified Command.Wanted -cmd :: [Command] +cmd :: Command cmd = Command.Wanted.cmd' "required" "get or set required content expression" requiredContentMapRaw requiredContentSet diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs index ce199e504..148ce9e5c 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -14,11 +14,12 @@ import Git.Sha import qualified Git.Branch import Annex.AutoMerge -cmd :: [Command] -cmd = [command "resolvemerge" paramNothing seek SectionPlumbing - "resolve merge conflicts"] +cmd :: Command +cmd = command "resolvemerge" SectionPlumbing + "resolve merge conflicts" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs index 5287718c5..d7e99587f 100644 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -13,12 +13,14 @@ import Logs.Web import Annex.UUID import qualified Remote -cmd :: [Command] -cmd = [notBareRepo $ - command "rmurl" (paramPair paramFile paramUrl) seek - SectionCommon "record file is not available at url"] +cmd :: Command +cmd = notBareRepo $ + command "rmurl" SectionCommon + "record file is not available at url" + (paramPair paramFile paramUrl) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withPairs start start :: (FilePath, String) -> CommandStart diff --git a/Command/Schedule.hs b/Command/Schedule.hs index 91ef2c138..266208f9a 100644 --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -17,11 +17,12 @@ import Types.Messages import qualified Data.Set as S -cmd :: [Command] -cmd = [command "schedule" (paramPair paramRemote (paramOptional paramExpression)) seek - SectionSetup "get or set scheduled jobs"] +cmd :: Command +cmd = command "schedule" SectionSetup "get or set scheduled jobs" + (paramPair paramRemote (paramOptional paramExpression)) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Semitrust.hs b/Command/Semitrust.hs index 49004d7f9..d9ee89394 100644 --- a/Command/Semitrust.hs +++ b/Command/Semitrust.hs @@ -11,9 +11,10 @@ import Command import Types.TrustLevel import Command.Trust (trustCommand) -cmd :: [Command] -cmd = [command "semitrust" (paramRepeating paramRemote) seek - SectionSetup "return repository to default trust level"] +cmd :: Command +cmd = command "semitrust" SectionSetup + "return repository to default trust level" + (paramRepeating paramRemote) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = trustCommand "semitrust" SemiTrusted diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 011785582..da7f99889 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -16,11 +16,13 @@ import Annex.Transfer import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered -cmd :: [Command] -cmd = [noCommit $ command "sendkey" paramKey seek - SectionPlumbing "runs rsync in server mode to send content"] +cmd :: Command +cmd = noCommit $ + command "sendkey" SectionPlumbing + "runs rsync in server mode to send content" + paramKey (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withKeys start start :: Key -> CommandStart diff --git a/Command/SetKey.hs b/Command/SetKey.hs index d5762dd8c..d8216a0b4 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -13,11 +13,12 @@ import Logs.Location import Annex.Content import Types.Key -cmd :: [Command] -cmd = [command "setkey" (paramPair paramKey paramPath) seek - SectionPlumbing "sets annexed content for a key"] +cmd :: Command +cmd = command "setkey" SectionPlumbing "sets annexed content for a key" + (paramPair paramKey paramPath) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs index 1c41dc2ae..831a62883 100644 --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -13,11 +13,14 @@ import Logs.Location import Logs.Presence.Pure import Types.Key -cmd :: [Command] -cmd = [noCommit $ command "setpresentkey" (paramPair paramKey (paramPair paramUUID "[1|0]")) seek - SectionPlumbing "change records of where key is present"] +cmd :: Command +cmd = noCommit $ + command "setpresentkey" SectionPlumbing + "change records of where key is present" + (paramPair paramKey (paramPair paramUUID "[1|0]")) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Status.hs b/Command/Status.hs index 26e96a925..c8aeaef0a 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -16,12 +16,13 @@ import qualified Git.LsFiles as LsFiles import qualified Git.Ref import qualified Git -cmd :: [Command] -cmd = [notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $ - command "status" paramPaths seek SectionCommon - "show the working tree status"] +cmd :: Command +cmd = notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $ + command "status" SectionCommon + "show the working tree status" + paramPaths (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [FilePath] -> CommandStart diff --git a/Command/Sync.hs b/Command/Sync.hs index d2c2f95e8..a5b601076 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -51,26 +51,33 @@ import Utility.Bloom import Control.Concurrent.MVar import qualified Data.Map as M -cmd :: [Command] -cmd = [withOptions syncOptions $ - command "sync" (paramOptional (paramRepeating paramRemote)) - seek SectionCommon "synchronize local repository with remotes"] - -syncOptions :: [Option] -syncOptions = - [ contentOption - , messageOption - , allOption - ] - -contentOption :: Option -contentOption = flagOption [] "content" "also transfer file contents" - -messageOption :: Option -messageOption = fieldOption ['m'] "message" "MSG" "specify commit message" - -seek :: CommandSeek -seek rs = do +cmd :: Command +cmd = command "sync" SectionCommon + "synchronize local repository with remotes" + (paramRepeating paramRemote) (seek <$$> optParser) + +data SyncOptions = SyncOptions + { syncWith :: CmdParams + , contentOption :: Bool + , messageOption :: Maybe String + , keyOptions :: Maybe KeyOptions + } + +optParser :: CmdParamsDesc -> Parser SyncOptions +optParser desc = SyncOptions + <$> cmdParams desc + <*> switch + ( long "content" + <> help "also transfer file contents" + ) + <*> optional (strOption + ( long "message" <> short 'm' <> metavar "MSG" + <> help "commit message" + )) + <*> optional parseAllOption + +seek :: SyncOptions -> CommandSeek +seek o = do prepMerge -- There may not be a branch checked out until after the commit, @@ -89,20 +96,20 @@ seek rs = do ) let withbranch a = a =<< getbranch - remotes <- syncRemotes rs + remotes <- syncRemotes (syncWith o) let gitremotes = filter Remote.gitSyncableRemote remotes let dataremotes = filter (not . remoteAnnexIgnore . Remote.gitconfig) remotes -- Syncing involves many actions, any of which can independently -- fail, without preventing the others from running. seekActions $ return $ concat - [ [ commit ] + [ [ commit o ] , [ withbranch mergeLocal ] , map (withbranch . pullRemote) gitremotes , [ mergeAnnex ] ] - whenM (Annex.getFlag $ optionName contentOption) $ - whenM (seekSyncContent dataremotes) $ + when (contentOption o) $ + whenM (seekSyncContent o dataremotes) $ -- Transferring content can take a while, -- and other changes can be pushed to the git-annex -- branch on the remotes in the meantime, so pull @@ -150,15 +157,14 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) fastest = fromMaybe [] . headMaybe . Remote.byCost -commit :: CommandStart -commit = ifM (annexAutoCommit <$> Annex.getGitConfig) +commit :: SyncOptions -> CommandStart +commit o = ifM (annexAutoCommit <$> Annex.getGitConfig) ( go , stop ) where go = next $ next $ do - commitmessage <- maybe commitMsg return - =<< Annex.getField (optionName messageOption) + commitmessage <- maybe commitMsg return (messageOption o) showStart "commit" "" Annex.Branch.commit "update" ifM isDirect @@ -371,14 +377,16 @@ newer remote b = do - - If any file movements were generated, returns true. -} -seekSyncContent :: [Remote] -> Annex Bool -seekSyncContent rs = do +seekSyncContent :: SyncOptions -> [Remote] -> Annex Bool +seekSyncContent o rs = do mvar <- liftIO newEmptyMVar - bloom <- ifM (Annex.getFlag "all") - ( Just <$> genBloomFilter (seekworktree mvar []) - , seekworktree mvar [] (const noop) >> pure Nothing - ) - withKeyOptions' False (seekkeys mvar bloom) (const noop) [] + bloom <- case keyOptions o of + Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar []) + _ -> seekworktree mvar [] (const noop) >> pure Nothing + withKeyOptions' (keyOptions o) False + (seekkeys mvar bloom) + (const noop) + [] liftIO $ not <$> isEmptyMVar mvar where seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>= diff --git a/Command/Test.hs b/Command/Test.hs index 3c4251460..57a9b16d3 100644 --- a/Command/Test.hs +++ b/Command/Test.hs @@ -11,12 +11,15 @@ import Common import Command import Messages -cmd :: [Command] -cmd = [ noRepo startIO $ dontCheck repoExists $ - command "test" paramNothing seek SectionTesting - "run built-in test suite"] +cmd :: Command +cmd = noRepo (parseparams startIO) $ dontCheck repoExists $ + command "test" SectionTesting + "run built-in test suite" + paramNothing (parseparams seek) + where + parseparams = withParams -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start {- We don't actually run the test suite here because of a dependency loop. diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index b0f2c28bb..250c6f41a 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -36,15 +36,16 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as M -cmd :: [Command] -cmd = [ withOptions [sizeOption] $ - command "testremote" paramRemote seek SectionTesting - "test transfers to/from a remote"] +cmd :: Command +cmd = withOptions [sizeOption] $ + command "testremote" SectionTesting + "test transfers to/from a remote" + paramRemote (withParams seek) sizeOption :: Option sizeOption = fieldOption [] "size" paramSize "base key size (default 1MiB)" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do basesz <- fromInteger . fromMaybe (1024 * 1024) <$> getOptionField sizeOption (pure . getsize) diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index f90e2ad73..2b5713d77 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -15,11 +15,13 @@ import Types.Key import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered -cmd :: [Command] -cmd = [noCommit $ command "transferinfo" paramKey seek SectionPlumbing - "updates sender on number of bytes of content received"] +cmd :: Command +cmd = noCommit $ + command "transferinfo" SectionPlumbing + "updates sender on number of bytes of content received" + paramKey (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start {- Security: @@ -47,8 +49,8 @@ start (k:[]) = do , transferUUID = u , transferKey = key } - info <- liftIO $ startTransferInfo file - (update, tfile, _) <- mkProgressUpdater t info + tinfo <- liftIO $ startTransferInfo file + (update, tfile, _) <- mkProgressUpdater t tinfo liftIO $ mapM_ void [ tryIO $ forever $ do bytes <- readUpdate diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 14e788893..04dbc1799 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -15,41 +15,51 @@ import Annex.Transfer import qualified Remote import Types.Remote -cmd :: [Command] -cmd = [withOptions transferKeyOptions $ - noCommit $ command "transferkey" paramKey seek SectionPlumbing - "transfers a key from or to a remote"] - -transferKeyOptions :: [Option] -transferKeyOptions = fileOption : fromToOptions - -fileOption :: Option -fileOption = fieldOption [] "file" paramFile "the associated file" - -seek :: CommandSeek -seek ps = do - to <- getOptionField toOption Remote.byNameWithUUID - from <- getOptionField fromOption Remote.byNameWithUUID - file <- getOptionField fileOption return - withKeys (start to from file) ps - -start :: Maybe Remote -> Maybe Remote -> AssociatedFile -> Key -> CommandStart -start to from file key = - case (from, to) of - (Nothing, Just dest) -> next $ toPerform dest key file - (Just src, Nothing) -> next $ fromPerform src key file - _ -> error "specify either --from or --to" - -toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform -toPerform remote key file = go Upload file $ +cmd :: Command +cmd = noCommit $ + command "transferkey" SectionPlumbing + "transfers a key from or to a remote" + paramKey (seek <--< optParser) + +data TransferKeyOptions = TransferKeyOptions + { keyOptions :: CmdParams + , fromToOptions :: FromToOptions + , fileOption :: AssociatedFile + } + +optParser :: CmdParamsDesc -> Parser TransferKeyOptions +optParser desc = TransferKeyOptions + <$> cmdParams desc + <*> parseFromToOptions + <*> optional (strOption + ( long "file" <> metavar paramFile + <> help "the associated file" + )) + +instance DeferredParseClass TransferKeyOptions where + finishParse v = TransferKeyOptions + <$> pure (keyOptions v) + <*> finishParse (fromToOptions v) + <*> pure (fileOption v) + +seek :: TransferKeyOptions -> CommandSeek +seek o = withKeys (start o) (keyOptions o) + +start :: TransferKeyOptions -> Key -> CommandStart +start o key = case fromToOptions o of + ToRemote dest -> next $ toPerform key (fileOption o) =<< getParsed dest + FromRemote src -> next $ fromPerform key (fileOption o) =<< getParsed src + +toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform +toPerform key file remote = go Upload file $ upload (uuid remote) key file forwardRetry noObserver $ \p -> do ok <- Remote.storeKey remote key file p when ok $ Remote.logStatus remote key InfoPresent return ok -fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform -fromPerform remote key file = go Upload file $ +fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform +fromPerform key file remote = go Upload file $ download (uuid remote) key file forwardRetry noObserver $ \p -> getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index d490d9be4..67f201024 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -21,11 +21,11 @@ import Git.Types (RemoteName) data TransferRequest = TransferRequest Direction Remote Key AssociatedFile -cmd :: [Command] -cmd = [command "transferkeys" paramNothing seek - SectionPlumbing "transfers keys"] +cmd :: Command +cmd = command "transferkeys" SectionPlumbing "transfers keys" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart @@ -45,7 +45,7 @@ start = do download (Remote.uuid remote) key file forwardRetry observer $ \p -> getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p - observer False t info = recordFailedTransfer t info + observer False t tinfo = recordFailedTransfer t tinfo observer True _ _ = noop runRequests @@ -80,14 +80,14 @@ runRequests readh writeh a = do hFlush writeh sendRequest :: Transfer -> TransferInfo -> Handle -> IO () -sendRequest t info h = do +sendRequest t tinfo h = do hPutStr h $ intercalate fieldSep [ serialize (transferDirection t) , maybe (serialize (fromUUID (transferUUID t))) (serialize . Remote.name) - (transferRemote info) + (transferRemote tinfo) , serialize (transferKey t) - , serialize (associatedFile info) + , serialize (associatedFile tinfo) , "" -- adds a trailing null ] hFlush h diff --git a/Command/Trust.hs b/Command/Trust.hs index 9d380990e..33ecc2e64 100644 --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -16,14 +16,14 @@ import Logs.Group import qualified Data.Set as S -cmd :: [Command] -cmd = [command "trust" (paramRepeating paramRemote) seek - SectionSetup "trust a repository"] +cmd :: Command +cmd = command "trust" SectionSetup "trust a repository" + (paramRepeating paramRemote) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = trustCommand "trust" Trusted -trustCommand :: String -> TrustLevel -> CommandSeek +trustCommand :: String -> TrustLevel -> CmdParams -> CommandSeek trustCommand c level = withWords start where start ws = do diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 0d88148c8..fdf976d3e 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -22,12 +22,13 @@ import qualified Git.DiffTree as DiffTree import Utility.CopyFile import Command.PreCommit (lockPreCommitHook) -cmd :: [Command] -cmd = [withOptions annexedMatchingOptions $ - command "unannex" paramPaths seek SectionUtility - "undo accidential add command"] +cmd :: Command +cmd = withGlobalOptions annexedMatchingOptions $ + command "unannex" SectionUtility + "undo accidential add command" + paramPaths (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = wrapUnannex . (withFilesInGit $ whenAnnexed start) wrapUnannex :: Annex a -> Annex a diff --git a/Command/Undo.hs b/Command/Undo.hs index 8e6b1c44f..c647dfba4 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -21,12 +21,13 @@ import qualified Git.Command as Git import qualified Git.Branch import qualified Command.Sync -cmd :: [Command] -cmd = [notBareRepo $ - command "undo" paramPaths seek - SectionCommon "undo last change to a file or directory"] +cmd :: Command +cmd = notBareRepo $ + command "undo" SectionCommon + "undo last change to a file or directory" + paramPaths (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do -- Safety first; avoid any undo that would touch files that are not -- in the index. diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs index dd6e8c952..cd2ebdf9b 100644 --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -15,11 +15,11 @@ import Types.Group import qualified Data.Set as S -cmd :: [Command] -cmd = [command "ungroup" (paramPair paramRemote paramDesc) seek - SectionSetup "remove a repository from a group"] +cmd :: Command +cmd = command "ungroup" SectionSetup "remove a repository from a group" + (paramPair paramRemote paramDesc) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 4a918070c..c49cc4ba0 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -21,9 +21,11 @@ import Utility.FileMode import System.IO.HVFS import System.IO.HVFS.Utils -cmd :: [Command] -cmd = [addCheck check $ command "uninit" paramPaths seek - SectionUtility "de-initialize git-annex and clean out repository"] +cmd :: Command +cmd = addCheck check $ + command "uninit" SectionUtility + "de-initialize git-annex and clean out repository" + paramPaths (withParams seek) check :: Annex () check = do @@ -39,7 +41,7 @@ check = do revhead = inRepo $ Git.Command.pipeReadStrict [Param "rev-parse", Param "--abbrev-ref", Param "HEAD"] -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do withFilesNotInGit False (whenAnnexed startCheckIncomplete) ps Annex.changeState $ \s -> s { Annex.fast = True } diff --git a/Command/Unlock.hs b/Command/Unlock.hs index a1b1ce411..d1b1d0e90 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -13,16 +13,17 @@ import Annex.Content import Annex.CatFile import Utility.CopyFile -cmd :: [Command] -cmd = - [ c "unlock" "unlock files for modification" - , c "edit" "same as unlock" - ] - where - c n = notDirect . withOptions annexedMatchingOptions - . command n paramPaths seek SectionCommon +cmd :: Command +cmd = mkcmd "unlock" "unlock files for modification" -seek :: CommandSeek +editcmd :: Command +editcmd = mkcmd "edit" "same as unlock" + +mkcmd :: String -> String -> Command +mkcmd n d = notDirect $ withGlobalOptions annexedMatchingOptions $ + command n SectionCommon d paramPaths (withParams seek) + +seek :: CmdParams -> CommandSeek seek = withFilesInGit $ whenAnnexed start {- The unlock subcommand replaces the symlink with a copy of the file's diff --git a/Command/Untrust.hs b/Command/Untrust.hs index 92e28b637..7f22a8086 100644 --- a/Command/Untrust.hs +++ b/Command/Untrust.hs @@ -11,9 +11,9 @@ import Command import Types.TrustLevel import Command.Trust (trustCommand) -cmd :: [Command] -cmd = [command "untrust" (paramRepeating paramRemote) seek - SectionSetup "do not trust a repository"] +cmd :: Command +cmd = command "untrust" SectionSetup "do not trust a repository" + (paramRepeating paramRemote) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = trustCommand "untrust" UnTrusted diff --git a/Command/Unused.hs b/Command/Unused.hs index 77a9a92c3..a383d567b 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2015 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -31,38 +31,47 @@ import Annex.CatFile import Types.Key import Types.RefSpec import Git.FilePath +import Git.Types import Logs.View (is_branchView) import Annex.BloomFilter -cmd :: [Command] -cmd = [withOptions [unusedFromOption, refSpecOption] $ - command "unused" paramNothing seek - SectionMaintenance "look for unused file content"] +cmd :: Command +cmd = -- withGlobalOptions [unusedFromOption, refSpecOption] $ + command "unused" SectionMaintenance + "look for unused file content" + paramNothing (seek <$$> optParser) -unusedFromOption :: Option -unusedFromOption = fieldOption ['f'] "from" paramRemote "remote to check for unused content" +data UnusedOptions = UnusedOptions + { fromRemote :: Maybe RemoteName + , refSpecOption :: Maybe RefSpec + } -refSpecOption :: Option -refSpecOption = fieldOption [] "used-refspec" paramRefSpec "refs to consider used (default: all refs)" +optParser :: CmdParamsDesc -> Parser UnusedOptions +optParser _ = UnusedOptions + <$> optional (strOption + ( long "from" <> short 'f' <> metavar paramRemote + <> help "remote to check for unused content" + )) + <*> optional (option (eitherReader parseRefSpec) + ( long "unused-refspec" <> metavar paramRefSpec + <> help "refs to consider used (default: all branches)" + )) -seek :: CommandSeek -seek = withNothing start +seek :: UnusedOptions -> CommandSeek +seek = commandAction . start -{- Finds unused content in the annex. -} -start :: CommandStart -start = do +start :: UnusedOptions -> CommandStart +start o = do cfgrefspec <- fromMaybe allRefSpec . annexUsedRefSpec <$> Annex.getGitConfig - !refspec <- maybe cfgrefspec (either error id . parseRefSpec) - <$> Annex.getField (optionName refSpecOption) - from <- Annex.getField (optionName unusedFromOption) - let (name, action) = case from of + let refspec = fromMaybe cfgrefspec (refSpecOption o) + let (name, perform) = case fromRemote o of Nothing -> (".", checkUnused refspec) Just "." -> (".", checkUnused refspec) Just "here" -> (".", checkUnused refspec) Just n -> (n, checkRemoteUnused n refspec) showStart "unused" name - next action + next perform checkUnused :: RefSpec -> CommandPerform checkUnused refspec = chain 0 @@ -126,11 +135,11 @@ unusedMsg u = unusedMsg' u ["Some annexed data is no longer used by any files:"] [dropMsg Nothing] unusedMsg' :: [(Int, Key)] -> [String] -> [String] -> String -unusedMsg' u header trailer = unlines $ - header ++ +unusedMsg' u mheader mtrailer = unlines $ + mheader ++ table u ++ ["(To see where data was previously used, try: git log --stat -S'KEY')"] ++ - trailer + mtrailer remoteUnusedMsg :: Remote -> [(Int, Key)] -> String remoteUnusedMsg r u = unusedMsg' u @@ -267,7 +276,7 @@ data UnusedMaps = UnusedMaps , unusedTmpMap :: UnusedMap } -withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CommandSeek +withUnusedMaps :: (UnusedMaps -> Int -> CommandStart) -> CmdParams -> CommandSeek withUnusedMaps a params = do unused <- readUnusedMap "" unusedbad <- readUnusedMap "bad" diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs index 081d7ff35..c02a6709f 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -11,12 +11,12 @@ import Common.Annex import Command import Upgrade -cmd :: [Command] -cmd = [dontCheck repoExists $ -- because an old version may not seem to exist - command "upgrade" paramNothing seek - SectionMaintenance "upgrade repository layout"] +cmd :: Command +cmd = dontCheck repoExists $ -- because an old version may not seem to exist + command "upgrade" SectionMaintenance "upgrade repository layout" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/VAdd.hs b/Command/VAdd.hs index ea98e6639..ac70da264 100644 --- a/Command/VAdd.hs +++ b/Command/VAdd.hs @@ -12,11 +12,14 @@ import Command import Annex.View import Command.View (checkoutViewBranch) -cmd :: [Command] -cmd = [notBareRepo $ notDirect $ command "vadd" (paramRepeating "FIELD=GLOB") - seek SectionMetaData "add subdirs to current view"] +cmd :: Command +cmd = notBareRepo $ notDirect $ + command "vadd" SectionMetaData + "add subdirs to current view" + (paramRepeating "FIELD=GLOB") + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/VCycle.hs b/Command/VCycle.hs index bf253adc1..a3c61d859 100644 --- a/Command/VCycle.hs +++ b/Command/VCycle.hs @@ -14,12 +14,13 @@ import Types.View import Logs.View import Command.View (checkoutViewBranch) -cmd :: [Command] -cmd = [notBareRepo $ notDirect $ - command "vcycle" paramNothing seek SectionMetaData - "switch view to next layout"] +cmd :: Command +cmd = notBareRepo $ notDirect $ + command "vcycle" SectionMetaData + "switch view to next layout" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start ::CommandStart diff --git a/Command/VFilter.hs b/Command/VFilter.hs index fd5ec9630..259d36068 100644 --- a/Command/VFilter.hs +++ b/Command/VFilter.hs @@ -12,11 +12,12 @@ import Command import Annex.View import Command.View (paramView, checkoutViewBranch) -cmd :: [Command] -cmd = [notBareRepo $ notDirect $ - command "vfilter" paramView seek SectionMetaData "filter current view"] +cmd :: Command +cmd = notBareRepo $ notDirect $ + command "vfilter" SectionMetaData "filter current view" + paramView (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/VPop.hs b/Command/VPop.hs index 1fb1d7a56..ba6f4ee5c 100644 --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -16,12 +16,12 @@ import Types.View import Logs.View import Command.View (checkoutViewBranch) -cmd :: [Command] -cmd = [notBareRepo $ notDirect $ - command "vpop" (paramOptional paramNumber) seek SectionMetaData - "switch back to previous view"] +cmd :: Command +cmd = notBareRepo $ notDirect $ + command "vpop" SectionMetaData "switch back to previous view" + paramNumber (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Version.hs b/Command/Version.hs index 1b96de9d2..72bbe4064 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -17,45 +17,54 @@ import qualified Types.Remote as R import qualified Remote import qualified Backend -cmd :: [Command] -cmd = [withOptions [rawOption] $ - noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "version" paramNothing seek SectionQuery "show version info"] +cmd :: Command +cmd = dontCheck repoExists $ noCommit $ + noRepo (seekNoRepo <$$> optParser) $ + command "version" SectionQuery "show version info" + paramNothing (seek <$$> optParser) -rawOption :: Option -rawOption = flagOption [] "raw" "output only program version" +data VersionOptions = VersionOptions + { rawOption :: Bool + } -seek :: CommandSeek -seek = withNothing $ ifM (getOptionFlag rawOption) (startRaw, start) +optParser :: CmdParamsDesc -> Parser VersionOptions +optParser _ = VersionOptions + <$> switch + ( long "raw" + <> help "output only program version" + ) -startRaw :: CommandStart -startRaw = do - liftIO $ do - putStr SysConfig.packageversion - hFlush stdout - stop +seek :: VersionOptions -> CommandSeek +seek o + | rawOption o = liftIO showRawVersion + | otherwise = showVersion + +seekNoRepo :: VersionOptions -> IO () +seekNoRepo o + | rawOption o = showRawVersion + | otherwise = showPackageVersion -start :: CommandStart -start = do +showVersion :: Annex () +showVersion = do v <- getVersion liftIO $ do - showPackageVersion - info "local repository version" $ fromMaybe "unknown" v - info "supported repository version" supportedVersion - info "upgrade supported from repository versions" $ + vinfo "local repository version" $ fromMaybe "unknown" v + vinfo "supported repository version" supportedVersion + vinfo "upgrade supported from repository versions" $ unwords upgradableVersions - stop - -startNoRepo :: CmdParams -> IO () -startNoRepo _ = showPackageVersion showPackageVersion :: IO () showPackageVersion = do - info "git-annex version" SysConfig.packageversion - info "build flags" $ unwords buildFlags - info "key/value backends" $ unwords $ map B.name Backend.list - info "remote types" $ unwords $ map R.typename Remote.remoteTypes + vinfo "git-annex version" SysConfig.packageversion + vinfo "build flags" $ unwords buildFlags + vinfo "key/value backends" $ unwords $ map B.name Backend.list + vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes + +showRawVersion :: IO () +showRawVersion = do + putStr SysConfig.packageversion + hFlush stdout -- no newline, so flush -info :: String -> String -> IO () -info k v = putStrLn $ k ++ ": " ++ v +vinfo :: String -> String -> IO () +vinfo k v = putStrLn $ k ++ ": " ++ v diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index f1a64ba23..677ba5b13 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -29,11 +29,11 @@ import Types.StandardGroups import Types.ScheduledActivity import Remote -cmd :: [Command] -cmd = [command "vicfg" paramNothing seek - SectionSetup "edit git-annex's configuration"] +cmd :: Command +cmd = command "vicfg" SectionSetup "edit git-annex's configuration" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/View.hs b/Command/View.hs index ae2878396..b39aef7d9 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -17,18 +17,19 @@ import Types.View import Annex.View import Logs.View -cmd :: [Command] -cmd = [notBareRepo $ notDirect $ - command "view" paramView seek SectionMetaData "enter a view branch"] +cmd :: Command +cmd = notBareRepo $ notDirect $ + command "view" SectionMetaData "enter a view branch" + paramView (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart start [] = error "Specify metadata to include in view" -start params = do +start ps = do showStart "view" "" - view <- mkView params + view <- mkView ps go view =<< currentView where go view Nothing = next $ perform view @@ -45,11 +46,11 @@ paramView :: String paramView = paramRepeating "FIELD=VALUE" mkView :: [String] -> Annex View -mkView params = go =<< inRepo Git.Branch.current +mkView ps = go =<< inRepo Git.Branch.current where go Nothing = error "not on any branch!" go (Just b) = return $ fst $ refineView (View b []) $ - map parseViewParam $ reverse params + map parseViewParam $ reverse ps checkoutViewBranch :: View -> (View -> Annex Git.Branch) -> CommandCleanup checkoutViewBranch view mkbranch = do diff --git a/Command/Wanted.hs b/Command/Wanted.hs index 07f5ee7c3..649f19c2b 100644 --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -17,7 +17,7 @@ import Types.StandardGroups import qualified Data.Map as M -cmd :: [Command] +cmd :: Command cmd = cmd' "wanted" "get or set preferred content expression" preferredContentMapRaw preferredContentSet @@ -27,8 +27,8 @@ cmd' -> String -> Annex (M.Map UUID PreferredContentExpression) -> (UUID -> PreferredContentExpression -> Annex ()) - -> [Command] -cmd' name desc getter setter = [command name pdesc seek SectionSetup desc] + -> Command +cmd' name desc getter setter = command name SectionSetup desc pdesc (withParams seek) where pdesc = paramPair paramRemote (paramOptional paramExpression) diff --git a/Command/Watch.hs b/Command/Watch.hs index cf86a5832..cc7356ddf 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -12,11 +12,13 @@ import Assistant import Command import Utility.HumanTime -cmd :: [Command] -cmd = [notBareRepo $ withOptions [foregroundOption, stopOption] $ - command "watch" paramNothing seek SectionCommon "watch for changes and autocommit"] +cmd :: Command +cmd = notBareRepo $ withOptions [foregroundOption, stopOption] $ + command "watch" SectionCommon + "watch for changes and autocommit" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do stopdaemon <- getOptionFlag stopOption foreground <- getOptionFlag foregroundOption diff --git a/Command/WebApp.hs b/Command/WebApp.hs index e872d4be0..2e41ebe7d 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -37,16 +37,18 @@ import Control.Concurrent.STM import Network.Socket (HostName) import System.Environment (getArgs) -cmd :: [Command] -cmd = [ withOptions [listenOption] $ - noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $ - command "webapp" paramNothing seek SectionCommon "launch webapp"] +cmd :: Command +cmd = withOptions [listenOption] $ + noCommit $ dontCheck repoExists $ notBareRepo $ + noRepo (withParams startNoRepo) $ + command "webapp" SectionCommon "launch webapp" + paramNothing (withParams seek) listenOption :: Option listenOption = fieldOption [] "listen" paramAddress "accept connections to this address" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do listenhost <- getOptionField listenOption return withNothing (start listenhost) ps diff --git a/Command/Whereis.hs b/Command/Whereis.hs index cfcc8f224..3610eed78 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -15,18 +15,29 @@ import Remote import Logs.Trust import Logs.Web -cmd :: [Command] -cmd = [noCommit $ withOptions (jsonOption : annexedMatchingOptions ++ keyOptions) $ - command "whereis" paramPaths seek SectionQuery - "lists repositories that have file content"] +cmd :: Command +cmd = noCommit $ withGlobalOptions (jsonOption : annexedMatchingOptions) $ + command "whereis" SectionQuery + "lists repositories that have file content" + paramPaths (seek <$$> optParser) -seek :: CommandSeek -seek ps = do +data WhereisOptions = WhereisOptions + { whereisFiles :: CmdParams + , keyOptions :: Maybe KeyOptions + } + +optParser :: CmdParamsDesc -> Parser WhereisOptions +optParser desc = WhereisOptions + <$> cmdParams desc + <*> optional (parseKeyOptions False) + +seek :: WhereisOptions -> CommandSeek +seek o = do m <- remoteMap id - withKeyOptions False + withKeyOptions (keyOptions o) False (startKeys m) (withFilesInGit $ whenAnnexed $ start m) - ps + (whereisFiles o) start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart start remotemap file key = start' remotemap key (Just file) diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs index 2bcb7405e..86d8dbc11 100644 --- a/Command/XMPPGit.hs +++ b/Command/XMPPGit.hs @@ -11,12 +11,15 @@ import Common.Annex import Command import Assistant.XMPP.Git -cmd :: [Command] -cmd = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "xmppgit" paramNothing seek - SectionPlumbing "git to XMPP relay"] +cmd :: Command +cmd = noCommit $ dontCheck repoExists $ + noRepo (parseparams startNoRepo) $ + command "xmppgit" SectionPlumbing "git to XMPP relay" + paramNothing (parseparams seek) + where + parseparams = withParams -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Types/Command.hs b/Types/Command.hs index de6e78038..e12873850 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -1,6 +1,6 @@ {- git-annex command data types - - - Copyright 2010-2011 Joey Hess <id@joeyh.name> + - Copyright 2010-2015 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -8,47 +8,53 @@ module Types.Command where import Data.Ord +import Options.Applicative.Types (Parser) import Types {- A command runs in these stages. - - - a. The check stage runs checks, that error out if + - a. The parser stage parses the command line and generates a CommandSeek + - action. -} +type CommandParser = Parser CommandSeek +{- b. The check stage runs checks, that error out if - anything prevents the command from running. -} data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () } -{- b. The seek stage takes the parameters passed to the command, - - looks through the repo to find the ones that are relevant - - to that command (ie, new files to add), and runs commandAction - - to handle all necessary actions. -} -type CommandSeek = [String] -> Annex () -{- c. The start stage is run before anything is printed about the +{- c. The seek stage is passed input from the parser, looks through + - the repo to find things to act on (ie, new files to add), and + - runs commandAction to handle all necessary actions. -} +type CommandSeek = Annex () +{- d. The start stage is run before anything is printed about the - command, is passed some input, and can early abort it - if the input does not make sense. It should run quickly and - should not modify Annex state. -} type CommandStart = Annex (Maybe CommandPerform) -{- d. The perform stage is run after a message is printed about the command +{- e. The perform stage is run after a message is printed about the command - being run, and it should be where the bulk of the work happens. -} type CommandPerform = Annex (Maybe CommandCleanup) -{- e. The cleanup stage is run only if the perform stage succeeds, and it +{- f. The cleanup stage is run only if the perform stage succeeds, and it - returns the overall success/fail of the command. -} type CommandCleanup = Annex Bool {- A command is defined by specifying these things. -} data Command = Command - { cmdoptions :: [Option] -- command-specific options - , cmdnorepo :: Maybe (CmdParams -> IO ()) -- an action to run when not in a repo - , cmdcheck :: [CommandCheck] -- check stage + { cmdcheck :: [CommandCheck] -- check stage , cmdnocommit :: Bool -- don't commit journalled state changes , cmdnomessages :: Bool -- don't output normal messages , cmdname :: String - , cmdparamdesc :: String -- description of params for usage - , cmdseek :: CommandSeek + , cmdparamdesc :: CmdParamsDesc -- description of params for usage , cmdsection :: CommandSection , cmddesc :: String -- description of command for usage + , cmdparser :: CommandParser -- command line parser + , cmdnorepo :: Maybe (Parser (IO ())) -- used when not in a repo } +{- Command-line parameters, after the command is selected and options + - are parsed. -} type CmdParams = [String] +type CmdParamsDesc = String + {- CommandCheck functions can be compared using their unique id. -} instance Eq CommandCheck where a == b = idCheck a == idCheck b diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs new file mode 100644 index 000000000..983ba3f5c --- /dev/null +++ b/Types/DeferredParse.hs @@ -0,0 +1,42 @@ +{- git-annex deferred parse values + - + - Copyright 2015 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE FlexibleInstances #-} + +module Types.DeferredParse where + +import Annex +import Common + +import Options.Applicative + +-- Some values cannot be fully parsed without performing an action. +-- The action may be expensive, so it's best to call finishParse on such a +-- value before using getParsed repeatedly. +data DeferredParse a = DeferredParse (Annex a) | ReadyParse a + +class DeferredParseClass a where + finishParse :: a -> Annex a + +getParsed :: DeferredParse a -> Annex a +getParsed (DeferredParse a) = a +getParsed (ReadyParse a) = pure a + +instance DeferredParseClass (DeferredParse a) where + finishParse (DeferredParse a) = ReadyParse <$> a + finishParse (ReadyParse a) = pure (ReadyParse a) + +instance DeferredParseClass (Maybe (DeferredParse a)) where + finishParse Nothing = pure Nothing + finishParse (Just v) = Just <$> finishParse v + +instance DeferredParseClass [DeferredParse a] where + finishParse v = mapM finishParse v + +-- Use when the Annex action modifies Annex state. +type GlobalSetter = DeferredParse () +type GlobalOption = Parser GlobalSetter diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index e8fdb7c6e..fe7cf22a9 100644 --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -17,7 +17,6 @@ module Utility.HumanTime ( ) where import Utility.PartialPrelude -import Utility.Applicative import Utility.QuickCheck import qualified Data.Map as M @@ -45,8 +44,8 @@ daysToDuration :: Integer -> Duration daysToDuration i = Duration $ i * dsecs {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} -parseDuration :: String -> Maybe Duration -parseDuration = Duration <$$> go 0 +parseDuration :: Monad m => String -> m Duration +parseDuration = maybe parsefail (return . Duration) . go 0 where go n [] = return n go n s = do @@ -56,6 +55,7 @@ parseDuration = Duration <$$> go 0 u <- M.lookup c unitmap go (n + num * u) rest _ -> return $ n + num + parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\"" fromDuration :: Duration -> String fromDuration Duration { durationSeconds = d } diff --git a/debian/changelog b/debian/changelog index 586128bf3..118ff330c 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ + * Switched option parsing to use optparse-applicative. This was a very large + and invasive change, and may have caused some minor behavior changes to + edge cases of option parsing. + * Bash completion code is built-in to git-annex, and can be enabled by + running: source <(git-annex --bash-completion-script git-annex) + * version --raw now works when run outside a git repository. + git-annex (5.20150710) unstable; urgency=medium * add: Stage symlinks the same as git add would, even if they are not a diff --git a/doc/git-annex-drop.mdwn b/doc/git-annex-drop.mdwn index 813cce6aa..a3a79f8d7 100644 --- a/doc/git-annex-drop.mdwn +++ b/doc/git-annex-drop.mdwn @@ -1,6 +1,6 @@ # NAME -git-annex drop - indicate content of files not currently wanted +git-annex drop - remove content of files from repository # SYNOPSIS diff --git a/doc/git-annex-fsck.mdwn b/doc/git-annex-fsck.mdwn index 1b1c0121b..73c401eb3 100644 --- a/doc/git-annex-fsck.mdwn +++ b/doc/git-annex-fsck.mdwn @@ -1,6 +1,6 @@ # NAME -git-annex fsck - check for problems +git-annex fsck - find and fix problems # SYNOPSIS diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 73894c0d8..e3790bdf9 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -763,6 +763,18 @@ may not be explicitly listed on their individual man pages. Overrides git configuration settings. May be specified multiple times. +# COMMAND-LINE TAB COMPLETION + +To enable bash completion, paste this into your shell prompt: + + source <(git-annex --bash-completion-script git-annex) + +The output of "git-annex --bash-completion-script git-annex" can also +be written to a bash completion file so bach loads it automatically. + +This bash completion is generated by the option parser, so it covers all +commands, all options, and will never go out of date! + # CONFIGURATION VIA .git/config Like other git commands, git-annex is configured via `.git/config`. diff --git a/git-annex.cabal b/git-annex.cabal index d999e60d3..905b945ae 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -113,6 +113,7 @@ Executable git-annex Main-Is: git-annex.hs Build-Depends: base (>= 4.5 && < 4.9), + optparse-applicative (>= 0.10), cryptohash (>= 0.11.0), containers (>= 0.5.0.0), exceptions (>= 0.6), @@ -164,7 +165,7 @@ Executable git-annex if flag(TestSuite) Build-Depends: tasty (>= 0.7), tasty-hunit, tasty-quickcheck, tasty-rerun, - optparse-applicative (>= 0.10), crypto-api + crypto-api CPP-Options: -DWITH_TESTSUITE if flag(TDFA) |