From a2ba70105683f4938b5b80b82f580e8c72b52c01 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 12:33:27 -0400 Subject: [PATCH 01/54] started converting to use optparse-applicative This is a work in progress. It compiles and is able to do basic command dispatch, including git autocorrection, while using optparse-applicative for the core commandline parsing. * Many commands are temporarily disabled before conversion. * Options are not wired in yet. * cmdnorepo actions don't work yet. Also, removed the [Command] list, which was only used in one place. --- CmdLine.hs | 66 ++++++++++++++++++++++++++++---------- CmdLine/Action.hs | 6 ++-- CmdLine/GitAnnex.hs | 7 +++- CmdLine/GitAnnexShell.hs | 17 ++++------ CmdLine/Seek.hs | 34 ++++++++++---------- Command.hs | 12 +++++-- Command/Add.hs | 9 +++--- Command/AddUnused.hs | 6 ++-- Command/AddUrl.hs | 6 ++-- Command/Assistant.hs | 6 ++-- Command/CheckPresentKey.hs | 6 ++-- Command/Commit.hs | 9 +++--- Command/ConfigList.hs | 9 +++--- Command/ContentLocation.hs | 6 ++-- Command/Copy.hs | 6 ++-- Command/Dead.hs | 6 ++-- Command/Describe.hs | 6 ++-- Command/DiffDriver.hs | 6 ++-- Command/Direct.hs | 6 ++-- Command/Drop.hs | 6 ++-- Command/DropKey.hs | 9 +++--- Command/DropUnused.hs | 6 ++-- Command/EnableRemote.hs | 6 ++-- Command/ExamineKey.hs | 6 ++-- Command/Expire.hs | 6 ++-- Command/Find.hs | 6 ++-- Command/FindRef.hs | 6 ++-- Command/Fix.hs | 11 ++++--- Command/Forget.hs | 6 ++-- Command/FromKey.hs | 6 ++-- Command/Fsck.hs | 6 ++-- Command/FuzzTest.hs | 6 ++-- Command/GCryptSetup.hs | 11 ++++--- Command/Get.hs | 6 ++-- Command/Group.hs | 6 ++-- Command/GroupWanted.hs | 6 ++-- Command/Help.hs | 6 ++-- Command/Import.hs | 6 ++-- Command/ImportFeed.hs | 6 ++-- Command/InAnnex.hs | 9 +++--- Command/Indirect.hs | 6 ++-- Command/Info.hs | 6 ++-- Command/Init.hs | 6 ++-- Command/InitRemote.hs | 6 ++-- Command/List.hs | 6 ++-- Command/Lock.hs | 6 ++-- Command/Log.hs | 6 ++-- Command/LookupKey.hs | 6 ++-- Command/Map.hs | 6 ++-- Command/Merge.hs | 6 ++-- Command/MetaData.hs | 6 ++-- Command/Migrate.hs | 6 ++-- Command/Mirror.hs | 6 ++-- Command/Move.hs | 6 ++-- Command/NotifyChanges.hs | 9 +++--- Command/NumCopies.hs | 6 ++-- Command/PreCommit.hs | 9 +++--- Command/Proxy.hs | 6 ++-- Command/ReKey.hs | 6 ++-- Command/ReadPresentKey.hs | 6 ++-- Command/RecvKey.hs | 9 +++--- Command/RegisterUrl.hs | 6 ++-- Command/Reinit.hs | 5 +-- Command/Reinject.hs | 4 +-- Command/RemoteDaemon.hs | 6 ++-- Command/Repair.hs | 6 ++-- Command/Required.hs | 2 +- Command/ResolveMerge.hs | 6 ++-- Command/RmUrl.hs | 6 ++-- Command/Schedule.hs | 6 ++-- Command/Semitrust.hs | 6 ++-- Command/SendKey.hs | 9 +++--- Command/SetKey.hs | 6 ++-- Command/SetPresentKey.hs | 6 ++-- Command/Status.hs | 6 ++-- Command/Sync.hs | 6 ++-- Command/Test.hs | 6 ++-- Command/TestRemote.hs | 6 ++-- Command/TransferInfo.hs | 9 +++--- Command/TransferKey.hs | 6 ++-- Command/TransferKeys.hs | 6 ++-- Command/Trust.hs | 6 ++-- Command/Unannex.hs | 11 ++++--- Command/Undo.hs | 6 ++-- Command/Ungroup.hs | 6 ++-- Command/Uninit.hs | 9 +++--- Command/Unlock.hs | 17 +++++----- Command/Untrust.hs | 6 ++-- Command/Unused.hs | 11 ++++--- Command/Upgrade.hs | 6 ++-- Command/VAdd.hs | 6 ++-- Command/VCycle.hs | 6 ++-- Command/VFilter.hs | 6 ++-- Command/VPop.hs | 6 ++-- Command/Version.hs | 6 ++-- Command/Vicfg.hs | 6 ++-- Command/View.hs | 6 ++-- Command/Wanted.hs | 6 ++-- Command/Watch.hs | 6 ++-- Command/WebApp.hs | 6 ++-- Command/Whereis.hs | 6 ++-- Command/XMPPGit.hs | 6 ++-- Types/Command.hs | 27 +++++++++------- git-annex.cabal | 3 +- 104 files changed, 435 insertions(+), 370 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index cd7a1a9862..2b9418d83f 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -1,6 +1,6 @@ {- git-annex command line parsing and dispatch - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,7 +16,7 @@ module CmdLine ( import qualified Control.Exception as E import qualified Data.Map as M import Control.Exception (throw) -import System.Console.GetOpt +import qualified Options.Applicative as O #ifndef mingw32_HOST_OS import System.Posix.Signals #endif @@ -35,6 +35,41 @@ import Types.Messages dispatch :: Bool -> CmdParams -> [Command] -> [Option] -> [(String, String)] -> String -> IO Git.Repo -> IO () dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do setupConsole + go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) + where + 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) <- liftIO $ + O.handleParseResult (parseCmd (name:args) allcmds) + when (cmdnomessages cmd) $ + Annex.setOutput QuietOutput + -- TODO: propigate global options to annex state (how?) + whenM (annexDebug <$> Annex.getGitConfig) $ + liftIO enableDebugOutput + startup + performCommandAction cmd seek $ + shutdown $ cmdnocommit cmd + go (Left e) = do + when fuzzy $ + autocorrect =<< Git.Config.global + -- a <- O.handleParseResult (parseCmd (name:args) allcmds) + error "TODO" + + autocorrect = Git.AutoCorrect.prepare inputcmdname cmdname cmds + err msg = msg ++ "\n\n" ++ usage header allcmds + (fuzzy, cmds, inputcmdname, args) = findCmd fuzzyok allargs allcmds err + name + | fuzzy = case cmds of + [c] -> cmdname c + _ -> inputcmdname + | otherwise = inputcmdname + +#if 0 case getOptCmd args cmd commonoptions of Right (flags, params) -> go flags params =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) @@ -59,10 +94,19 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = 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 +#endif + +{- Parses command line and selects a command to run and gets the + - seek action for the command. -} +parseCmd :: CmdParams -> [Command] -> O.ParserResult (Command, CommandSeek) +parseCmd allargs allcmds = O.execParserPure (O.prefs O.idm) pinfo allargs + where + pinfo = O.info (O.subparser $ mconcat $ map mkcommand allcmds) O.idm + mkcommand c = O.command (cmdname c) (O.info (mkparser c) O.idm) + mkparser c = (,) + <$> pure c + <*> cmdparser c {- Parses command line params far enough to find the Command to run, and - returns the remaining params. @@ -84,18 +128,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 2838e4ff88..15064fe426 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/GitAnnex.hs b/CmdLine/GitAnnex.hs index 354f451e75..5619129f50 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -16,6 +16,7 @@ import Utility.Env import Annex.Ssh import qualified Command.Add +{- import qualified Command.Unannex import qualified Command.Drop import qualified Command.Move @@ -116,15 +117,18 @@ import qualified Command.TestRemote #ifdef WITH_EKG import System.Remote.Monitoring #endif +-} cmds :: [Command] -cmds = concat +cmds = [ Command.Add.cmd +{- , Command.Get.cmd , Command.Drop.cmd , Command.Move.cmd , Command.Copy.cmd , Command.Unlock.cmd + , Command.Unlock.editcmd , Command.Lock.cmd , Command.Sync.cmd , Command.Mirror.cmd @@ -217,6 +221,7 @@ cmds = concat , Command.FuzzTest.cmd , Command.TestRemote.cmd #endif +-} ] header :: String diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index adf6da04e9..fca37790b6 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -16,7 +16,6 @@ import qualified Git.Config import CmdLine 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 @@ -100,12 +99,10 @@ 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 options fields header mkrepo 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 @@ -200,8 +197,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/Seek.hs b/CmdLine/Seek.hs index 47e2c79bc3..66f57e1b00 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -29,11 +29,11 @@ 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,11 +142,11 @@ 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 @@ -160,7 +160,7 @@ getOptionField option converter = converter <=< Annex.getField $ optionName opti 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,7 +171,7 @@ 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 :: Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek withKeyOptions auto keyop = withKeyOptions' auto $ \getkeys -> do matcher <- Limit.getMatcher seekActions $ map (process matcher) <$> getkeys @@ -181,7 +181,7 @@ withKeyOptions auto keyop = withKeyOptions' auto $ \getkeys -> do , return Nothing ) -withKeyOptions' :: Bool -> (Annex [Key] -> Annex ()) -> CommandSeek -> CommandSeek +withKeyOptions' :: Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek withKeyOptions' auto keyop fallbackop params = do bare <- fromRepo Git.repoIsLocalBare allkeys <- Annex.getFlag "all" diff --git a/Command.hs b/Command.hs index 35034a494c..6522924c30 100644 --- a/Command.hs +++ b/Command.hs @@ -7,6 +7,7 @@ module Command ( command, + commandParser, noRepo, noCommit, noMessages, @@ -32,10 +33,17 @@ import CmdLine.Action as ReExported import CmdLine.Option as ReExported import CmdLine.GitAnnex.Options as ReExported -{- Generates a normal command -} -command :: String -> String -> CommandSeek -> CommandSection -> String -> Command +import qualified Options.Applicative as O + +{- Generates a normal Command -} +command :: String -> String -> CommandSection -> String -> CommandParser -> Command command = Command [] Nothing commonChecks False False +{- Simple CommandParser generator, for when the CommandSeek wants all + - non-option parameters. -} +commandParser :: (CmdParams -> CommandSeek) -> CommandParser +commandParser mkseek = mkseek <$> O.many (O.argument O.str O.idm) + {- Indicates that a command doesn't need to commit any changes to - the git-annex branch. -} noCommit :: Command -> Command diff --git a/Command/Add.hs b/Command/Add.hs index 5f6f06cdb6..689f2c6a54 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -34,9 +34,10 @@ 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 $ withOptions addOptions $ + command "add" paramPaths SectionCommon "add files to annex" + (commandParser seek) addOptions :: [Option] addOptions = includeDotFilesOption : fileMatchingOptions @@ -47,7 +48,7 @@ includeDotFilesOption = flagOption [] "include-dotfiles" "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 :: CmdParams -> CommandSeek seek ps = do matcher <- largeFilesMatcher let go a = flip a ps $ \file -> ifM (checkFileMatcher matcher file <||> Annex.getState Annex.force) diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs index 4aab8d0171..a0e9ccba68 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -14,9 +14,9 @@ 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" (paramRepeating paramNumRange) + seek SectionMaintenance "add back unused files" seek :: CommandSeek seek = withUnusedMaps start diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index fda2a99e0f..f009ff388d 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] $ +cmd :: Command +cmd = notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption, rawOption] $ command "addurl" (paramRepeating paramUrl) seek - SectionCommon "add urls to annex"] + SectionCommon "add urls to annex" fileOption :: Option fileOption = fieldOption [] "file" paramFile "specify what file the url is added to" diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 8a916aa557..d405bc8b32 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -19,10 +19,10 @@ import Assistant.Install import System.Environment -cmd :: [Command] -cmd = [noRepo checkNoRepoOpts $ dontCheck repoExists $ withOptions options $ +cmd :: Command +cmd = noRepo checkNoRepoOpts $ dontCheck repoExists $ withOptions options $ notBareRepo $ command "assistant" paramNothing seek SectionCommon - "automatically sync changes"] + "automatically sync changes" options :: [Option] options = diff --git a/Command/CheckPresentKey.hs b/Command/CheckPresentKey.hs index ad61ba3c09..e212a2da87 100644 --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -14,9 +14,9 @@ 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" (paramPair paramKey paramRemote) seek + SectionPlumbing "check if key is present in remote" seek :: CommandSeek seek = withWords start diff --git a/Command/Commit.hs b/Command/Commit.hs index 73f9e2d5ed..b94182a06d 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" paramNothing + SectionPlumbing "commits any staged changes to the git-annex branch" + (commandParser seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index 33b348b07e..78c6d8d243 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -15,11 +15,12 @@ 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" paramNothing + SectionPlumbing "outputs relevant git configuration" + (commandParser seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs index 10879f5b1d..be781b5e27 100644 --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -12,10 +12,10 @@ import Command import CmdLine.Batch import Annex.Content -cmd :: [Command] -cmd = [withOptions [batchOption] $ noCommit $ noMessages $ +cmd :: Command +cmd = withOptions [batchOption] $ noCommit $ noMessages $ command "contentlocation" (paramRepeating paramKey) seek - SectionPlumbing "looks up content for a key"] + SectionPlumbing "looks up content for a key" seek :: CommandSeek seek = batchable withKeys start diff --git a/Command/Copy.hs b/Command/Copy.hs index 5cfdabb4ea..ab4d8e25e3 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -14,9 +14,9 @@ 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"] +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] diff --git a/Command/Dead.hs b/Command/Dead.hs index 7e62b6db0b..75efd0dd58 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -16,10 +16,10 @@ import Command.Trust (trustCommand) import Logs.Location import Remote (keyLocations) -cmd :: [Command] -cmd = [withOptions [keyOption] $ +cmd :: Command +cmd = withOptions [keyOption] $ command "dead" (paramRepeating paramRemote) seek - SectionSetup "hide a lost repository or key"] + SectionSetup "hide a lost repository or key" seek :: CommandSeek seek ps = maybe (trustCommand "dead" DeadTrusted ps) (flip seekKey ps) diff --git a/Command/Describe.hs b/Command/Describe.hs index 56a73334d8..6ff67f1126 100644 --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -12,9 +12,9 @@ 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" (paramPair paramRemote paramDesc) seek + SectionSetup "change description of a repository" seek :: CommandSeek seek = withWords start diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs index f6ef77ecd7..c93bec525e 100644 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -13,10 +13,10 @@ import Annex.Content import Annex.Link import Git.Types -cmd :: [Command] -cmd = [dontCheck repoExists $ +cmd :: Command +cmd = dontCheck repoExists $ command "diffdriver" ("[-- cmd --]") seek - SectionPlumbing "external git diff driver shim"] + SectionPlumbing "external git diff driver shim" seek :: CommandSeek seek = withWords start diff --git a/Command/Direct.hs b/Command/Direct.hs index 1a6b2cb059..3eda794a04 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -15,10 +15,10 @@ import qualified Git.Branch import Config import Annex.Direct -cmd :: [Command] -cmd = [notBareRepo $ noDaemonRunning $ +cmd :: Command +cmd = notBareRepo $ noDaemonRunning $ command "direct" paramNothing seek - SectionSetup "switch repository to direct mode"] + SectionSetup "switch repository to direct mode" seek :: CommandSeek seek = withNothing start diff --git a/Command/Drop.hs b/Command/Drop.hs index 698dd7bada..496d5c55c9 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -22,9 +22,9 @@ 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"] +cmd :: Command +cmd = withOptions (dropOptions) $ command "drop" paramPaths seek + SectionCommon "indicate content of files not currently wanted" dropOptions :: [Option] dropOptions = dropFromOption : annexedMatchingOptions ++ [autoOption] ++ keyOptions diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 890a794669..09366c262a 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -13,11 +13,12 @@ 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" (paramRepeating paramKey) + SectionPlumbing "drops annexed content for specified keys" + (commandParser seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withKeys start start :: Key -> CommandStart diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index d441a4bd2c..99e1e063db 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -16,10 +16,10 @@ import qualified Git import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) import Annex.NumCopies -cmd :: [Command] -cmd = [withOptions [Command.Drop.dropFromOption] $ +cmd :: Command +cmd = withOptions [Command.Drop.dropFromOption] $ command "dropunused" (paramRepeating paramNumRange) - seek SectionMaintenance "drop unused file content"] + seek SectionMaintenance "drop unused file content" seek :: CommandSeek seek ps = do diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index db3ec2b37f..ccf6d9aab4 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -15,10 +15,10 @@ import qualified Command.InitRemote as InitRemote import qualified Data.Map as M -cmd :: [Command] -cmd = [command "enableremote" +cmd :: Command +cmd = command "enableremote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) - seek SectionSetup "enables use of an existing special remote"] + seek SectionSetup "enables use of an existing special remote" seek :: CommandSeek seek = withWords start diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs index 05db9817a6..5ece3a99a5 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -14,10 +14,10 @@ import qualified Utility.Format import Command.Find (formatOption, getFormat, showFormatted, keyVars) import Types.Key -cmd :: [Command] -cmd = [noCommit $ noMessages $ withOptions [formatOption, jsonOption, batchOption] $ +cmd :: Command +cmd = noCommit $ noMessages $ withOptions [formatOption, jsonOption, batchOption] $ command "examinekey" (paramRepeating paramKey) seek - SectionPlumbing "prints information from a key"] + SectionPlumbing "prints information from a key" seek :: CommandSeek seek ps = do diff --git a/Command/Expire.hs b/Command/Expire.hs index f4d1a06e3e..44bdd113f8 100644 --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -20,9 +20,9 @@ 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 = withOptions [activityOption, noActOption] $ command "expire" paramExpire seek + SectionMaintenance "expire inactive repositories" paramExpire :: String paramExpire = (paramRepeating $ paramOptional paramRemote ++ ":" ++ paramTime) diff --git a/Command/Find.hs b/Command/Find.hs index 236824643e..d0bb165c3f 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -19,9 +19,9 @@ 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 = withOptions annexedMatchingOptions $ mkCommand $ + command "find" paramPaths seek SectionQuery "lists available files" mkCommand :: Command -> Command mkCommand = noCommit . noMessages . withOptions [formatOption, print0Option, jsonOption] diff --git a/Command/FindRef.hs b/Command/FindRef.hs index e7f7eae6de..3f09cd6b31 100644 --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -10,10 +10,10 @@ module Command.FindRef where import Command import qualified Command.Find as Find -cmd :: [Command] -cmd = [withOptions nonWorkTreeMatchingOptions $ Find.mkCommand $ +cmd :: Command +cmd = withOptions nonWorkTreeMatchingOptions $ Find.mkCommand $ command "findref" paramRef seek SectionPlumbing - "lists files in a git ref"] + "lists files in a git ref" seek :: CommandSeek seek refs = do diff --git a/Command/Fix.hs b/Command/Fix.hs index c4e5e52ee9..6a27878e38 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 $ withOptions annexedMatchingOptions $ + command "fix" paramPaths + SectionMaintenance "fix up symlinks to point to annexed content" + (commandParser 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 94a1fb421d..370dc8b1ee 100644 --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -15,9 +15,9 @@ 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" paramNothing seek + SectionMaintenance "prune git-annex branch history" forgetOptions :: [Option] forgetOptions = [dropDeadOption] diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 51389b7708..78ebb6268a 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -19,10 +19,10 @@ import qualified Backend.URL import Network.URI -cmd :: [Command] -cmd = [notDirect $ notBareRepo $ +cmd :: Command +cmd = notDirect $ notBareRepo $ command "fromkey" (paramPair paramKey paramPath) seek - SectionPlumbing "adds a file using a specific key"] + SectionPlumbing "adds a file using a specific key" seek :: CommandSeek seek ps = do diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 8988100b8b..177db6498d 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -40,9 +40,9 @@ 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"] +cmd :: Command +cmd = withOptions fsckOptions $ command "fsck" paramPaths seek + SectionMaintenance "check for problems" fsckFromOption :: Option fsckFromOption = fieldOption ['f'] "from" paramRemote "check remote" diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index d6c9e1ac18..bc8cc11617 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -20,9 +20,9 @@ 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" paramNothing seek SectionTesting + "generates fuzz test files" seek :: CommandSeek seek = withNothing start diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs index 7a7f8ae50b..e267aaf670 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" paramValue + SectionPlumbing "sets up gcrypt repository" + (commandParser seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withStrings start start :: String -> CommandStart diff --git a/Command/Get.hs b/Command/Get.hs index d39b3890f1..f54e88b7ae 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -16,9 +16,9 @@ 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 = withOptions getOptions $ command "get" paramPaths seek + SectionCommon "make content of annexed files available" getOptions :: [Option] getOptions = fromOption : autoOption : jobsOption : annexedMatchingOptions diff --git a/Command/Group.hs b/Command/Group.hs index 820f6ab17c..839d21a4c1 100644 --- a/Command/Group.hs +++ b/Command/Group.hs @@ -15,9 +15,9 @@ 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" (paramPair paramRemote paramDesc) seek + SectionSetup "add a repository to a group" seek :: CommandSeek seek = withWords start diff --git a/Command/GroupWanted.hs b/Command/GroupWanted.hs index 5cdf785d70..f58544f6fa 100644 --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -12,9 +12,9 @@ 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" (paramPair paramGroup (paramOptional paramExpression)) seek + SectionSetup "get or set groupwanted expression" seek :: CommandSeek seek = withWords start diff --git a/Command/Help.hs b/Command/Help.hs index 2af39ac9a4..073ab2b367 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -21,9 +21,9 @@ 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 $ noRepo startNoRepo $ dontCheck repoExists $ + command "help" (paramOptional "COMMAND") seek SectionCommon "display help" seek :: CommandSeek seek = withWords start diff --git a/Command/Import.hs b/Command/Import.hs index acf3bc01f2..6bc330fcad 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -22,9 +22,9 @@ 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" paramPaths seek + SectionCommon "move and add files from outside git working copy" opts :: [Option] opts = duplicateModeOptions ++ fileMatchingOptions diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index 4bc3f52f46..4be84375ce 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -43,10 +43,10 @@ import Types.MetaData import Logs.MetaData import Annex.MetaData -cmd :: [Command] -cmd = [notBareRepo $ withOptions [templateOption, relaxedOption, rawOption] $ +cmd :: Command +cmd = notBareRepo $ withOptions [templateOption, relaxedOption, rawOption] $ command "importfeed" (paramRepeating paramUrl) seek - SectionCommon "import files from podcast feeds"] + SectionCommon "import files from podcast feeds" templateOption :: Option templateOption = fieldOption [] "template" paramFormat "template for filenames" diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs index 8e792c4bb4..29d0750a59 100644 --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -11,11 +11,12 @@ 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" (paramRepeating paramKey) + SectionPlumbing "checks if keys are present in the annex" + (commandParser seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withKeys start start :: Key -> CommandStart diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 1d703d2f3c..3e10988ed4 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -22,10 +22,10 @@ import Annex.CatFile import Annex.Init import qualified Command.Add -cmd :: [Command] -cmd = [notBareRepo $ noDaemonRunning $ +cmd :: Command +cmd = notBareRepo $ noDaemonRunning $ command "indirect" paramNothing seek - SectionSetup "switch repository to indirect mode"] + SectionSetup "switch repository to indirect mode" seek :: CommandSeek seek = withNothing start diff --git a/Command/Info.hs b/Command/Info.hs index e6e0194ce8..802aabb568 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -78,10 +78,10 @@ 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) $ +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"] + "shows information about the specified item or the repository as a whole" seek :: CommandSeek seek = withWords start diff --git a/Command/Init.hs b/Command/Init.hs index 23203b0350..45ecb92f81 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -11,9 +11,9 @@ 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" paramDesc seek SectionSetup "initialize git-annex" seek :: CommandSeek seek = withWords start diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs index 7831fe22a0..4bf5f5312c 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -19,10 +19,10 @@ import Logs.Trust import Data.Ord -cmd :: [Command] -cmd = [command "initremote" +cmd :: Command +cmd = command "initremote" (paramPair paramName $ paramOptional $ paramRepeating paramKeyValue) - seek SectionSetup "creates a special (non-git) remote"] + seek SectionSetup "creates a special (non-git) remote" seek :: CommandSeek seek = withWords start diff --git a/Command/List.hs b/Command/List.hs index b9b3a376c2..ba27da7021 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -23,10 +23,10 @@ import Annex.UUID import qualified Annex import Git.Types (RemoteName) -cmd :: [Command] -cmd = [noCommit $ withOptions (allrepos : annexedMatchingOptions) $ +cmd :: Command +cmd = noCommit $ withOptions (allrepos : annexedMatchingOptions) $ command "list" paramPaths seek - SectionQuery "show which remotes contain files"] + SectionQuery "show which remotes contain files" allrepos :: Option allrepos = flagOption [] "allrepos" "show all repositories, not only remotes" diff --git a/Command/Lock.hs b/Command/Lock.hs index 720169506e..2d796ad4f9 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -12,10 +12,10 @@ import Command import qualified Annex.Queue import qualified Annex -cmd :: [Command] -cmd = [notDirect $ withOptions annexedMatchingOptions $ +cmd :: Command +cmd = notDirect $ withOptions annexedMatchingOptions $ command "lock" paramPaths seek SectionCommon - "undo unlock command"] + "undo unlock command" seek :: CommandSeek seek ps = do diff --git a/Command/Log.hs b/Command/Log.hs index 495c43c5a5..3d618360de 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -38,9 +38,9 @@ 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 = withOptions options $ + command "log" paramPaths seek SectionQuery "shows location log" options :: [Option] options = passthruOptions ++ [gourceOption] ++ annexedMatchingOptions diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs index 6e7f070499..9b7dd3a9bf 100644 --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -13,10 +13,10 @@ import CmdLine.Batch import Annex.CatFile import Types.Key -cmd :: [Command] -cmd = [withOptions [batchOption] $ notBareRepo $ noCommit $ noMessages $ +cmd :: Command +cmd = withOptions [batchOption] $ notBareRepo $ noCommit $ noMessages $ command "lookupkey" (paramRepeating paramFile) seek - SectionPlumbing "looks up key used for file"] + SectionPlumbing "looks up key used for file" seek :: CommandSeek seek = batchable withStrings start diff --git a/Command/Map.hs b/Command/Map.hs index 75af591d5f..4328139f1e 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -25,10 +25,10 @@ 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 $ +cmd :: Command +cmd = dontCheck repoExists $ command "map" paramNothing seek SectionQuery - "generate map of repositories"] + "generate map of repositories" seek :: CommandSeek seek = withNothing start diff --git a/Command/Merge.hs b/Command/Merge.hs index 28e3bbb4d4..b451db2afa 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -13,9 +13,9 @@ 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" paramNothing seek SectionMaintenance + "automatically merge changes from remotes" seek :: CommandSeek seek ps = do diff --git a/Command/MetaData.hs b/Command/MetaData.hs index 10093ab084..d6adb0ad42 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -16,10 +16,10 @@ import Logs.MetaData import qualified Data.Set as S import Data.Time.Clock.POSIX -cmd :: [Command] -cmd = [withOptions metaDataOptions $ +cmd :: Command +cmd = withOptions metaDataOptions $ command "metadata" paramPaths seek - SectionMetaData "sets or gets metadata of a file"] + SectionMetaData "sets or gets metadata of a file" metaDataOptions :: [Option] metaDataOptions = diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 6ffe354d5b..d406dbea4d 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -18,10 +18,10 @@ import qualified Command.ReKey import qualified Command.Fsck import qualified Annex -cmd :: [Command] -cmd = [notDirect $ withOptions annexedMatchingOptions $ +cmd :: Command +cmd = notDirect $ withOptions annexedMatchingOptions $ command "migrate" paramPaths seek - SectionUtility "switch data to different backend"] + SectionUtility "switch data to different backend" seek :: CommandSeek seek = withFilesInGit $ whenAnnexed start diff --git a/Command/Mirror.hs b/Command/Mirror.hs index 535dc64b69..8ae57da2fb 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -16,9 +16,9 @@ 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" paramPaths seek + SectionCommon "mirror content of files to/from another repository" mirrorOptions :: [Option] mirrorOptions = fromToOptions ++ [jobsOption] ++ annexedMatchingOptions ++ keyOptions diff --git a/Command/Move.hs b/Command/Move.hs index 6867052ded..739be44176 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -17,9 +17,9 @@ 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"] +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 diff --git a/Command/NotifyChanges.hs b/Command/NotifyChanges.hs index 7ec6072dd2..55379440ce 100644 --- a/Command/NotifyChanges.hs +++ b/Command/NotifyChanges.hs @@ -19,11 +19,12 @@ 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" paramNothing SectionPlumbing + "sends notification when git refs are changed" + (commandParser seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs index 1e710f561a..33db1bbc9f 100644 --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -13,9 +13,9 @@ 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" paramNumber seek + SectionSetup "configure desired number of copies" seek :: CommandSeek seek = withWords start diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs index f4dcff269d..4f1729394c 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -28,11 +28,12 @@ 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" paramPaths SectionPlumbing + "run by git pre-commit hook" + (commandParser 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 8c11bf7708..cfb1f8ba31 100644 --- a/Command/Proxy.hs +++ b/Command/Proxy.hs @@ -17,10 +17,10 @@ import qualified Git.Sha import qualified Git.Ref import qualified Git.Branch -cmd :: [Command] -cmd = [notBareRepo $ +cmd :: Command +cmd = notBareRepo $ command "proxy" ("-- git command") seek - SectionPlumbing "safely bypass direct mode guard"] + SectionPlumbing "safely bypass direct mode guard" seek :: CommandSeek seek = withWords start diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 980b27f5a3..319f3eda8d 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -18,10 +18,10 @@ import Logs.Location import Utility.CopyFile import qualified Remote -cmd :: [Command] -cmd = [notDirect $ command "rekey" +cmd :: Command +cmd = notDirect $ command "rekey" (paramOptional $ paramRepeating $ paramPair paramPath paramKey) - seek SectionPlumbing "change keys used for files"] + seek SectionPlumbing "change keys used for files" seek :: CommandSeek seek = withPairs start diff --git a/Command/ReadPresentKey.hs b/Command/ReadPresentKey.hs index 8125ddf7e2..6eab893cf1 100644 --- a/Command/ReadPresentKey.hs +++ b/Command/ReadPresentKey.hs @@ -12,9 +12,9 @@ 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" (paramPair paramKey paramUUID) seek + SectionPlumbing "read records of where key is present" seek :: CommandSeek seek = withWords start diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index 8572596d2e..574963494f 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" paramKey + SectionPlumbing "runs rsync in server mode to receive content" + (commandParser seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withKeys start start :: Key -> CommandStart diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs index 4282db58a4..bac5b77403 100644 --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -15,10 +15,10 @@ import Logs.Web import Annex.UUID import Command.FromKey (mkKey) -cmd :: [Command] -cmd = [notDirect $ notBareRepo $ +cmd :: Command +cmd = notDirect $ notBareRepo $ command "registerurl" (paramPair paramKey paramUrl) seek - SectionPlumbing "registers an url for a key"] + SectionPlumbing "registers an url for a key" seek :: CommandSeek seek = withWords start diff --git a/Command/Reinit.hs b/Command/Reinit.hs index f201c66bba..948ed3131c 100644 --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -15,8 +15,9 @@ import Types.UUID import qualified Remote cmd :: [Command] -cmd = [dontCheck repoExists $ - command "reinit" (paramUUID ++ "|" ++ paramDesc) seek SectionUtility "initialize repository, reusing old UUID"] +cmd = dontCheck repoExists $ + command "reinit" (paramUUID ++ "|" ++ paramDesc) seek + SectionUtility "initialize repository, reusing old UUID" seek :: CommandSeek seek = withWords start diff --git a/Command/Reinject.hs b/Command/Reinject.hs index de7f6eb3d0..09511562fd 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -15,8 +15,8 @@ import qualified Command.Fsck import qualified Backend cmd :: [Command] -cmd = [command "reinject" (paramPair "SRC" "DEST") seek - SectionUtility "sets content of annexed file"] +cmd = command "reinject" (paramPair "SRC" "DEST") seek + SectionUtility "sets content of annexed file" seek :: CommandSeek seek = withWords start diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs index 2e3d625551..fdd9386133 100644 --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -11,9 +11,9 @@ 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" paramNothing seek SectionPlumbing + "detects when remotes have changed, and fetches from them" seek :: CommandSeek seek = withNothing start diff --git a/Command/Repair.hs b/Command/Repair.hs index d41a074c0e..56d6969609 100644 --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -16,9 +16,9 @@ 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" paramNothing seek SectionMaintenance "recover broken git repository" seek :: CommandSeek seek = withNothing start diff --git a/Command/Required.hs b/Command/Required.hs index 3d9c592796..3cc053b55d 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 ce199e504a..0ecf180b82 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -14,9 +14,9 @@ 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" paramNothing seek SectionPlumbing + "resolve merge conflicts" seek :: CommandSeek seek = withNothing start diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs index 5287718c58..2f95ef9932 100644 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -13,10 +13,10 @@ import Logs.Web import Annex.UUID import qualified Remote -cmd :: [Command] -cmd = [notBareRepo $ +cmd :: Command +cmd = notBareRepo $ command "rmurl" (paramPair paramFile paramUrl) seek - SectionCommon "record file is not available at url"] + SectionCommon "record file is not available at url" seek :: CommandSeek seek = withPairs start diff --git a/Command/Schedule.hs b/Command/Schedule.hs index 91ef2c1383..723ade65bd 100644 --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -17,9 +17,9 @@ 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" (paramPair paramRemote (paramOptional paramExpression)) seek + SectionSetup "get or set scheduled jobs" seek :: CommandSeek seek = withWords start diff --git a/Command/Semitrust.hs b/Command/Semitrust.hs index 49004d7f95..3ef2621e03 100644 --- a/Command/Semitrust.hs +++ b/Command/Semitrust.hs @@ -11,9 +11,9 @@ 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" (paramRepeating paramRemote) seek + SectionSetup "return repository to default trust level" seek :: CommandSeek seek = trustCommand "semitrust" SemiTrusted diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 0117855820..78d1f9c1c4 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -16,11 +16,12 @@ 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" paramKey + SectionPlumbing "runs rsync in server mode to send content" + (commandParser seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withKeys start start :: Key -> CommandStart diff --git a/Command/SetKey.hs b/Command/SetKey.hs index d5762dd8c2..4f7b5aaf59 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -13,9 +13,9 @@ 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" (paramPair paramKey paramPath) seek + SectionPlumbing "sets annexed content for a key" seek :: CommandSeek seek = withWords start diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs index 1c41dc2ae0..cc2ebc1420 100644 --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -13,9 +13,9 @@ 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" (paramPair paramKey (paramPair paramUUID "[1|0]")) seek + SectionPlumbing "change records of where key is present" seek :: CommandSeek seek = withWords start diff --git a/Command/Status.hs b/Command/Status.hs index 26e96a9253..248a0b84ba 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -16,10 +16,10 @@ import qualified Git.LsFiles as LsFiles import qualified Git.Ref import qualified Git -cmd :: [Command] -cmd = [notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $ +cmd :: Command +cmd = notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $ command "status" paramPaths seek SectionCommon - "show the working tree status"] + "show the working tree status" seek :: CommandSeek seek = withWords start diff --git a/Command/Sync.hs b/Command/Sync.hs index d2c2f95e88..10b9fc2cde 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -51,10 +51,10 @@ import Utility.Bloom import Control.Concurrent.MVar import qualified Data.Map as M -cmd :: [Command] -cmd = [withOptions syncOptions $ +cmd :: Command +cmd = withOptions syncOptions $ command "sync" (paramOptional (paramRepeating paramRemote)) - seek SectionCommon "synchronize local repository with remotes"] + seek SectionCommon "synchronize local repository with remotes" syncOptions :: [Option] syncOptions = diff --git a/Command/Test.hs b/Command/Test.hs index 3c42514609..af02985af2 100644 --- a/Command/Test.hs +++ b/Command/Test.hs @@ -11,10 +11,10 @@ import Common import Command import Messages -cmd :: [Command] -cmd = [ noRepo startIO $ dontCheck repoExists $ +cmd :: Command +cmd = noRepo startIO $ dontCheck repoExists $ command "test" paramNothing seek SectionTesting - "run built-in test suite"] + "run built-in test suite" seek :: CommandSeek seek = withWords start diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index b0f2c28bb8..cbd2edaf1f 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -36,10 +36,10 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as M -cmd :: [Command] -cmd = [ withOptions [sizeOption] $ +cmd :: Command +cmd = withOptions [sizeOption] $ command "testremote" paramRemote seek SectionTesting - "test transfers to/from a remote"] + "test transfers to/from a remote" sizeOption :: Option sizeOption = fieldOption [] "size" paramSize "base key size (default 1MiB)" diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index f90e2ad731..44ffe59ad5 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -15,11 +15,12 @@ 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" paramKey SectionPlumbing + "updates sender on number of bytes of content received" + (commandParser seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start {- Security: diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 14e7888939..6da2e742b6 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -15,10 +15,10 @@ import Annex.Transfer import qualified Remote import Types.Remote -cmd :: [Command] -cmd = [withOptions transferKeyOptions $ +cmd :: Command +cmd = withOptions transferKeyOptions $ noCommit $ command "transferkey" paramKey seek SectionPlumbing - "transfers a key from or to a remote"] + "transfers a key from or to a remote" transferKeyOptions :: [Option] transferKeyOptions = fileOption : fromToOptions diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index d490d9be41..a151754df0 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -21,9 +21,9 @@ 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" paramNothing seek + SectionPlumbing "transfers keys" seek :: CommandSeek seek = withNothing start diff --git a/Command/Trust.hs b/Command/Trust.hs index 9d380990e8..6f3382c30d 100644 --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -16,9 +16,9 @@ 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" (paramRepeating paramRemote) seek + SectionSetup "trust a repository" seek :: CommandSeek seek = trustCommand "trust" Trusted diff --git a/Command/Unannex.hs b/Command/Unannex.hs index 0d88148c8f..83e9909217 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 = withOptions annexedMatchingOptions $ + command "unannex" paramPaths SectionUtility + "undo accidential add command" + (commandParser 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 8e6b1c44f0..4740aab486 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -21,10 +21,10 @@ import qualified Git.Command as Git import qualified Git.Branch import qualified Command.Sync -cmd :: [Command] -cmd = [notBareRepo $ +cmd :: Command +cmd = notBareRepo $ command "undo" paramPaths seek - SectionCommon "undo last change to a file or directory"] + SectionCommon "undo last change to a file or directory" seek :: CommandSeek seek ps = do diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs index dd6e8c952c..b711a0132b 100644 --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -15,9 +15,9 @@ 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" (paramPair paramRemote paramDesc) seek + SectionSetup "remove a repository from a group" seek :: CommandSeek seek = withWords start diff --git a/Command/Uninit.hs b/Command/Uninit.hs index 4a918070cd..64c5154647 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -21,9 +21,10 @@ 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" paramPaths + SectionUtility "de-initialize git-annex and clean out repository" + (commandParser seek) check :: Annex () check = do @@ -39,7 +40,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 a1b1ce4112..98117f5b5a 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -13,14 +13,15 @@ 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" + +editcmd :: Command +editcmd = mkcmd "edit" "same as unlock" + +mkcmd :: String -> String -> Command +mkcmd n = notDirect . withOptions annexedMatchingOptions + . command n paramPaths seek SectionCommon seek :: CommandSeek seek = withFilesInGit $ whenAnnexed start diff --git a/Command/Untrust.hs b/Command/Untrust.hs index 92e28b6376..220faf85e9 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" (paramRepeating paramRemote) seek + SectionSetup "do not trust a repository" seek :: CommandSeek seek = trustCommand "untrust" UnTrusted diff --git a/Command/Unused.hs b/Command/Unused.hs index 77a9a92c3b..1f84f012f7 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -34,10 +34,11 @@ import Git.FilePath 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 = withOptions [unusedFromOption, refSpecOption] $ + command "unused" paramNothing + SectionMaintenance "look for unused file content" + (commandParser seek) unusedFromOption :: Option unusedFromOption = fieldOption ['f'] "from" paramRemote "remote to check for unused content" @@ -45,7 +46,7 @@ unusedFromOption = fieldOption ['f'] "from" paramRemote "remote to check for unu refSpecOption :: Option refSpecOption = fieldOption [] "used-refspec" paramRefSpec "refs to consider used (default: all refs)" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start {- Finds unused content in the annex. -} diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs index 081d7ff352..0fa9022ff0 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -11,10 +11,10 @@ import Common.Annex import Command import Upgrade -cmd :: [Command] -cmd = [dontCheck repoExists $ -- because an old version may not seem to exist +cmd :: Command +cmd = dontCheck repoExists $ -- because an old version may not seem to exist command "upgrade" paramNothing seek - SectionMaintenance "upgrade repository layout"] + SectionMaintenance "upgrade repository layout" seek :: CommandSeek seek = withNothing start diff --git a/Command/VAdd.hs b/Command/VAdd.hs index ea98e66397..478eab098b 100644 --- a/Command/VAdd.hs +++ b/Command/VAdd.hs @@ -12,9 +12,9 @@ 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" (paramRepeating "FIELD=GLOB") + seek SectionMetaData "add subdirs to current view" seek :: CommandSeek seek = withWords start diff --git a/Command/VCycle.hs b/Command/VCycle.hs index bf253adc1c..31a5f80c2b 100644 --- a/Command/VCycle.hs +++ b/Command/VCycle.hs @@ -14,10 +14,10 @@ import Types.View import Logs.View import Command.View (checkoutViewBranch) -cmd :: [Command] -cmd = [notBareRepo $ notDirect $ +cmd :: Command +cmd = notBareRepo $ notDirect $ command "vcycle" paramNothing seek SectionMetaData - "switch view to next layout"] + "switch view to next layout" seek :: CommandSeek seek = withNothing start diff --git a/Command/VFilter.hs b/Command/VFilter.hs index fd5ec9630f..78f2d9d5c3 100644 --- a/Command/VFilter.hs +++ b/Command/VFilter.hs @@ -12,9 +12,9 @@ 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" paramView seek SectionMetaData "filter current view" seek :: CommandSeek seek = withWords start diff --git a/Command/VPop.hs b/Command/VPop.hs index 1fb1d7a56a..f6fc56b084 100644 --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -16,10 +16,10 @@ import Types.View import Logs.View import Command.View (checkoutViewBranch) -cmd :: [Command] -cmd = [notBareRepo $ notDirect $ +cmd :: Command +cmd = notBareRepo $ notDirect $ command "vpop" (paramOptional paramNumber) seek SectionMetaData - "switch back to previous view"] + "switch back to previous view" seek :: CommandSeek seek = withWords start diff --git a/Command/Version.hs b/Command/Version.hs index 1b96de9d2f..3ceef3a60d 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -17,10 +17,10 @@ import qualified Types.Remote as R import qualified Remote import qualified Backend -cmd :: [Command] -cmd = [withOptions [rawOption] $ +cmd :: Command +cmd = withOptions [rawOption] $ noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "version" paramNothing seek SectionQuery "show version info"] + command "version" paramNothing seek SectionQuery "show version info" rawOption :: Option rawOption = flagOption [] "raw" "output only program version" diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index f1a64ba234..9b8177e770 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -29,9 +29,9 @@ 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" paramNothing seek + SectionSetup "edit git-annex's configuration" seek :: CommandSeek seek = withNothing start diff --git a/Command/View.hs b/Command/View.hs index ae2878396c..584cf091f6 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -17,9 +17,9 @@ 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" paramView seek SectionMetaData "enter a view branch" seek :: CommandSeek seek = withWords start diff --git a/Command/Wanted.hs b/Command/Wanted.hs index 07f5ee7c34..215595a525 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 pdesc seek SectionSetup desc where pdesc = paramPair paramRemote (paramOptional paramExpression) diff --git a/Command/Watch.hs b/Command/Watch.hs index cf86a58328..0782a4e6e5 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -12,9 +12,9 @@ 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" paramNothing seek SectionCommon "watch for changes and autocommit" seek :: CommandSeek seek ps = do diff --git a/Command/WebApp.hs b/Command/WebApp.hs index e872d4be01..dab8e1e5bb 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -37,10 +37,10 @@ import Control.Concurrent.STM import Network.Socket (HostName) import System.Environment (getArgs) -cmd :: [Command] -cmd = [ withOptions [listenOption] $ +cmd :: Command +cmd = withOptions [listenOption] $ noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $ - command "webapp" paramNothing seek SectionCommon "launch webapp"] + command "webapp" paramNothing seek SectionCommon "launch webapp" listenOption :: Option listenOption = fieldOption [] "listen" paramAddress diff --git a/Command/Whereis.hs b/Command/Whereis.hs index cfcc8f2245..54be0dd187 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -15,10 +15,10 @@ import Remote import Logs.Trust import Logs.Web -cmd :: [Command] -cmd = [noCommit $ withOptions (jsonOption : annexedMatchingOptions ++ keyOptions) $ +cmd :: Command +cmd = noCommit $ withOptions (jsonOption : annexedMatchingOptions ++ keyOptions) $ command "whereis" paramPaths seek SectionQuery - "lists repositories that have file content"] + "lists repositories that have file content" seek :: CommandSeek seek ps = do diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs index 2bcb7405e4..86cae9ab73 100644 --- a/Command/XMPPGit.hs +++ b/Command/XMPPGit.hs @@ -11,10 +11,10 @@ import Common.Annex import Command import Assistant.XMPP.Git -cmd :: [Command] -cmd = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ +cmd :: Command +cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $ command "xmppgit" paramNothing seek - SectionPlumbing "git to XMPP relay"] + SectionPlumbing "git to XMPP relay" seek :: CommandSeek seek = withWords start diff --git a/Types/Command.hs b/Types/Command.hs index de6e780389..4ab7220353 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -1,6 +1,6 @@ {- git-annex command data types - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -8,28 +8,31 @@ 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 @@ -42,11 +45,13 @@ data Command = Command , cmdnomessages :: Bool -- don't output normal messages , cmdname :: String , cmdparamdesc :: String -- description of params for usage - , cmdseek :: CommandSeek , cmdsection :: CommandSection , cmddesc :: String -- description of command for usage + , cmdparser :: CommandParser -- command line parser } +{- Command-line parameters, after the command is selected and options + - are parsed. -} type CmdParams = [String] {- CommandCheck functions can be compared using their unique id. -} diff --git a/git-annex.cabal b/git-annex.cabal index 941067f5de..fec1bd40d6 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) From 3125da54f65c8b61ed0d4983ec36a29e529e5832 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 13:39:11 -0400 Subject: [PATCH 02/54] display cmdparamdesc in optparse-applicative usage messages Since optparse-applicative display "FOO" as "[FOO]", the paramOptional modifier which wrapped it in square brackets was removed from most places. --- CmdLine/Usage.hs | 4 ++-- Command.hs | 12 ++++++++---- Command/Help.hs | 2 +- Command/Info.hs | 2 +- Command/ReKey.hs | 2 +- Command/Sync.hs | 2 +- Command/VPop.hs | 2 +- 7 files changed, 15 insertions(+), 11 deletions(-) diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs index ad1d4e583d..b386be9a6c 100644 --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -58,7 +58,7 @@ commandUsage cmd = unlines {- 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 +114,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 6522924c30..4fc665ba21 100644 --- a/Command.hs +++ b/Command.hs @@ -36,13 +36,17 @@ import CmdLine.GitAnnex.Options as ReExported import qualified Options.Applicative as O {- Generates a normal Command -} -command :: String -> String -> CommandSection -> String -> CommandParser -> Command -command = Command [] Nothing commonChecks False False +command :: String -> String -> CommandSection -> String -> (Command -> CommandParser) -> Command +command name paramdesc section desc parser = c + where + c = Command [] Nothing commonChecks False False name paramdesc section desc (parser c) {- Simple CommandParser generator, for when the CommandSeek wants all - non-option parameters. -} -commandParser :: (CmdParams -> CommandSeek) -> CommandParser -commandParser mkseek = mkseek <$> O.many (O.argument O.str O.idm) +commandParser :: (CmdParams -> CommandSeek) -> Command -> CommandParser +commandParser mkseek c = mkseek <$> O.many cmdparams + where + cmdparams = O.argument O.str (O.metavar (cmdparamdesc c)) {- Indicates that a command doesn't need to commit any changes to - the git-annex branch. -} diff --git a/Command/Help.hs b/Command/Help.hs index 073ab2b367..b6b1be3794 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -23,7 +23,7 @@ import System.Console.GetOpt cmd :: Command cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "help" (paramOptional "COMMAND") seek SectionCommon "display help" + command "help" "COMMAND" seek SectionCommon "display help" seek :: CommandSeek seek = withWords start diff --git a/Command/Info.hs b/Command/Info.hs index 802aabb568..0c8200ff3e 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -80,7 +80,7 @@ type StatState = StateT StatInfo Annex cmd :: Command cmd = noCommit $ dontCheck repoExists $ withOptions (jsonOption : bytesOption : annexedMatchingOptions) $ - command "info" (paramOptional $ paramRepeating paramItem) seek SectionQuery + command "info" (paramRepeating paramItem) seek SectionQuery "shows information about the specified item or the repository as a whole" seek :: CommandSeek diff --git a/Command/ReKey.hs b/Command/ReKey.hs index 319f3eda8d..2a27878980 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -20,7 +20,7 @@ import qualified Remote cmd :: Command cmd = notDirect $ command "rekey" - (paramOptional $ paramRepeating $ paramPair paramPath paramKey) + (paramRepeating $ paramPair paramPath paramKey) seek SectionPlumbing "change keys used for files" seek :: CommandSeek diff --git a/Command/Sync.hs b/Command/Sync.hs index 10b9fc2cde..95bd7c8d7a 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -53,7 +53,7 @@ import qualified Data.Map as M cmd :: Command cmd = withOptions syncOptions $ - command "sync" (paramOptional (paramRepeating paramRemote)) + command "sync" (paramRepeating paramRemote) seek SectionCommon "synchronize local repository with remotes" syncOptions :: [Option] diff --git a/Command/VPop.hs b/Command/VPop.hs index f6fc56b084..0dadd52fb0 100644 --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -18,7 +18,7 @@ import Command.View (checkoutViewBranch) cmd :: Command cmd = notBareRepo $ notDirect $ - command "vpop" (paramOptional paramNumber) seek SectionMetaData + command "vpop" paramNumber seek SectionMetaData "switch back to previous view" seek :: CommandSeek From 6e5c1f8db3a4f2b1a3369c7a4152211ae985d68a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 15:08:02 -0400 Subject: [PATCH 03/54] convert all commands to work with optparse-applicative Still no options though. --- CmdLine/Batch.hs | 2 +- CmdLine/GitAnnex.hs | 4 ---- CmdLine/Usage.hs | 11 +++++++++-- Command.hs | 18 ++++-------------- Command/Add.hs | 12 ++++++------ Command/AddUnused.hs | 8 +++++--- Command/AddUrl.hs | 6 +++--- Command/Assistant.hs | 5 +++-- Command/CheckPresentKey.hs | 9 ++++++--- Command/Commit.hs | 6 +++--- Command/ConfigList.hs | 7 ++++--- Command/ContentLocation.hs | 7 ++++--- Command/Copy.hs | 8 +++++--- Command/Dead.hs | 8 ++++---- Command/Describe.hs | 8 +++++--- Command/DiffDriver.hs | 7 ++++--- Command/Direct.hs | 6 +++--- Command/Drop.hs | 8 +++++--- Command/DropKey.hs | 8 +++++--- Command/DropUnused.hs | 7 ++++--- Command/EnableRemote.hs | 7 ++++--- Command/ExamineKey.hs | 7 ++++--- Command/Expire.hs | 8 +++++--- Command/Find.hs | 5 +++-- Command/FindRef.hs | 5 +++-- Command/Fix.hs | 6 +++--- Command/Forget.hs | 8 +++++--- Command/FromKey.hs | 7 ++++--- Command/Fsck.hs | 7 ++++--- Command/FuzzTest.hs | 8 +++++--- Command/GCryptSetup.hs | 6 +++--- Command/Get.hs | 8 +++++--- Command/Group.hs | 6 +++--- Command/GroupWanted.hs | 8 +++++--- Command/Help.hs | 7 ++++--- Command/Import.hs | 8 +++++--- Command/ImportFeed.hs | 6 +++--- Command/InAnnex.hs | 8 +++++--- Command/Indirect.hs | 6 +++--- Command/Info.hs | 7 ++++--- Command/Init.hs | 5 +++-- Command/InitRemote.hs | 7 ++++--- Command/List.hs | 7 ++++--- Command/Lock.hs | 7 ++++--- Command/Log.hs | 5 +++-- Command/LookupKey.hs | 7 ++++--- Command/Map.hs | 5 +++-- Command/Merge.hs | 5 +++-- Command/MetaData.hs | 7 ++++--- Command/Migrate.hs | 7 ++++--- Command/Mirror.hs | 8 +++++--- Command/Move.hs | 8 +++++--- Command/NotifyChanges.hs | 7 ++++--- Command/NumCopies.hs | 7 ++++--- Command/PreCommit.hs | 5 +++-- Command/Proxy.hs | 7 ++++--- Command/ReKey.hs | 10 ++++++---- Command/ReadPresentKey.hs | 9 ++++++--- Command/RecvKey.hs | 6 +++--- Command/RegisterUrl.hs | 6 ++++-- Command/Reinit.hs | 10 ++++++---- Command/Reinject.hs | 9 +++++---- Command/RemoteDaemon.hs | 8 +++++--- Command/Repair.hs | 6 ++++-- Command/ResolveMerge.hs | 5 +++-- Command/RmUrl.hs | 8 +++++--- Command/Schedule.hs | 7 ++++--- Command/Semitrust.hs | 7 ++++--- Command/SendKey.hs | 7 ++++--- Command/SetKey.hs | 7 ++++--- Command/SetPresentKey.hs | 9 ++++++--- Command/Status.hs | 5 +++-- Command/Sync.hs | 7 ++++--- Command/Test.hs | 5 +++-- Command/TestRemote.hs | 7 ++++--- Command/TransferInfo.hs | 7 ++++--- Command/TransferKey.hs | 7 ++++--- Command/TransferKeys.hs | 6 +++--- Command/Trust.hs | 8 ++++---- Command/Unannex.hs | 4 ++-- Command/Undo.hs | 7 ++++--- Command/Ungroup.hs | 6 +++--- Command/Uninit.hs | 7 ++++--- Command/Unlock.hs | 6 +++--- Command/Untrust.hs | 6 +++--- Command/Unused.hs | 8 ++++---- Command/Upgrade.hs | 6 +++--- Command/VAdd.hs | 9 ++++++--- Command/VCycle.hs | 7 ++++--- Command/VFilter.hs | 5 +++-- Command/VPop.hs | 6 +++--- Command/Version.hs | 5 +++-- Command/Vicfg.hs | 6 +++--- Command/View.hs | 13 +++++++------ Command/Wanted.hs | 2 +- Command/Watch.hs | 6 ++++-- Command/WebApp.hs | 5 +++-- Command/Whereis.hs | 5 +++-- Command/XMPPGit.hs | 6 +++--- 99 files changed, 391 insertions(+), 297 deletions(-) diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs index 836472eb01..24f942978e 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 5619129f50..8967bc4711 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -16,7 +16,6 @@ import Utility.Env import Annex.Ssh import qualified Command.Add -{- import qualified Command.Unannex import qualified Command.Drop import qualified Command.Move @@ -117,12 +116,10 @@ import qualified Command.TestRemote #ifdef WITH_EKG import System.Remote.Monitoring #endif --} cmds :: [Command] cmds = [ Command.Add.cmd -{- , Command.Get.cmd , Command.Drop.cmd , Command.Move.cmd @@ -221,7 +218,6 @@ cmds = , Command.FuzzTest.cmd , Command.TestRemote.cmd #endif --} ] header :: String diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs index b386be9a6c..58408762b9 100644 --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -1,6 +1,6 @@ {- git-annex usage messages - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -8,10 +8,10 @@ module CmdLine.Usage where import Common.Annex - import Types.Command import System.Console.GetOpt +import qualified Options.Applicative as O usageMessage :: String -> String usageMessage s = "Usage: " ++ s @@ -56,6 +56,13 @@ commandUsage cmd = unlines , "[option ...]" ] +{- Simple CommandParser generator, for when the CommandSeek wants all + - non-option parameters. -} +withParams :: (CmdParams -> CommandSeek) -> String -> CommandParser +withParams mkseek paramdesc = mkseek <$> O.many cmdparams + where + cmdparams = O.argument O.str (O.metavar paramdesc) + {- Descriptions of params used in usage messages. -} paramPaths :: String paramPaths = paramRepeating paramPath -- most often used diff --git a/Command.hs b/Command.hs index 4fc665ba21..c1d788c799 100644 --- a/Command.hs +++ b/Command.hs @@ -7,7 +7,6 @@ module Command ( command, - commandParser, noRepo, noCommit, noMessages, @@ -33,20 +32,11 @@ import CmdLine.Action as ReExported import CmdLine.Option as ReExported import CmdLine.GitAnnex.Options as ReExported -import qualified Options.Applicative as O - {- Generates a normal Command -} -command :: String -> String -> CommandSection -> String -> (Command -> CommandParser) -> Command -command name paramdesc section desc parser = c - where - c = Command [] Nothing commonChecks False False name paramdesc section desc (parser c) - -{- Simple CommandParser generator, for when the CommandSeek wants all - - non-option parameters. -} -commandParser :: (CmdParams -> CommandSeek) -> Command -> CommandParser -commandParser mkseek c = mkseek <$> O.many cmdparams - where - cmdparams = O.argument O.str (O.metavar (cmdparamdesc c)) +command :: String -> CommandSection -> String -> String -> (String -> CommandParser) -> Command +command name section desc paramdesc mkparser = + Command [] Nothing commonChecks False False name paramdesc + section desc (mkparser paramdesc) {- Indicates that a command doesn't need to commit any changes to - the git-annex branch. -} diff --git a/Command/Add.hs b/Command/Add.hs index 689f2c6a54..270ac7f394 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -36,8 +36,8 @@ import Control.Exception (IOException) cmd :: Command cmd = notBareRepo $ withOptions addOptions $ - command "add" paramPaths SectionCommon "add files to annex" - (commandParser seek) + command "add" SectionCommon "add files to annex" + paramPaths (withParams seek) addOptions :: [Option] addOptions = includeDotFilesOption : fileMatchingOptions @@ -71,8 +71,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 @@ -279,8 +279,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 a0e9ccba68..2b315eada4 100644 --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -15,10 +15,12 @@ import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) import Types.Key cmd :: Command -cmd = notDirect $ command "addunused" (paramRepeating paramNumRange) - seek SectionMaintenance "add back unused files" +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 f009ff388d..45edca283c 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -39,8 +39,8 @@ import qualified Utility.Quvi as Quvi cmd :: Command cmd = notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption, rawOption] $ - command "addurl" (paramRepeating paramUrl) seek - SectionCommon "add urls to annex" + 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 d405bc8b32..51d5a46b27 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -21,8 +21,9 @@ import System.Environment cmd :: Command cmd = noRepo checkNoRepoOpts $ dontCheck repoExists $ withOptions options $ - notBareRepo $ command "assistant" paramNothing seek SectionCommon + notBareRepo $ command "assistant" SectionCommon "automatically sync changes" + paramNothing (withParams seek) options :: [Option] options = @@ -42,7 +43,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 e212a2da87..6a38f85013 100644 --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -15,10 +15,13 @@ import Annex import Types.Messages cmd :: Command -cmd = noCommit $ command "checkpresentkey" (paramPair paramKey paramRemote) seek - SectionPlumbing "check if key is present in remote" +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 b94182a06d..52b88d2b34 100644 --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -13,9 +13,9 @@ import qualified Annex.Branch import qualified Git cmd :: Command -cmd = command "commit" paramNothing - SectionPlumbing "commits any staged changes to the git-annex branch" - (commandParser seek) +cmd = command "commit" SectionPlumbing + "commits any staged changes to the git-annex branch" + paramNothing (withParams seek) seek :: CmdParams -> CommandSeek seek = withNothing start diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs index 78c6d8d243..95498ba209 100644 --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -16,9 +16,10 @@ import qualified Git.Config import Remote.GCrypt (coreGCryptId) cmd :: Command -cmd = noCommit $ command "configlist" paramNothing - SectionPlumbing "outputs relevant git configuration" - (commandParser seek) +cmd = noCommit $ + command "configlist" SectionPlumbing + "outputs relevant git configuration" + paramNothing (withParams seek) seek :: CmdParams -> CommandSeek seek = withNothing start diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs index be781b5e27..bca73f9260 100644 --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -14,10 +14,11 @@ import Annex.Content cmd :: Command cmd = withOptions [batchOption] $ noCommit $ noMessages $ - command "contentlocation" (paramRepeating paramKey) seek - SectionPlumbing "looks up content for a key" + 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 ab4d8e25e3..26ff8e2630 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -15,13 +15,15 @@ import Annex.Wanted import Annex.NumCopies cmd :: Command -cmd = withOptions copyOptions $ command "copy" paramPaths seek - SectionCommon "copy content of files to/from another repository" +cmd = withOptions copyOptions $ + command "copy" SectionCommon + "copy content of files to/from another repository" + paramPaths (withParams seek) copyOptions :: [Option] copyOptions = Command.Move.moveOptions ++ [autoOption] -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do to <- getOptionField toOption Remote.byNameWithUUID from <- getOptionField fromOption Remote.byNameWithUUID diff --git a/Command/Dead.hs b/Command/Dead.hs index 75efd0dd58..e487b3b5e1 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -18,14 +18,14 @@ import Remote (keyLocations) cmd :: Command cmd = withOptions [keyOption] $ - command "dead" (paramRepeating paramRemote) seek - SectionSetup "hide a lost repository or key" + 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 6ff67f1126..ca0bac4e80 100644 --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -13,10 +13,12 @@ import qualified Remote import Logs.UUID cmd :: Command -cmd = command "describe" (paramPair paramRemote paramDesc) seek - SectionSetup "change description of a repository" +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 c93bec525e..2313e5f0de 100644 --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -15,10 +15,11 @@ import Git.Types cmd :: Command cmd = dontCheck repoExists $ - command "diffdriver" ("[-- cmd --]") seek - SectionPlumbing "external git diff driver shim" + 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 3eda794a04..162780dd5c 100644 --- a/Command/Direct.hs +++ b/Command/Direct.hs @@ -17,10 +17,10 @@ import Annex.Direct cmd :: Command cmd = notBareRepo $ noDaemonRunning $ - command "direct" paramNothing seek - SectionSetup "switch repository to direct mode" + 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 496d5c55c9..a93dac5952 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -23,8 +23,10 @@ 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" +cmd = withOptions (dropOptions) $ + command "drop" SectionCommon + "indicate content of files not currently wanted" + paramPaths (withParams seek) dropOptions :: [Option] dropOptions = dropFromOption : annexedMatchingOptions ++ [autoOption] ++ keyOptions @@ -32,7 +34,7 @@ dropOptions = dropFromOption : annexedMatchingOptions ++ [autoOption] ++ keyOpti dropFromOption :: Option dropFromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do from <- getOptionField dropFromOption Remote.byNameWithUUID auto <- getOptionFlag autoOption diff --git a/Command/DropKey.hs b/Command/DropKey.hs index 09366c262a..5d44f0fcdc 100644 --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -14,9 +14,11 @@ import Logs.Location import Annex.Content cmd :: Command -cmd = noCommit $ command "dropkey" (paramRepeating paramKey) - SectionPlumbing "drops annexed content for specified keys" - (commandParser seek) +cmd = noCommit $ + command "dropkey" SectionPlumbing + "drops annexed content for specified keys" + (paramRepeating paramKey) + (withParams seek) seek :: CmdParams -> CommandSeek seek = withKeys start diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 99e1e063db..703cc38906 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -18,10 +18,11 @@ import Annex.NumCopies cmd :: Command cmd = withOptions [Command.Drop.dropFromOption] $ - command "dropunused" (paramRepeating paramNumRange) - seek SectionMaintenance "drop unused file content" + command "dropunused" SectionMaintenance + "drop unused file content" + (paramRepeating paramNumRange) (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do numcopies <- getNumCopies withUnusedMaps (start numcopies) ps diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs index ccf6d9aab4..1d4c4af5e9 100644 --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -16,11 +16,12 @@ import qualified Command.InitRemote as InitRemote import qualified Data.Map as M cmd :: Command -cmd = command "enableremote" +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 5ece3a99a5..65f4978a64 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -16,10 +16,11 @@ import Types.Key cmd :: Command cmd = noCommit $ noMessages $ withOptions [formatOption, jsonOption, batchOption] $ - command "examinekey" (paramRepeating paramKey) seek - SectionPlumbing "prints information from a key" + 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 44bdd113f8..9552128f11 100644 --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -21,8 +21,10 @@ 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 = withOptions [activityOption, noActOption] $ + command "expire" SectionMaintenance + "expire inactive repositories" + paramExpire (withParams seek) paramExpire :: String paramExpire = (paramRepeating $ paramOptional paramRemote ++ ":" ++ paramTime) @@ -33,7 +35,7 @@ activityOption = fieldOption [] "activity" "Name" "specify activity" noActOption :: Option noActOption = flagOption [] "no-act" "don't really do anything" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do expire <- parseExpire ps wantact <- getOptionField activityOption (pure . parseActivity) diff --git a/Command/Find.hs b/Command/Find.hs index d0bb165c3f..5a0a08973a 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -21,7 +21,8 @@ import Types.Key cmd :: Command cmd = withOptions annexedMatchingOptions $ mkCommand $ - command "find" paramPaths seek SectionQuery "lists available files" + command "find" SectionQuery "lists available files" + paramPaths (withParams seek) mkCommand :: Command -> Command mkCommand = noCommit . noMessages . withOptions [formatOption, print0Option, jsonOption] @@ -38,7 +39,7 @@ print0Option = Option [] ["print0"] (NoArg set) where set = Annex.setField (optionName formatOption) "${file}\0" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do format <- getFormat withFilesInGit (whenAnnexed $ start format) ps diff --git a/Command/FindRef.hs b/Command/FindRef.hs index 3f09cd6b31..cd7583b96f 100644 --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -12,10 +12,11 @@ import qualified Command.Find as Find cmd :: Command cmd = withOptions nonWorkTreeMatchingOptions $ Find.mkCommand $ - command "findref" paramRef seek SectionPlumbing + 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 6a27878e38..a5f385b4f4 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -20,9 +20,9 @@ import Utility.Touch cmd :: Command cmd = notDirect $ noCommit $ withOptions annexedMatchingOptions $ - command "fix" paramPaths - SectionMaintenance "fix up symlinks to point to annexed content" - (commandParser seek) + command "fix" SectionMaintenance + "fix up symlinks to point to annexed content" + paramPaths (withParams seek) seek :: CmdParams -> CommandSeek seek = withFilesInGit $ whenAnnexed start diff --git a/Command/Forget.hs b/Command/Forget.hs index 370dc8b1ee..24789fe44c 100644 --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -16,8 +16,10 @@ import qualified Annex import Data.Time.Clock.POSIX cmd :: Command -cmd = withOptions forgetOptions $ command "forget" paramNothing seek - SectionMaintenance "prune git-annex branch history" +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 78ebb6268a..6a3fe3a4aa 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -21,10 +21,11 @@ import Network.URI cmd :: Command cmd = notDirect $ notBareRepo $ - command "fromkey" (paramPair paramKey paramPath) seek - SectionPlumbing "adds a file using a specific key" + 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 177db6498d..29ef010328 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -41,8 +41,9 @@ import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) cmd :: Command -cmd = withOptions fsckOptions $ command "fsck" paramPaths seek - SectionMaintenance "check for problems" +cmd = withOptions fsckOptions $ + command "fsck" SectionMaintenance "check for problems" + paramPaths (withParams seek) fsckFromOption :: Option fsckFromOption = fieldOption ['f'] "from" paramRemote "check remote" @@ -65,7 +66,7 @@ fsckOptions = , incrementalScheduleOption ] ++ keyOptions ++ annexedMatchingOptions -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do from <- getOptionField fsckFromOption Remote.byNameWithUUID u <- maybe getUUID (pure . Remote.uuid) from diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index bc8cc11617..e15632c811 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -21,10 +21,12 @@ import Test.QuickCheck import Control.Concurrent cmd :: Command -cmd = notBareRepo $ command "fuzztest" paramNothing seek SectionTesting - "generates fuzz test files" +cmd = notBareRepo $ + command "fuzztest" SectionTesting + "generates fuzz test files" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs index e267aaf670..5c26866353 100644 --- a/Command/GCryptSetup.hs +++ b/Command/GCryptSetup.hs @@ -15,9 +15,9 @@ import qualified Git cmd :: Command cmd = dontCheck repoExists $ noCommit $ - command "gcryptsetup" paramValue - SectionPlumbing "sets up gcrypt repository" - (commandParser seek) + command "gcryptsetup" SectionPlumbing + "sets up gcrypt repository" + paramValue (withParams seek) seek :: CmdParams -> CommandSeek seek = withStrings start diff --git a/Command/Get.hs b/Command/Get.hs index f54e88b7ae..297f5d27b5 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -17,14 +17,16 @@ import Annex.Wanted import qualified Command.Move cmd :: Command -cmd = withOptions getOptions $ command "get" paramPaths seek - SectionCommon "make content of annexed files available" +cmd = withOptions getOptions $ + command "get" SectionCommon + "make content of annexed files available" + paramPaths (withParams seek) getOptions :: [Option] getOptions = fromOption : autoOption : jobsOption : annexedMatchingOptions ++ incompleteOption : keyOptions -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do from <- getOptionField fromOption Remote.byNameWithUUID auto <- getOptionFlag autoOption diff --git a/Command/Group.hs b/Command/Group.hs index 839d21a4c1..6543fa2fbb 100644 --- a/Command/Group.hs +++ b/Command/Group.hs @@ -16,10 +16,10 @@ 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 "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 f58544f6fa..0565344b19 100644 --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -13,10 +13,12 @@ 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 "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 b6b1be3794..08873e2bbb 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -23,9 +23,10 @@ import System.Console.GetOpt cmd :: Command cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "help" "COMMAND" seek SectionCommon "display help" + command "help" SectionCommon "display help" + "COMMAND" (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart @@ -47,7 +48,7 @@ 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 diff --git a/Command/Import.hs b/Command/Import.hs index 6bc330fcad..8d09f84789 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -23,8 +23,10 @@ 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 = withOptions opts $ notBareRepo $ + command "import" SectionCommon + "move and add files from outside git working copy" + paramPaths (withParams seek) opts :: [Option] opts = duplicateModeOptions ++ fileMatchingOptions @@ -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 4be84375ce..5e4869b306 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -45,13 +45,13 @@ import Annex.MetaData cmd :: Command cmd = notBareRepo $ withOptions [templateOption, relaxedOption, rawOption] $ - command "importfeed" (paramRepeating paramUrl) seek - SectionCommon "import files from podcast feeds" + 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 29d0750a59..c00f18ead6 100644 --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -12,9 +12,11 @@ import Command import Annex.Content cmd :: Command -cmd = noCommit $ command "inannex" (paramRepeating paramKey) - SectionPlumbing "checks if keys are present in the annex" - (commandParser seek) +cmd = noCommit $ + command "inannex" SectionPlumbing + "checks if keys are present in the annex" + (paramRepeating paramKey) + (withParams seek) seek :: CmdParams -> CommandSeek seek = withKeys start diff --git a/Command/Indirect.hs b/Command/Indirect.hs index 3e10988ed4..c12c91a484 100644 --- a/Command/Indirect.hs +++ b/Command/Indirect.hs @@ -24,10 +24,10 @@ import qualified Command.Add cmd :: Command cmd = notBareRepo $ noDaemonRunning $ - command "indirect" paramNothing seek - SectionSetup "switch repository to indirect mode" + 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 0c8200ff3e..3012d4649f 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -80,10 +80,11 @@ type StatState = StateT StatInfo Annex cmd :: Command cmd = noCommit $ dontCheck repoExists $ withOptions (jsonOption : bytesOption : annexedMatchingOptions) $ - command "info" (paramRepeating paramItem) seek SectionQuery - "shows information about the specified item or the repository as a whole" + 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 diff --git a/Command/Init.hs b/Command/Init.hs index 45ecb92f81..0f32f1ba1f 100644 --- a/Command/Init.hs +++ b/Command/Init.hs @@ -13,9 +13,10 @@ import Annex.Init cmd :: Command cmd = dontCheck repoExists $ - command "init" paramDesc seek SectionSetup "initialize git-annex" + 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 4bf5f5312c..a3a946944a 100644 --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -20,11 +20,12 @@ import Logs.Trust import Data.Ord cmd :: Command -cmd = command "initremote" +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 ba27da7021..723f53b46a 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -25,13 +25,14 @@ import Git.Types (RemoteName) cmd :: Command cmd = noCommit $ withOptions (allrepos : annexedMatchingOptions) $ - command "list" paramPaths seek - SectionQuery "show which remotes contain files" + 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 2d796ad4f9..04c8b94949 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -14,10 +14,11 @@ import qualified Annex cmd :: Command cmd = notDirect $ withOptions annexedMatchingOptions $ - command "lock" paramPaths seek SectionCommon - "undo unlock command" + 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 3d618360de..6f3967c6a7 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -40,7 +40,8 @@ type Outputter = Bool -> POSIXTime -> [UUID] -> Annex () cmd :: Command cmd = withOptions options $ - command "log" paramPaths seek SectionQuery "shows location log" + command "log" SectionQuery "shows location log" + paramPaths (withParams seek) options :: [Option] options = passthruOptions ++ [gourceOption] ++ annexedMatchingOptions @@ -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 9b7dd3a9bf..021dc963bc 100644 --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -15,10 +15,11 @@ import Types.Key cmd :: Command cmd = withOptions [batchOption] $ notBareRepo $ noCommit $ noMessages $ - command "lookupkey" (paramRepeating paramFile) seek - SectionPlumbing "looks up key used for file" + 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 4328139f1e..9550108090 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -27,10 +27,11 @@ data Link = Link Git.Repo Git.Repo cmd :: Command cmd = dontCheck repoExists $ - command "map" paramNothing seek SectionQuery + 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 b451db2afa..8ea4e79e46 100644 --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -14,10 +14,11 @@ import qualified Git.Branch import Command.Sync (prepMerge, mergeLocal) cmd :: Command -cmd = command "merge" paramNothing seek SectionMaintenance +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 d6adb0ad42..3b38c8b95d 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -18,8 +18,9 @@ import Data.Time.Clock.POSIX cmd :: Command cmd = withOptions metaDataOptions $ - command "metadata" paramPaths seek - SectionMetaData "sets or gets metadata of a file" + 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 d406dbea4d..80d42e87a6 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -20,10 +20,11 @@ import qualified Annex cmd :: Command cmd = notDirect $ withOptions annexedMatchingOptions $ - command "migrate" paramPaths seek - SectionUtility "switch data to different backend" + 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 8ae57da2fb..f0880e87ea 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -17,13 +17,15 @@ 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 = 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 739be44176..fc13ca2543 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -18,13 +18,15 @@ import Annex.Transfer import Logs.Presence cmd :: Command -cmd = withOptions moveOptions $ command "move" paramPaths seek - SectionCommon "move content of files to/from another repository" +cmd = withOptions moveOptions $ + command "move" SectionCommon + "move content of files to/from another repository" + paramPaths (withParams seek) moveOptions :: [Option] moveOptions = fromToOptions ++ [jobsOption] ++ keyOptions ++ annexedMatchingOptions -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do to <- getOptionField toOption Remote.byNameWithUUID from <- getOptionField fromOption Remote.byNameWithUUID diff --git a/Command/NotifyChanges.hs b/Command/NotifyChanges.hs index 55379440ce..0912083492 100644 --- a/Command/NotifyChanges.hs +++ b/Command/NotifyChanges.hs @@ -20,9 +20,10 @@ import Control.Concurrent.Async import Control.Concurrent.STM cmd :: Command -cmd = noCommit $ command "notifychanges" paramNothing SectionPlumbing - "sends notification when git refs are changed" - (commandParser seek) +cmd = noCommit $ + command "notifychanges" SectionPlumbing + "sends notification when git refs are changed" + paramNothing (withParams seek) seek :: CmdParams -> CommandSeek seek = withNothing start diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs index 33db1bbc9f..1a3dd3dad6 100644 --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -14,10 +14,11 @@ import Annex.NumCopies import Types.Messages cmd :: Command -cmd = command "numcopies" paramNumber seek - SectionSetup "configure desired number of copies" +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 4f1729394c..2d62b51f3f 100644 --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -29,9 +29,10 @@ import qualified Git.LsFiles as Git import qualified Data.Set as S cmd :: Command -cmd = command "pre-commit" paramPaths SectionPlumbing +cmd = command "pre-commit" SectionPlumbing "run by git pre-commit hook" - (commandParser seek) + paramPaths + (withParams seek) seek :: CmdParams -> CommandSeek seek ps = lockPreCommitHook $ ifM isDirect diff --git a/Command/Proxy.hs b/Command/Proxy.hs index cfb1f8ba31..3c487b9b56 100644 --- a/Command/Proxy.hs +++ b/Command/Proxy.hs @@ -19,10 +19,11 @@ import qualified Git.Branch cmd :: Command cmd = notBareRepo $ - command "proxy" ("-- git command") seek - SectionPlumbing "safely bypass direct mode guard" + 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 2a27878980..597be57a53 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -19,11 +19,13 @@ import Utility.CopyFile import qualified Remote cmd :: Command -cmd = notDirect $ command "rekey" - (paramRepeating $ paramPair paramPath paramKey) - seek SectionPlumbing "change keys used for files" +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 6eab893cf1..2b0b51fe35 100644 --- a/Command/ReadPresentKey.hs +++ b/Command/ReadPresentKey.hs @@ -13,10 +13,13 @@ 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 = 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 574963494f..a49efce2fa 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -21,9 +21,9 @@ import qualified Types.Backend import qualified Backend cmd :: Command -cmd = noCommit $ command "recvkey" paramKey - SectionPlumbing "runs rsync in server mode to receive content" - (commandParser seek) +cmd = noCommit $ command "recvkey" SectionPlumbing + "runs rsync in server mode to receive content" + paramKey (withParams seek) seek :: CmdParams -> CommandSeek seek = withKeys start diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs index bac5b77403..16489c0949 100644 --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -17,10 +17,12 @@ import Command.FromKey (mkKey) cmd :: Command cmd = notDirect $ notBareRepo $ - command "registerurl" (paramPair paramKey paramUrl) seek + command "registerurl" SectionPlumbing "registers an url for a key" + (paramPair paramKey paramUrl) + (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart diff --git a/Command/Reinit.hs b/Command/Reinit.hs index 948ed3131c..0d144e9451 100644 --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -14,12 +14,14 @@ import Annex.UUID import Types.UUID import qualified Remote -cmd :: [Command] +cmd :: Command cmd = dontCheck repoExists $ - command "reinit" (paramUUID ++ "|" ++ paramDesc) seek - SectionUtility "initialize repository, reusing old UUID" + 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 09511562fd..76e1420ffa 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 fdd9386133..962189da1a 100644 --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -12,10 +12,12 @@ import Command import RemoteDaemon.Core cmd :: Command -cmd = noCommit $ command "remotedaemon" paramNothing seek SectionPlumbing - "detects when remotes have changed, and fetches from them" +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 56d6969609..f4c92b02fe 100644 --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -18,9 +18,11 @@ import Annex.Version cmd :: Command cmd = noCommit $ dontCheck repoExists $ - command "repair" paramNothing seek SectionMaintenance "recover broken git repository" + command "repair" SectionMaintenance + "recover broken git repository" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs index 0ecf180b82..148ce9e5c1 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -15,10 +15,11 @@ import qualified Git.Branch import Annex.AutoMerge cmd :: Command -cmd = command "resolvemerge" paramNothing seek SectionPlumbing +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 2f95ef9932..d7e99587f1 100644 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -15,10 +15,12 @@ import qualified Remote cmd :: Command cmd = notBareRepo $ - command "rmurl" (paramPair paramFile paramUrl) seek - SectionCommon "record file is not available at url" + 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 723ade65bd..266208f9a7 100644 --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -18,10 +18,11 @@ 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 "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 3ef2621e03..d9ee893945 100644 --- a/Command/Semitrust.hs +++ b/Command/Semitrust.hs @@ -12,8 +12,9 @@ import Types.TrustLevel import Command.Trust (trustCommand) cmd :: Command -cmd = command "semitrust" (paramRepeating paramRemote) seek - SectionSetup "return repository to default trust level" +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 78d1f9c1c4..da7f99889b 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -17,9 +17,10 @@ import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered cmd :: Command -cmd = noCommit $ command "sendkey" paramKey - SectionPlumbing "runs rsync in server mode to send content" - (commandParser seek) +cmd = noCommit $ + command "sendkey" SectionPlumbing + "runs rsync in server mode to send content" + paramKey (withParams seek) seek :: CmdParams -> CommandSeek seek = withKeys start diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 4f7b5aaf59..d8216a0b42 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -14,10 +14,11 @@ import Annex.Content import Types.Key cmd :: Command -cmd = command "setkey" (paramPair paramKey paramPath) seek - SectionPlumbing "sets annexed content for a key" +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 cc2ebc1420..831a62883e 100644 --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -14,10 +14,13 @@ 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 = 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 248a0b84ba..c8aeaef0af 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -18,10 +18,11 @@ import qualified Git cmd :: Command cmd = notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $ - command "status" paramPaths seek SectionCommon + 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 95bd7c8d7a..2f7c4af7f2 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -53,8 +53,9 @@ import qualified Data.Map as M cmd :: Command cmd = withOptions syncOptions $ - command "sync" (paramRepeating paramRemote) - seek SectionCommon "synchronize local repository with remotes" + command "sync" SectionCommon + "synchronize local repository with remotes" + (paramRepeating paramRemote) (withParams seek) syncOptions :: [Option] syncOptions = @@ -69,7 +70,7 @@ contentOption = flagOption [] "content" "also transfer file contents" messageOption :: Option messageOption = fieldOption ['m'] "message" "MSG" "specify commit message" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek rs = do prepMerge diff --git a/Command/Test.hs b/Command/Test.hs index af02985af2..6f9c23d2d1 100644 --- a/Command/Test.hs +++ b/Command/Test.hs @@ -13,10 +13,11 @@ import Messages cmd :: Command cmd = noRepo startIO $ dontCheck repoExists $ - command "test" paramNothing seek SectionTesting + command "test" SectionTesting "run built-in test suite" + paramNothing (withParams seek) -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 cbd2edaf1f..250c6f41a2 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -38,13 +38,14 @@ import qualified Data.Map as M cmd :: Command cmd = withOptions [sizeOption] $ - command "testremote" paramRemote seek SectionTesting - "test transfers to/from a remote" + 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 44ffe59ad5..d102be55e0 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -16,9 +16,10 @@ import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered cmd :: Command -cmd = noCommit $ command "transferinfo" paramKey SectionPlumbing - "updates sender on number of bytes of content received" - (commandParser seek) +cmd = noCommit $ + command "transferinfo" SectionPlumbing + "updates sender on number of bytes of content received" + paramKey (withParams seek) seek :: CmdParams -> CommandSeek seek = withWords start diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index 6da2e742b6..de4568f3a9 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -16,9 +16,10 @@ import qualified Remote import Types.Remote cmd :: Command -cmd = withOptions transferKeyOptions $ - noCommit $ command "transferkey" paramKey seek SectionPlumbing +cmd = withOptions transferKeyOptions $ noCommit $ + command "transferkey" SectionPlumbing "transfers a key from or to a remote" + paramKey (withParams seek) transferKeyOptions :: [Option] transferKeyOptions = fileOption : fromToOptions @@ -26,7 +27,7 @@ transferKeyOptions = fileOption : fromToOptions fileOption :: Option fileOption = fieldOption [] "file" paramFile "the associated file" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do to <- getOptionField toOption Remote.byNameWithUUID from <- getOptionField fromOption Remote.byNameWithUUID diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index a151754df0..755a7ef3e6 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -22,10 +22,10 @@ import Git.Types (RemoteName) data TransferRequest = TransferRequest Direction Remote Key AssociatedFile cmd :: Command -cmd = command "transferkeys" paramNothing seek - SectionPlumbing "transfers keys" +cmd = command "transferkeys" SectionPlumbing "transfers keys" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing start start :: CommandStart diff --git a/Command/Trust.hs b/Command/Trust.hs index 6f3382c30d..33ecc2e64f 100644 --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -17,13 +17,13 @@ import Logs.Group import qualified Data.Set as S cmd :: Command -cmd = command "trust" (paramRepeating paramRemote) seek - SectionSetup "trust a repository" +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 83e9909217..ea814560f2 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -24,9 +24,9 @@ import Command.PreCommit (lockPreCommitHook) cmd :: Command cmd = withOptions annexedMatchingOptions $ - command "unannex" paramPaths SectionUtility + command "unannex" SectionUtility "undo accidential add command" - (commandParser seek) + paramPaths (withParams seek) seek :: CmdParams -> CommandSeek seek = wrapUnannex . (withFilesInGit $ whenAnnexed start) diff --git a/Command/Undo.hs b/Command/Undo.hs index 4740aab486..c647dfba4d 100644 --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -23,10 +23,11 @@ import qualified Command.Sync cmd :: Command cmd = notBareRepo $ - command "undo" paramPaths seek - SectionCommon "undo last change to a file or directory" + 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 b711a0132b..cd2ebdf9bf 100644 --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -16,10 +16,10 @@ 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 "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 64c5154647..c49cc4ba0e 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -22,9 +22,10 @@ import System.IO.HVFS import System.IO.HVFS.Utils cmd :: Command -cmd = addCheck check $ command "uninit" paramPaths - SectionUtility "de-initialize git-annex and clean out repository" - (commandParser seek) +cmd = addCheck check $ + command "uninit" SectionUtility + "de-initialize git-annex and clean out repository" + paramPaths (withParams seek) check :: Annex () check = do diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 98117f5b5a..36b0023d86 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -20,10 +20,10 @@ editcmd :: Command editcmd = mkcmd "edit" "same as unlock" mkcmd :: String -> String -> Command -mkcmd n = notDirect . withOptions annexedMatchingOptions - . command n paramPaths seek SectionCommon +mkcmd n d = notDirect $ withOptions annexedMatchingOptions $ + command n SectionCommon d paramPaths (withParams seek) -seek :: CommandSeek +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 220faf85e9..7f22a8086d 100644 --- a/Command/Untrust.hs +++ b/Command/Untrust.hs @@ -12,8 +12,8 @@ import Types.TrustLevel import Command.Trust (trustCommand) cmd :: Command -cmd = command "untrust" (paramRepeating paramRemote) seek - SectionSetup "do not trust a repository" +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 1f84f012f7..e6d5f7c715 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -36,9 +36,9 @@ import Annex.BloomFilter cmd :: Command cmd = withOptions [unusedFromOption, refSpecOption] $ - command "unused" paramNothing - SectionMaintenance "look for unused file content" - (commandParser seek) + command "unused" SectionMaintenance + "look for unused file content" + paramNothing (withParams seek) unusedFromOption :: Option unusedFromOption = fieldOption ['f'] "from" paramRemote "remote to check for unused content" @@ -268,7 +268,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 0fa9022ff0..c02a6709f9 100644 --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -13,10 +13,10 @@ import Upgrade cmd :: Command cmd = dontCheck repoExists $ -- because an old version may not seem to exist - command "upgrade" paramNothing seek - SectionMaintenance "upgrade repository layout" + 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 478eab098b..ac70da2649 100644 --- a/Command/VAdd.hs +++ b/Command/VAdd.hs @@ -13,10 +13,13 @@ 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 = 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 31a5f80c2b..a3c61d8591 100644 --- a/Command/VCycle.hs +++ b/Command/VCycle.hs @@ -16,10 +16,11 @@ import Command.View (checkoutViewBranch) cmd :: Command cmd = notBareRepo $ notDirect $ - command "vcycle" paramNothing seek SectionMetaData - "switch view to next layout" + 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 78f2d9d5c3..259d36068a 100644 --- a/Command/VFilter.hs +++ b/Command/VFilter.hs @@ -14,9 +14,10 @@ import Command.View (paramView, checkoutViewBranch) cmd :: Command cmd = notBareRepo $ notDirect $ - command "vfilter" paramView seek SectionMetaData "filter current view" + 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 0dadd52fb0..ba6f4ee5ca 100644 --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -18,10 +18,10 @@ import Command.View (checkoutViewBranch) cmd :: Command cmd = notBareRepo $ notDirect $ - command "vpop" paramNumber seek SectionMetaData - "switch back to previous view" + 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 3ceef3a60d..70aea8f2ca 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -20,12 +20,13 @@ import qualified Backend cmd :: Command cmd = withOptions [rawOption] $ noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "version" paramNothing seek SectionQuery "show version info" + command "version" SectionQuery "show version info" + paramNothing (withParams seek) rawOption :: Option rawOption = flagOption [] "raw" "output only program version" -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withNothing $ ifM (getOptionFlag rawOption) (startRaw, start) startRaw :: CommandStart diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 9b8177e770..677ba5b13a 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -30,10 +30,10 @@ import Types.ScheduledActivity import Remote cmd :: Command -cmd = command "vicfg" paramNothing seek - SectionSetup "edit git-annex's configuration" +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 584cf091f6..b39aef7d92 100644 --- a/Command/View.hs +++ b/Command/View.hs @@ -19,16 +19,17 @@ import Logs.View cmd :: Command cmd = notBareRepo $ notDirect $ - command "view" paramView seek SectionMetaData "enter a view branch" + 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 215595a525..649f19c2b0 100644 --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -28,7 +28,7 @@ cmd' -> Annex (M.Map UUID PreferredContentExpression) -> (UUID -> PreferredContentExpression -> Annex ()) -> Command -cmd' name desc getter setter = command name pdesc seek SectionSetup desc +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 0782a4e6e5..cc7356ddfe 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -14,9 +14,11 @@ import Utility.HumanTime cmd :: Command cmd = notBareRepo $ withOptions [foregroundOption, stopOption] $ - command "watch" paramNothing seek SectionCommon "watch for changes and autocommit" + 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 dab8e1e5bb..2a639e4892 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -40,13 +40,14 @@ import System.Environment (getArgs) cmd :: Command cmd = withOptions [listenOption] $ noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $ - command "webapp" paramNothing seek SectionCommon "launch webapp" + 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 54be0dd187..05bc706548 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -17,10 +17,11 @@ import Logs.Web cmd :: Command cmd = noCommit $ withOptions (jsonOption : annexedMatchingOptions ++ keyOptions) $ - command "whereis" paramPaths seek SectionQuery + command "whereis" SectionQuery "lists repositories that have file content" + paramPaths (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek ps = do m <- remoteMap id withKeyOptions False diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs index 86cae9ab73..7d7d99476d 100644 --- a/Command/XMPPGit.hs +++ b/Command/XMPPGit.hs @@ -13,10 +13,10 @@ import Assistant.XMPP.Git cmd :: Command cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "xmppgit" paramNothing seek - SectionPlumbing "git to XMPP relay" + command "xmppgit" SectionPlumbing "git to XMPP relay" + paramNothing (withParams seek) -seek :: CommandSeek +seek :: CmdParams -> CommandSeek seek = withWords start start :: [String] -> CommandStart From 92d8f80bffcd39e9357a469784e62d1289bd913c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 15:39:05 -0400 Subject: [PATCH 04/54] support cmdnorepo actions, also using getopt-applicative there --- CmdLine.hs | 45 +++++++++----------------------------------- CmdLine/Usage.hs | 8 -------- Command.hs | 17 +++++++++++++---- Command/Assistant.hs | 9 +++++---- Command/Help.hs | 9 ++++++--- Command/Test.hs | 6 ++++-- Command/Version.hs | 10 ++++++---- Command/WebApp.hs | 7 ++++--- Command/XMPPGit.hs | 9 ++++++--- Types/Command.hs | 2 +- 10 files changed, 54 insertions(+), 68 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index 2b9418d83f..82c9b42896 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -45,7 +45,7 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do inRepo $ autocorrect . Just forM_ fields $ uncurry Annex.setField (cmd, seek) <- liftIO $ - O.handleParseResult (parseCmd (name:args) allcmds) + O.handleParseResult (parseCmd (name:args) allcmds cmdparser) when (cmdnomessages cmd) $ Annex.setOutput QuietOutput -- TODO: propigate global options to annex state (how?) @@ -54,11 +54,12 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do startup performCommandAction cmd seek $ shutdown $ cmdnocommit cmd - go (Left e) = do + go (Left norepo) = do when fuzzy $ autocorrect =<< Git.Config.global - -- a <- O.handleParseResult (parseCmd (name:args) allcmds) - error "TODO" + let norepoparser = fromMaybe (throw norepo) . cmdnorepo + (_cmd, a) <- O.handleParseResult (parseCmd (name:args) allcmds norepoparser) + a autocorrect = Git.AutoCorrect.prepare inputcmdname cmdname cmds err msg = msg ++ "\n\n" ++ usage header allcmds @@ -69,44 +70,16 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do _ -> inputcmdname | otherwise = inputcmdname -#if 0 - 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 - where - go flags params (Right g) = do - state <- Annex.new g - Annex.eval state $ do - checkEnvironment - when fuzzy $ - inRepo $ autocorrect . Just - forM_ fields $ uncurry Annex.setField - when (cmdnomessages cmd) $ - Annex.setOutput QuietOutput - sequence_ flags - whenM (annexDebug <$> Annex.getGitConfig) $ - liftIO enableDebugOutput - startup - performCommandAction cmd params $ - shutdown $ cmdnocommit cmd - go _flags params (Left e) = do - when fuzzy $ - autocorrect =<< Git.Config.global - maybe (throw e) (\a -> a params) (cmdnorepo cmd) - cmd = Prelude.head cmds -#endif -{- Parses command line and selects a command to run and gets the - - seek action for the command. -} -parseCmd :: CmdParams -> [Command] -> O.ParserResult (Command, CommandSeek) -parseCmd allargs allcmds = O.execParserPure (O.prefs O.idm) pinfo allargs +{- Parses command line, selecting one of the commands from the list. -} +parseCmd :: CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v) +parseCmd allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs where pinfo = O.info (O.subparser $ mconcat $ map mkcommand allcmds) O.idm mkcommand c = O.command (cmdname c) (O.info (mkparser c) O.idm) mkparser c = (,) <$> pure c - <*> cmdparser c + <*> getparser c {- Parses command line params far enough to find the Command to run, and - returns the remaining params. diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs index 58408762b9..1355c43162 100644 --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -11,7 +11,6 @@ import Common.Annex import Types.Command import System.Console.GetOpt -import qualified Options.Applicative as O usageMessage :: String -> String usageMessage s = "Usage: " ++ s @@ -56,13 +55,6 @@ commandUsage cmd = unlines , "[option ...]" ] -{- Simple CommandParser generator, for when the CommandSeek wants all - - non-option parameters. -} -withParams :: (CmdParams -> CommandSeek) -> String -> CommandParser -withParams mkseek paramdesc = mkseek <$> O.many cmdparams - where - cmdparams = O.argument O.str (O.metavar paramdesc) - {- Descriptions of params used in usage messages. -} paramPaths :: String paramPaths = paramRepeating paramPath -- most often used diff --git a/Command.hs b/Command.hs index c1d788c799..ec8ffadd9f 100644 --- a/Command.hs +++ b/Command.hs @@ -7,6 +7,7 @@ module Command ( command, + withParams, noRepo, noCommit, noMessages, @@ -32,11 +33,19 @@ import CmdLine.Action as ReExported import CmdLine.Option as ReExported import CmdLine.GitAnnex.Options as ReExported +import qualified Options.Applicative as O + {- Generates a normal Command -} command :: String -> CommandSection -> String -> String -> (String -> CommandParser) -> Command command name section desc paramdesc mkparser = - Command [] Nothing commonChecks False False name paramdesc - section desc (mkparser paramdesc) + Command [] commonChecks False False name paramdesc + section desc (mkparser paramdesc) Nothing + +{- Option parser that takes all non-option params as-is. -} +withParams :: (CmdParams -> v) -> String -> O.Parser v +withParams mkseek paramdesc = mkseek <$> O.many cmdparams + where + cmdparams = O.argument O.str (O.metavar paramdesc) {- Indicates that a command doesn't need to commit any changes to - the git-annex branch. -} @@ -50,8 +59,8 @@ 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 diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 51d5a46b27..08e96da076 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -20,10 +20,11 @@ import Assistant.Install import System.Environment cmd :: Command -cmd = noRepo checkNoRepoOpts $ dontCheck repoExists $ withOptions options $ - notBareRepo $ command "assistant" SectionCommon - "automatically sync changes" - paramNothing (withParams seek) +cmd = dontCheck repoExists $ withOptions options $ notBareRepo $ + noRepo (withParams checkNoRepoOpts) $ + command "assistant" SectionCommon + "automatically sync changes" + paramNothing (withParams seek) options :: [Option] options = diff --git a/Command/Help.hs b/Command/Help.hs index 08873e2bbb..17ed8cd0b9 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -22,9 +22,12 @@ import qualified Command.Fsck import System.Console.GetOpt cmd :: Command -cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "help" SectionCommon "display help" - "COMMAND" (withParams seek) +cmd = noCommit $ dontCheck repoExists $ + noRepo (parseparams startNoRepo) $ + command "help" SectionCommon "display help" + "COMMAND" (parseparams seek) + where + parseparams = withParams seek :: CmdParams -> CommandSeek seek = withWords start diff --git a/Command/Test.hs b/Command/Test.hs index 6f9c23d2d1..57a9b16d30 100644 --- a/Command/Test.hs +++ b/Command/Test.hs @@ -12,10 +12,12 @@ import Command import Messages cmd :: Command -cmd = noRepo startIO $ dontCheck repoExists $ +cmd = noRepo (parseparams startIO) $ dontCheck repoExists $ command "test" SectionTesting "run built-in test suite" - paramNothing (withParams seek) + paramNothing (parseparams seek) + where + parseparams = withParams seek :: CmdParams -> CommandSeek seek = withWords start diff --git a/Command/Version.hs b/Command/Version.hs index 70aea8f2ca..38c7996755 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -18,10 +18,12 @@ import qualified Remote import qualified Backend cmd :: Command -cmd = withOptions [rawOption] $ - noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "version" SectionQuery "show version info" - paramNothing (withParams seek) +cmd = withOptions [rawOption] $ dontCheck repoExists $ noCommit $ + noRepo (parseparams startNoRepo) $ + command "version" SectionQuery "show version info" + paramNothing (parseparams seek) + where + parseparams = withParams rawOption :: Option rawOption = flagOption [] "raw" "output only program version" diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 2a639e4892..2e41ebe7df 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -39,9 +39,10 @@ import System.Environment (getArgs) cmd :: Command cmd = withOptions [listenOption] $ - noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $ - command "webapp" SectionCommon "launch webapp" - paramNothing (withParams seek) + noCommit $ dontCheck repoExists $ notBareRepo $ + noRepo (withParams startNoRepo) $ + command "webapp" SectionCommon "launch webapp" + paramNothing (withParams seek) listenOption :: Option listenOption = fieldOption [] "listen" paramAddress diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs index 7d7d99476d..86d8dbc112 100644 --- a/Command/XMPPGit.hs +++ b/Command/XMPPGit.hs @@ -12,9 +12,12 @@ import Command import Assistant.XMPP.Git cmd :: Command -cmd = noCommit $ noRepo startNoRepo $ dontCheck repoExists $ - command "xmppgit" SectionPlumbing "git to XMPP relay" - paramNothing (withParams seek) +cmd = noCommit $ dontCheck repoExists $ + noRepo (parseparams startNoRepo) $ + command "xmppgit" SectionPlumbing "git to XMPP relay" + paramNothing (parseparams seek) + where + parseparams = withParams seek :: CmdParams -> CommandSeek seek = withWords start diff --git a/Types/Command.hs b/Types/Command.hs index 4ab7220353..99920e6577 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -39,7 +39,6 @@ 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 , cmdnocommit :: Bool -- don't commit journalled state changes , cmdnomessages :: Bool -- don't output normal messages @@ -48,6 +47,7 @@ data Command = Command , 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 From 7d9072d1db01b11fa707b33dab1d01699213fd66 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 15:41:54 -0400 Subject: [PATCH 05/54] remove git-annex help options display Common options will be displayed in the --help for a command by optparse-applicative. --- Command/Help.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/Command/Help.hs b/Command/Help.hs index 17ed8cd0b9..0da7ecc464 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -19,8 +19,6 @@ import qualified Command.Sync import qualified Command.Whereis import qualified Command.Fsck -import System.Console.GetOpt - cmd :: Command cmd = noCommit $ dontCheck repoExists $ noRepo (parseparams startNoRepo) $ @@ -41,13 +39,9 @@ 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:" @@ -64,7 +58,6 @@ showGeneralHelp = putStrLn $ unlines ] , "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." ] where cmdline c = "\t" ++ cmdname c ++ "\t" ++ cmddesc c From b59b8be73743c2ce648686fee6c65db782ddbe48 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 16:08:26 -0400 Subject: [PATCH 06/54] generalize parseDuration so it can be used in the ReadM monad --- Utility/HumanTime.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs index e8fdb7c6e9..fe7cf22a9a 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 } From 6a88c7c1015bd08239d300c36f702bd970fe3fd5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 16:58:54 -0400 Subject: [PATCH 07/54] converted fsck's options to optparse-applicative Global options and seeking and key options are still to be done. --- CmdLine.hs | 9 ++++-- Command.hs | 24 ++++++++++----- Command/Fsck.hs | 80 +++++++++++++++++++++++++++--------------------- Types/Command.hs | 4 ++- 4 files changed, 72 insertions(+), 45 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index 82c9b42896..89f9964b76 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -75,8 +75,13 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do parseCmd :: CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v) parseCmd allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs where - pinfo = O.info (O.subparser $ mconcat $ map mkcommand allcmds) O.idm - mkcommand c = O.command (cmdname c) (O.info (mkparser c) O.idm) + pinfo = O.info (O.subparser $ mconcat $ map mkcommand allcmds) + ( O.fullDesc + <> O.progDesc "hiya" + <> O.header "ook - aaa" + ) + mkcommand c = O.command (cmdname c) $ O.info (mkparser c) + (O.fullDesc <> O.progDesc (cmddesc c)) mkparser c = (,) <$> pure c <*> getparser c diff --git a/Command.hs b/Command.hs index ec8ffadd9f..e72bd1660a 100644 --- a/Command.hs +++ b/Command.hs @@ -1,6 +1,6 @@ {- git-annex command infrastructure - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -8,6 +8,8 @@ module Command ( command, withParams, + cmdParams, + finalOpt, noRepo, noCommit, noMessages, @@ -36,16 +38,24 @@ import CmdLine.GitAnnex.Options as ReExported import qualified Options.Applicative as O {- Generates a normal Command -} -command :: String -> CommandSection -> String -> String -> (String -> CommandParser) -> 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 -{- Option parser that takes all non-option params as-is. -} -withParams :: (CmdParams -> v) -> String -> O.Parser v -withParams mkseek paramdesc = mkseek <$> O.many cmdparams - where - cmdparams = O.argument O.str (O.metavar paramdesc) +{- Simple option parser that takes all non-option params as-is. -} +withParams :: (CmdParams -> v) -> CmdParamsDesc -> O.Parser v +withParams mkseek paramdesc = mkseek <$> cmdParams paramdesc + +{- Parser that accepts all non-option params. -} +cmdParams :: CmdParamsDesc -> O.Parser CmdParams +cmdParams paramdesc = O.many (O.argument O.str (O.metavar paramdesc)) + +{- Makes an option parser that is normally required be optional; + - its switch can be given zero or more times, and the last one + - given will be used. -} +finalOpt :: O.Parser a -> O.Parser (Maybe a) +finalOpt = lastMaybe <$$> O.many {- Indicates that a command doesn't need to commit any changes to - the git-annex branch. -} diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 29ef010328..c2a819e9d8 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -39,42 +39,56 @@ import qualified Database.Fsck as FsckDb import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) +import Options.Applicative hiding (command) cmd :: Command -cmd = withOptions fsckOptions $ - command "fsck" SectionMaintenance "check for problems" - paramPaths (withParams seek) +cmd = command "fsck" SectionMaintenance "check for problems" + paramPaths (seek <$$> optParser) -fsckFromOption :: Option -fsckFromOption = fieldOption ['f'] "from" paramRemote "check remote" +data FsckOptions = FsckOptions + { fsckFiles :: CmdParams + , fsckFromOption :: Maybe String + , startIncrementalOption :: Bool + , moreIncrementalOption :: Bool + , incrementalScheduleOption :: Maybe Duration + } -startIncrementalOption :: Option -startIncrementalOption = flagOption ['S'] "incremental" "start an incremental fsck" +optParser :: CmdParamsDesc -> Parser FsckOptions +optParser desc = FsckOptions + <$> cmdParams desc + <*> finalOpt (strOption + ( long "from" + <> short 'f' + <> metavar paramRemote + <> help "check remote" + )) + <*> switch + ( long "incremental" + <> short 'S' + <> help "start an incremental fsck" + ) + <*> switch + ( long "more" + <> short 'm' + <> help "continue an incremental fsck" + ) + <*> finalOpt (option (str >>= parseDuration) + ( long "incremental-schedule" + <> metavar paramTime + <> help "schedule incremental fscking" + )) -moreIncrementalOption :: Option -moreIncrementalOption = flagOption ['m'] "more" "continue an incremental fsck" +-- TODO: keyOptions, annexedMatchingOptions -incrementalScheduleOption :: Option -incrementalScheduleOption = fieldOption [] "incremental-schedule" paramTime - "schedule incremental fscking" - -fsckOptions :: [Option] -fsckOptions = - [ fsckFromOption - , startIncrementalOption - , moreIncrementalOption - , incrementalScheduleOption - ] ++ keyOptions ++ annexedMatchingOptions - -seek :: CmdParams -> CommandSeek -seek ps = do - from <- getOptionField fsckFromOption Remote.byNameWithUUID +seek :: FsckOptions -> CommandSeek +seek o = do + from <- Remote.byNameWithUUID (fsckFromOption o) u <- maybe getUUID (pure . Remote.uuid) from - i <- getIncremental u + i <- getIncremental u o withKeyOptions False (\k -> startKey i k =<< getNumCopies) (withFilesInGit $ whenAnnexed $ start from i) - ps + (fsckFiles o) withFsckDb i FsckDb.closeDb void $ tryIO $ recordActivity Fsck u @@ -498,13 +512,10 @@ 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 +getIncremental :: UUID -> FsckOptions -> Annex Incremental +getIncremental u o = do + i <- maybe (return False) checkschedule (incrementalScheduleOption o) + case (i, startIncrementalOption o, moreIncrementalOption o) of (False, False, False) -> return NonIncremental (False, True, False) -> startIncremental (False ,False, True) -> contIncremental @@ -521,8 +532,7 @@ getIncremental u = do ) contIncremental = ContIncremental <$> FsckDb.openDb u - checkschedule Nothing = error "bad --incremental-schedule value" - checkschedule (Just delta) = do + checkschedule delta = do Annex.addCleanup FsckCleanup $ do v <- getStartTime u case v of diff --git a/Types/Command.hs b/Types/Command.hs index 99920e6577..acd662bf3f 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -43,7 +43,7 @@ data Command = Command , cmdnocommit :: Bool -- don't commit journalled state changes , cmdnomessages :: Bool -- don't output normal messages , cmdname :: String - , cmdparamdesc :: String -- description of params for usage + , cmdparamdesc :: CmdParamsDesc -- description of params for usage , cmdsection :: CommandSection , cmddesc :: String -- description of command for usage , cmdparser :: CommandParser -- command line parser @@ -54,6 +54,8 @@ data Command = Command - 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 From 60806dd19118720e1a450707122b4cebe90c6020 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 17:59:06 -0400 Subject: [PATCH 08/54] wip --- CmdLine/GitAnnex/Options.hs | 76 ++++++++++++++++++++++++------- CmdLine/Seek.hs | 29 ++++++------ Command.hs | 12 ----- Command/Drop.hs | 90 ++++++++++++++++++++++--------------- Command/Fsck.hs | 12 +++-- 5 files changed, 137 insertions(+), 82 deletions(-) diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 320268f6a5..1472a4d2b1 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 - @@ -8,6 +8,7 @@ module CmdLine.GitAnnex.Options where import System.Console.GetOpt +import Options.Applicative import Common.Annex import qualified Git.Config @@ -15,6 +16,8 @@ import Git.Types import Types.TrustLevel import Types.NumCopies import Types.Messages +import Types.Key +import Types.Command import qualified Annex import qualified Remote import qualified Limit @@ -51,24 +54,50 @@ gitAnnexOptions = commonOptions ++ >>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }) >>= Annex.changeGitRepo --- Options for matching on annexed keys, rather than work tree files. -keyOptions :: [Option] -keyOptions = [ allOption, unusedOption, keyOption] +-- Options for acting on keys, rather than work tree files. +data KeyOptions = KeyOptions + { wantAllKeys :: Bool + , wantUnusedKeys :: Bool + , wantIncompleteKeys :: Bool + , wantSpecificKey :: Maybe Key + } -allOption :: Option -allOption = Option ['A'] ["all"] (NoArg (Annex.setFlag "all")) - "operate on all versions of all files" +parseKeyOptions :: Bool -> Parser KeyOptions +parseKeyOptions allowincomplete = KeyOptions + <$> parseAllKeysOption + <*> parseUnusedKeysOption + <*> (if allowincomplete then parseIncompleteOption else pure False) + <*> parseSpecificKeyOption -unusedOption :: Option -unusedOption = Option ['U'] ["unused"] (NoArg (Annex.setFlag "unused")) - "operate on files found by last run of git-annex unused" +parseAllKeysOption :: Parser Bool +parseAllKeysOption = switch + ( long "all" + <> short 'A' + <> help "operate on all versions of all files" + ) -keyOption :: Option -keyOption = Option [] ["key"] (ReqArg (Annex.setField "key") paramKey) - "operate on specified key" +parseUnusedKeysOption :: Parser Bool +parseUnusedKeysOption = switch + ( long "unused" + <> short 'U' + <> help "operate on files found by last run of git-annex unused" + ) -incompleteOption :: Option -incompleteOption = flagOption [] "incomplete" "resume previous downloads" +parseSpecificKeyOption :: Parser (Maybe Key) +parseSpecificKeyOption = finalOpt $ option (str >>= parseKey) + ( long "key" + <> help "operate on specified key" + <> metavar paramKey + ) + +parseKey :: Monad m => String -> m Key +parseKey = maybe (fail "invalid key") return . file2key + +parseIncompleteOption :: Parser Bool +parseIncompleteOption = switch + ( long "incomplete" + <> help "resume previous downloads" + ) -- Options to match properties of annexed files. annexedMatchingOptions :: [Option] @@ -161,3 +190,20 @@ timeLimitOption = Option ['T'] ["time-limit"] autoOption :: Option autoOption = flagOption ['a'] "auto" "automatic mode" + +parseAutoOption :: Parser Bool +parseAutoOption = switch + ( long "auto" + <> short 'a' + <> help "automatic mode" + ) + +{- Parser that accepts all non-option params. -} +cmdParams :: CmdParamsDesc -> Parser CmdParams +cmdParams paramdesc = many (argument str (metavar paramdesc)) + +{- Makes an option parser that is normally required be optional; + - - its switch can be given zero or more times, and the last one + - - given will be used. -} +finalOpt :: Parser a -> Parser (Maybe a) +finalOpt = lastMaybe <$$> many diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 66f57e1b00..1d6708191a 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -23,6 +23,7 @@ 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 @@ -171,40 +172,38 @@ withNothing _ _ = error "This command takes no parameters." - - Otherwise falls back to a regular CommandSeek action on - whatever params were passed. -} -withKeyOptions :: Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek -withKeyOptions auto keyop = withKeyOptions' auto $ \getkeys -> do +withKeyOptions :: 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 ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek -withKeyOptions' auto keyop fallbackop params = do +withKeyOptions' :: 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" + let allkeys = wantAllKeys ko + let unused = wantUnusedKeys ko + let incomplete = wantIncompleteKeys ko + let specifickey = wantSpecificKey ko when (auto && bare) $ error "Cannot use --auto in a bare repository" case (allkeys, unused, incomplete, null params, specifickey) of (False , False , False , True , Nothing) | bare -> go auto loggedKeys - | otherwise -> fallbackop params - (False , False , False , _ , Nothing) -> fallbackop params + | otherwise -> fallbackaction params + (False , False , False , _ , Nothing) -> fallbackaction 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] + (False , False , False , True , Just k) -> go auto $ return [k] _ -> 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/Command.hs b/Command.hs index e72bd1660a..b272bba5da 100644 --- a/Command.hs +++ b/Command.hs @@ -8,8 +8,6 @@ module Command ( command, withParams, - cmdParams, - finalOpt, noRepo, noCommit, noMessages, @@ -47,16 +45,6 @@ command name section desc paramdesc mkparser = withParams :: (CmdParams -> v) -> CmdParamsDesc -> O.Parser v withParams mkseek paramdesc = mkseek <$> cmdParams paramdesc -{- Parser that accepts all non-option params. -} -cmdParams :: CmdParamsDesc -> O.Parser CmdParams -cmdParams paramdesc = O.many (O.argument O.str (O.metavar paramdesc)) - -{- Makes an option parser that is normally required be optional; - - its switch can be given zero or more times, and the last one - - given will be used. -} -finalOpt :: O.Parser a -> O.Parser (Maybe a) -finalOpt = lastMaybe <$$> O.many - {- Indicates that a command doesn't need to commit any changes to - the git-annex branch. -} noCommit :: Command -> Command diff --git a/Command/Drop.hs b/Command/Drop.hs index a93dac5952..b569491bbb 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -19,50 +19,68 @@ import Annex.NumCopies import Annex.Content import Annex.Wanted import Annex.Notification +import Git.Types (RemoteName) import qualified Data.Set as S +import Options.Applicative hiding (command) cmd :: Command -cmd = withOptions (dropOptions) $ - command "drop" SectionCommon - "indicate content of files not currently wanted" - paramPaths (withParams seek) +cmd = command "drop" SectionCommon + "indicate content of files not currently wanted" + paramPaths (seek <$$> optParser) -dropOptions :: [Option] -dropOptions = dropFromOption : annexedMatchingOptions ++ [autoOption] ++ keyOptions +data DropOptions = DropOptions + { dropFiles :: CmdParams + , dropFrom :: Maybe RemoteName + , autoMode :: Bool + , keyOptions :: KeyOptions + } -dropFromOption :: Option -dropFromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote" +-- TODO: annexedMatchingOptions -seek :: CmdParams -> CommandSeek -seek ps = do - from <- getOptionField dropFromOption Remote.byNameWithUUID - auto <- getOptionFlag autoOption - withKeyOptions auto - (startKeys auto from) - (withFilesInGit $ whenAnnexed $ start auto from) - ps +optParser :: CmdParamsDesc -> Parser DropOptions +optParser desc = DropOptions + <$> cmdParams desc + <*> parseDropFromOption + <*> parseAutoOption + <*> parseKeyOptions False -start :: Bool -> Maybe Remote -> FilePath -> Key -> CommandStart -start auto from file key = start' auto from key (Just file) +parseDropFromOption :: Parser (Maybe RemoteName) +parseDropFromOption = finalOpt $ strOption + ( long "from" + <> short 'f' + <> metavar paramRemote + <> help "drop content from a remote" + ) -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 +seek :: DropOptions -> CommandSeek +seek o = withKeyOptions (keyOptions o) (autoMode o) + (startKeys o) + (withFilesInGit $ whenAnnexed $ start o) + (dropFiles o) -startKeys :: Bool -> Maybe Remote -> Key -> CommandStart -startKeys auto from key = start' auto from key Nothing +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 <- Remote.byNameWithUUID (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 @@ -166,10 +184,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/Fsck.hs b/Command/Fsck.hs index c2a819e9d8..486b686d57 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -34,6 +34,7 @@ import Types.CleanupActions import Utility.HumanTime import Utility.CopyFile import Git.FilePath +import Git.Types (RemoteName) import Utility.PID import qualified Database.Fsck as FsckDb @@ -42,15 +43,17 @@ import System.Posix.Types (EpochTime) import Options.Applicative hiding (command) cmd :: Command -cmd = command "fsck" SectionMaintenance "check for problems" +cmd = command "fsck" SectionMaintenance + "find and fix problems" paramPaths (seek <$$> optParser) data FsckOptions = FsckOptions { fsckFiles :: CmdParams - , fsckFromOption :: Maybe String + , fsckFromOption :: Maybe RemoteName , startIncrementalOption :: Bool , moreIncrementalOption :: Bool , incrementalScheduleOption :: Maybe Duration + , keyOptions :: KeyOptions } optParser :: CmdParamsDesc -> Parser FsckOptions @@ -77,15 +80,16 @@ optParser desc = FsckOptions <> metavar paramTime <> help "schedule incremental fscking" )) + <*> parseKeyOptions False --- TODO: keyOptions, annexedMatchingOptions +-- TODO: annexedMatchingOptions seek :: FsckOptions -> CommandSeek seek o = do from <- Remote.byNameWithUUID (fsckFromOption o) u <- maybe getUUID (pure . Remote.uuid) from i <- getIncremental u o - withKeyOptions False + withKeyOptions (keyOptions o) False (\k -> startKey i k =<< getNumCopies) (withFilesInGit $ whenAnnexed $ start from i) (fsckFiles o) From 3332df2c526d0e1306b6730f0e93413656b799b2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 18:31:05 -0400 Subject: [PATCH 09/54] improve --help display for commands --- CmdLine.hs | 9 +++------ CmdLine/Usage.hs | 16 ---------------- 2 files changed, 3 insertions(+), 22 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index 89f9964b76..c61a0050cf 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -75,13 +75,10 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do parseCmd :: CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v) parseCmd allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs where - pinfo = O.info (O.subparser $ mconcat $ map mkcommand allcmds) - ( O.fullDesc - <> O.progDesc "hiya" - <> O.header "ook - aaa" - ) + pinfo = O.info (O.helper <*> subcmds) O.fullDesc + subcmds = O.subparser $ mconcat $ map mkcommand allcmds mkcommand c = O.command (cmdname c) $ O.info (mkparser c) - (O.fullDesc <> O.progDesc (cmddesc c)) + (O.fullDesc <> O.header (cmddesc c)) mkparser c = (,) <$> pure c <*> getparser c diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs index 1355c43162..0b1cade053 100644 --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -10,8 +10,6 @@ module CmdLine.Usage where import Common.Annex import Types.Command -import System.Console.GetOpt - usageMessage :: String -> String usageMessage s = "Usage: " ++ s @@ -41,20 +39,6 @@ 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 = paramRepeating paramPath -- most often used From 463709ab2ae27da6a4a09cb38957e5dcfc1e9e3c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 8 Jul 2015 19:38:56 -0400 Subject: [PATCH 10/54] improve autocorrection code so that --bash-completion-script etc will work git-annex --bash-completion-script git-annex will now work; before the command autocorrection would screw it up --- CmdLine.hs | 42 ++++++++++++++++++++++++------------------ 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index c61a0050cf..fd85248fbd 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -13,10 +13,10 @@ module CmdLine ( shutdown ) where +import qualified Options.Applicative as O import qualified Control.Exception as E import qualified Data.Map as M import Control.Exception (throw) -import qualified Options.Applicative as O #ifndef mingw32_HOST_OS import System.Posix.Signals #endif @@ -41,11 +41,9 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do state <- Annex.new g Annex.eval state $ do checkEnvironment - when fuzzy $ - inRepo $ autocorrect . Just forM_ fields $ uncurry Annex.setField - (cmd, seek) <- liftIO $ - O.handleParseResult (parseCmd (name:args) allcmds cmdparser) + (cmd, seek) <- parsewith cmdparser + (\a -> inRepo $ a . Just) when (cmdnomessages cmd) $ Annex.setOutput QuietOutput -- TODO: propigate global options to annex state (how?) @@ -55,21 +53,29 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do performCommandAction cmd seek $ shutdown $ cmdnocommit cmd go (Left norepo) = do - when fuzzy $ - autocorrect =<< Git.Config.global - let norepoparser = fromMaybe (throw norepo) . cmdnorepo - (_cmd, a) <- O.handleParseResult (parseCmd (name:args) allcmds norepoparser) + (_, a) <- parsewith + (fromMaybe (throw norepo) . cmdnorepo) + (\a -> a =<< Git.Config.global) a - autocorrect = Git.AutoCorrect.prepare inputcmdname cmdname cmds - err msg = msg ++ "\n\n" ++ usage header allcmds - (fuzzy, cmds, inputcmdname, args) = findCmd fuzzyok allargs allcmds err - name - | fuzzy = case cmds of - [c] -> cmdname c - _ -> inputcmdname - | otherwise = inputcmdname - + parsewith getparser ingitrepo = + case parseCmd 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 (name:args) allcmds getparser)) + res -> liftIO (O.handleParseResult res) + where + autocorrect = Git.AutoCorrect.prepare inputcmdname cmdname cmds + err msg = msg ++ "\n\n" ++ usage header allcmds + (fuzzy, cmds, inputcmdname, args) = findCmd fuzzyok allargs allcmds err + name + | fuzzy = case cmds of + (c:_) -> cmdname c + _ -> inputcmdname + | otherwise = inputcmdname {- Parses command line, selecting one of the commands from the list. -} parseCmd :: CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v) From d8d1499229c0317f0ecdea72c151a14ef3c8dc0e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 01:02:27 -0400 Subject: [PATCH 11/54] finalOpt is the same as optional --- CmdLine/GitAnnex/Options.hs | 8 +------- Command/Drop.hs | 2 +- Command/Fsck.hs | 4 ++-- 3 files changed, 4 insertions(+), 10 deletions(-) diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 1472a4d2b1..160c01a3a7 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -84,7 +84,7 @@ parseUnusedKeysOption = switch ) parseSpecificKeyOption :: Parser (Maybe Key) -parseSpecificKeyOption = finalOpt $ option (str >>= parseKey) +parseSpecificKeyOption = optional $ option (str >>= parseKey) ( long "key" <> help "operate on specified key" <> metavar paramKey @@ -201,9 +201,3 @@ parseAutoOption = switch {- Parser that accepts all non-option params. -} cmdParams :: CmdParamsDesc -> Parser CmdParams cmdParams paramdesc = many (argument str (metavar paramdesc)) - -{- Makes an option parser that is normally required be optional; - - - its switch can be given zero or more times, and the last one - - - given will be used. -} -finalOpt :: Parser a -> Parser (Maybe a) -finalOpt = lastMaybe <$$> many diff --git a/Command/Drop.hs b/Command/Drop.hs index b569491bbb..e246af3428 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -46,7 +46,7 @@ optParser desc = DropOptions <*> parseKeyOptions False parseDropFromOption :: Parser (Maybe RemoteName) -parseDropFromOption = finalOpt $ strOption +parseDropFromOption = optional $ strOption ( long "from" <> short 'f' <> metavar paramRemote diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 486b686d57..885ce17dd7 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -59,7 +59,7 @@ data FsckOptions = FsckOptions optParser :: CmdParamsDesc -> Parser FsckOptions optParser desc = FsckOptions <$> cmdParams desc - <*> finalOpt (strOption + <*> optional (strOption ( long "from" <> short 'f' <> metavar paramRemote @@ -75,7 +75,7 @@ optParser desc = FsckOptions <> short 'm' <> help "continue an incremental fsck" ) - <*> finalOpt (option (str >>= parseDuration) + <*> optional (option (str >>= parseDuration) ( long "incremental-schedule" <> metavar paramTime <> help "schedule incremental fscking" From bd9ed413ceb60cf606a648078f3b9ac48fd04a9e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 01:53:15 -0400 Subject: [PATCH 12/54] few more subcommand --help improvements --- CmdLine.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index fd85248fbd..b4e0ea0442 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -82,9 +82,9 @@ parseCmd :: CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult parseCmd allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs where pinfo = O.info (O.helper <*> subcmds) O.fullDesc - subcmds = O.subparser $ mconcat $ map mkcommand allcmds + subcmds = O.hsubparser $ mconcat $ map mkcommand allcmds mkcommand c = O.command (cmdname c) $ O.info (mkparser c) - (O.fullDesc <> O.header (cmddesc c)) + (O.fullDesc <> O.header (cmddesc c) <> O.progDesc (cmddesc c)) mkparser c = (,) <$> pure c <*> getparser c From d0cf4b2dd451ad84abc9d300a2c10eb734f557e9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 02:01:27 -0400 Subject: [PATCH 13/54] let bash completion complete files --- CmdLine/GitAnnex/Options.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 160c01a3a7..51c222d7d8 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -200,4 +200,8 @@ parseAutoOption = switch {- Parser that accepts all non-option params. -} cmdParams :: CmdParamsDesc -> Parser CmdParams -cmdParams paramdesc = many (argument str (metavar paramdesc)) +cmdParams paramdesc = many $ argument str + ( metavar paramdesc + -- Let bash completion complete files + <> action "file" + ) From c1c64ec76c9edfbca7d6ea9cb2e171eabdc7d029 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 10:41:17 -0400 Subject: [PATCH 14/54] formatting --- CmdLine/GitAnnex.hs | 8 ++++++-- CmdLine/GitAnnex/Options.hs | 12 ++++-------- Command/Drop.hs | 6 ++---- Command/Fsck.hs | 13 ++++--------- 4 files changed, 16 insertions(+), 23 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 8967bc4711..80ee876ff5 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -17,6 +17,8 @@ import Annex.Ssh import qualified Command.Add import qualified Command.Unannex +import qualified Command.Fsck +{- import qualified Command.Drop import qualified Command.Move import qualified Command.Copy @@ -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 @@ -116,10 +117,13 @@ import qualified Command.TestRemote #ifdef WITH_EKG import System.Remote.Monitoring #endif +-} cmds :: [Command] cmds = [ Command.Add.cmd + , Command.Fsck.cmd +{- , Command.Get.cmd , Command.Drop.cmd , Command.Move.cmd @@ -176,7 +180,6 @@ cmds = , Command.VPop.cmd , Command.VCycle.cmd , Command.Fix.cmd - , Command.Fsck.cmd , Command.Expire.cmd , Command.Repair.cmd , Command.Unused.cmd @@ -218,6 +221,7 @@ cmds = , Command.FuzzTest.cmd , Command.TestRemote.cmd #endif +-} ] header :: String diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 51c222d7d8..f95ab08ff1 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -71,23 +71,20 @@ parseKeyOptions allowincomplete = KeyOptions parseAllKeysOption :: Parser Bool parseAllKeysOption = switch - ( long "all" - <> short 'A' + ( long "all" <> short 'A' <> help "operate on all versions of all files" ) parseUnusedKeysOption :: Parser Bool parseUnusedKeysOption = switch - ( long "unused" - <> short 'U' + ( long "unused" <> short 'U' <> help "operate on files found by last run of git-annex unused" ) parseSpecificKeyOption :: Parser (Maybe Key) parseSpecificKeyOption = optional $ option (str >>= parseKey) - ( long "key" + ( long "key" <> metavar paramKey <> help "operate on specified key" - <> metavar paramKey ) parseKey :: Monad m => String -> m Key @@ -193,8 +190,7 @@ autoOption = flagOption ['a'] "auto" "automatic mode" parseAutoOption :: Parser Bool parseAutoOption = switch - ( long "auto" - <> short 'a' + ( long "auto" <> short 'a' <> help "automatic mode" ) diff --git a/Command/Drop.hs b/Command/Drop.hs index e246af3428..3f4ea1a9dc 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -47,10 +47,8 @@ optParser desc = DropOptions parseDropFromOption :: Parser (Maybe RemoteName) parseDropFromOption = optional $ strOption - ( long "from" - <> short 'f' - <> metavar paramRemote - <> help "drop content from a remote" + ( long "from" <> short 'f' <> metavar paramRemote + <> help "drop content from a remote" ) seek :: DropOptions -> CommandSeek diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 885ce17dd7..5350a63ebd 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -60,24 +60,19 @@ optParser :: CmdParamsDesc -> Parser FsckOptions optParser desc = FsckOptions <$> cmdParams desc <*> optional (strOption - ( long "from" - <> short 'f' - <> metavar paramRemote + ( long "from" <> short 'f' <> metavar paramRemote <> help "check remote" )) <*> switch - ( long "incremental" - <> short 'S' + ( long "incremental" <> short 'S' <> help "start an incremental fsck" ) <*> switch - ( long "more" - <> short 'm' + ( long "more" <> short 'm' <> help "continue an incremental fsck" ) <*> optional (option (str >>= parseDuration) - ( long "incremental-schedule" - <> metavar paramTime + ( long "incremental-schedule" <> metavar paramTime <> help "schedule incremental fscking" )) <*> parseKeyOptions False From e646051574950932d3ec875d6447e502179a781d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 10:58:38 -0400 Subject: [PATCH 15/54] update fsck synopsis --- doc/git-annex-fsck.mdwn | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/git-annex-fsck.mdwn b/doc/git-annex-fsck.mdwn index 1b1c0121b6..73c401eb35 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 From 6204dcbd7b6a4ac7479b902e80299af2cb08350a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 11:22:37 -0400 Subject: [PATCH 16/54] fix formatting of git-annex(1) synopsis --- Build/mdwn2man | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Build/mdwn2man b/Build/mdwn2man index 87094069f6..171218db03 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; From 8a9d2a6e9d15626afbc6f4a85c753f377d69c229 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 11:49:52 -0400 Subject: [PATCH 17/54] let optparse-applicative handle the usage display when run w/o command or bad command Still generating the list of commands myself, to get it sorted into sections and with short synopses. --- CmdLine.hs | 45 +++++++++++++++++++++++----------------- CmdLine/GitAnnex.hs | 11 +++++----- CmdLine/GitAnnexShell.hs | 4 +++- CmdLine/Usage.hs | 8 +++++-- Command/Help.hs | 4 ++-- 5 files changed, 42 insertions(+), 30 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index b4e0ea0442..5114bc9843 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -14,6 +14,7 @@ module CmdLine ( ) 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) @@ -32,8 +33,8 @@ 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] -> [Option] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () +dispatch fuzzyok allargs allcmds commonoptions fields getgitrepo progname progdesc = do setupConsole go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) where @@ -59,46 +60,52 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do a parsewith getparser ingitrepo = - case parseCmd allargs allcmds getparser of + case parseCmd progname progdesc 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 (name:args) allcmds getparser)) + liftIO (O.handleParseResult (parseCmd progname progdesc correctedargs allcmds getparser)) res -> liftIO (O.handleParseResult res) where - autocorrect = Git.AutoCorrect.prepare inputcmdname cmdname cmds - err msg = msg ++ "\n\n" ++ usage header allcmds - (fuzzy, cmds, inputcmdname, args) = findCmd fuzzyok allargs allcmds err + autocorrect = Git.AutoCorrect.prepare (fromJust inputcmdname) cmdname cmds + (fuzzy, cmds, inputcmdname, args) = findCmd fuzzyok allargs allcmds name | fuzzy = case cmds of - (c:_) -> cmdname c + (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 :: CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v) -parseCmd allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs +parseCmd :: String -> String -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v) +parseCmd progname progdesc allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs where - pinfo = O.info (O.helper <*> subcmds) O.fullDesc + 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 (cmddesc c) <> O.progDesc (cmddesc c)) + 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 + 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 diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 80ee876ff5..5e37a885a7 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -19,6 +19,7 @@ import qualified Command.Add import qualified Command.Unannex import qualified Command.Fsck {- +import qualified Command.Help import qualified Command.Drop import qualified Command.Move import qualified Command.Copy @@ -97,7 +98,6 @@ import qualified Command.Proxy import qualified Command.DiffDriver import qualified Command.Undo import qualified Command.Version -import qualified Command.Help #ifdef WITH_ASSISTANT import qualified Command.Watch import qualified Command.Assistant @@ -124,6 +124,7 @@ cmds = [ Command.Add.cmd , Command.Fsck.cmd {- + , Command.Help.cmd , Command.Get.cmd , Command.Drop.cmd , Command.Move.cmd @@ -204,7 +205,6 @@ cmds = , Command.DiffDriver.cmd , Command.Undo.cmd , Command.Version.cmd - , Command.Help.cmd #ifdef WITH_ASSISTANT , Command.Watch.cmd , Command.Assistant.cmd @@ -224,9 +224,6 @@ cmds = -} ] -header :: String -header = "git-annex command [option ...]" - run :: [String] -> IO () run args = do #ifdef WITH_EKG @@ -234,7 +231,9 @@ run args = do #endif go envmodes where - go [] = dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get + go [] = dispatch True args cmds gitAnnexOptions [] 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/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index fca37790b6..bda4f79072 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -101,7 +101,9 @@ builtin cmd dir params = do let (params', fieldparams, opts) = partitionParams params rsyncopts = ("RsyncOptions", unwords opts) fields = rsyncopts : filter checkField (parseFields fieldparams) - dispatch False (cmd : params') cmds options fields header mkrepo + dispatch False (cmd : params') cmds options fields mkrepo + "git-annex-shell" + "Restricted login shell for git-annex only SSH access" where mkrepo = do r <- Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs index 0b1cade053..a6cc90a719 100644 --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -13,9 +13,12 @@ import Types.Command 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 = [] @@ -39,6 +42,7 @@ usage header cmds = unlines $ usageMessage header : concatMap go [minBound..] longest f = foldl max 0 $ map (length . f) cmds scmds = sort cmds + {- Descriptions of params used in usage messages. -} paramPaths :: String paramPaths = paramRepeating paramPath -- most often used diff --git a/Command/Help.hs b/Command/Help.hs index 0da7ecc464..a44dcb234f 100644 --- a/Command/Help.hs +++ b/Command/Help.hs @@ -56,8 +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." + , "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 From 94e703e8b81e706d4852f987e690213c1681b2b6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 12:26:25 -0400 Subject: [PATCH 18/54] use Alternative when parsing mutually exclusive fsck options --- Command/Fsck.hs | 91 ++++++++++++++++++++++++------------------------- 1 file changed, 45 insertions(+), 46 deletions(-) diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 5350a63ebd..9ca859d95d 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -50,12 +50,15 @@ cmd = command "fsck" SectionMaintenance data FsckOptions = FsckOptions { fsckFiles :: CmdParams , fsckFromOption :: Maybe RemoteName - , startIncrementalOption :: Bool - , moreIncrementalOption :: Bool - , incrementalScheduleOption :: Maybe Duration + , incrementalOpt :: Maybe IncrementalOpt , keyOptions :: KeyOptions } +data IncrementalOpt + = StartIncrementalO + | MoreIncrementalO + | ScheduleIncrementalO Duration + optParser :: CmdParamsDesc -> Parser FsckOptions optParser desc = FsckOptions <$> cmdParams desc @@ -63,19 +66,22 @@ optParser desc = FsckOptions ( long "from" <> short 'f' <> metavar paramRemote <> help "check remote" )) - <*> switch - ( long "incremental" <> short 'S' - <> help "start an incremental fsck" - ) - <*> switch - ( long "more" <> short 'm' - <> help "continue an incremental fsck" - ) - <*> optional (option (str >>= parseDuration) - ( long "incremental-schedule" <> metavar paramTime - <> help "schedule incremental fscking" - )) + <*> optional parseincremental <*> 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" + )) -- TODO: annexedMatchingOptions @@ -83,7 +89,7 @@ seek :: FsckOptions -> CommandSeek seek o = do from <- Remote.byNameWithUUID (fsckFromOption o) u <- maybe getUUID (pure . Remote.uuid) from - i <- getIncremental u o + i <- prepIncremental u (incrementalOpt o) withKeyOptions (keyOptions o) False (\k -> startKey i k =<< getNumCopies) (withFilesInGit $ whenAnnexed $ start from i) @@ -511,33 +517,26 @@ getStartTime u = do data Incremental = StartIncremental FsckDb.FsckHandle | ContIncremental FsckDb.FsckHandle | NonIncremental -getIncremental :: UUID -> FsckOptions -> Annex Incremental -getIncremental u o = do - i <- maybe (return False) checkschedule (incrementalScheduleOption o) - case (i, startIncrementalOption o, moreIncrementalOption o) 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 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 From 032e6485fab2849fb47d1a27b1e3db80f142cfe0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 12:44:03 -0400 Subject: [PATCH 19/54] use Alternative for parsing KeyOptions --- CmdLine/GitAnnex/Options.hs | 61 ++++++++++++++++--------------------- CmdLine/Seek.hs | 24 ++++++--------- Command/Fsck.hs | 4 +-- 3 files changed, 38 insertions(+), 51 deletions(-) diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index f95ab08ff1..02cbcdcfe8 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -55,47 +55,38 @@ gitAnnexOptions = commonOptions ++ >>= Annex.changeGitRepo -- Options for acting on keys, rather than work tree files. -data KeyOptions = KeyOptions - { wantAllKeys :: Bool - , wantUnusedKeys :: Bool - , wantIncompleteKeys :: Bool - , wantSpecificKey :: Maybe Key - } +data KeyOptions + = WantAllKeys + | WantUnusedKeys + | WantSpecificKey Key + | WantIncompleteKeys parseKeyOptions :: Bool -> Parser KeyOptions -parseKeyOptions allowincomplete = KeyOptions - <$> parseAllKeysOption - <*> parseUnusedKeysOption - <*> (if allowincomplete then parseIncompleteOption else pure False) - <*> parseSpecificKeyOption - -parseAllKeysOption :: Parser Bool -parseAllKeysOption = switch - ( long "all" <> short 'A' - <> help "operate on all versions of all files" - ) - -parseUnusedKeysOption :: Parser Bool -parseUnusedKeysOption = switch - ( long "unused" <> short 'U' - <> help "operate on files found by last run of git-annex unused" - ) - -parseSpecificKeyOption :: Parser (Maybe Key) -parseSpecificKeyOption = optional $ option (str >>= parseKey) - ( long "key" <> metavar paramKey - <> help "operate on specified key" - ) +parseKeyOptions allowincomplete = if allowincomplete + then base + <|> flag' WantIncompleteKeys + ( long "incomplete" + <> help "resume previous downloads" + ) + else base + where + base = + flag' WantAllKeys + ( long "all" <> short 'A' + <> help "operate on all versions of all files" + ) + <|> 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" + )) parseKey :: Monad m => String -> m Key parseKey = maybe (fail "invalid key") return . file2key -parseIncompleteOption :: Parser Bool -parseIncompleteOption = switch - ( long "incomplete" - <> help "resume previous downloads" - ) - -- Options to match properties of annexed files. annexedMatchingOptions :: [Option] annexedMatchingOptions = concat diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 1d6708191a..b40e0d17aa 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -172,7 +172,7 @@ withNothing _ _ = error "This command takes no parameters." - - Otherwise falls back to a regular CommandSeek action on - whatever params were passed. -} -withKeyOptions :: KeyOptions -> Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek +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 @@ -182,25 +182,21 @@ withKeyOptions ko auto keyaction = withKeyOptions' ko auto $ \getkeys -> do , return Nothing ) -withKeyOptions' :: KeyOptions -> Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek +withKeyOptions' :: Maybe KeyOptions -> Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek withKeyOptions' ko auto keyaction fallbackaction params = do bare <- fromRepo Git.repoIsLocalBare - let allkeys = wantAllKeys ko - let unused = wantUnusedKeys ko - let incomplete = wantIncompleteKeys ko - let specifickey = wantSpecificKey ko 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 -> fallbackaction params - (False , False , False , _ , Nothing) -> fallbackaction 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 k) -> go auto $ return [k] - _ -> error "Can only specify one of file names, --all, --unused, --key, or --incomplete" + (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 = keyaction getkeys diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 9ca859d95d..09a3a82c99 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -51,7 +51,7 @@ data FsckOptions = FsckOptions { fsckFiles :: CmdParams , fsckFromOption :: Maybe RemoteName , incrementalOpt :: Maybe IncrementalOpt - , keyOptions :: KeyOptions + , keyOptions :: Maybe KeyOptions } data IncrementalOpt @@ -67,7 +67,7 @@ optParser desc = FsckOptions <> help "check remote" )) <*> optional parseincremental - <*> parseKeyOptions False + <*> optional (parseKeyOptions False) where parseincremental = flag' StartIncrementalO From 8ad927dbc687c99371de9c9ceec40b316bbb611a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 15:23:14 -0400 Subject: [PATCH 20/54] converted copy and move Got a little tricky.. --- CmdLine/GitAnnex.hs | 14 +++----- CmdLine/GitAnnex/Options.hs | 59 ++++++++++++++++++++++++++----- Command.hs | 1 + Command/Copy.hs | 53 ++++++++++++++++------------ Command/Drop.hs | 16 ++++----- Command/Fsck.hs | 1 - Command/Move.hs | 69 +++++++++++++++++++++---------------- Command/TransferInfo.hs | 4 +-- 8 files changed, 136 insertions(+), 81 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 5e37a885a7..fc323a49ba 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -15,15 +15,14 @@ import Command import Utility.Env import Annex.Ssh +import qualified Command.Help import qualified Command.Add import qualified Command.Unannex -import qualified Command.Fsck -{- -import qualified Command.Help import qualified Command.Drop import qualified Command.Move import qualified Command.Copy import qualified Command.Get +import qualified Command.Fsck import qualified Command.LookupKey import qualified Command.ContentLocation import qualified Command.ExamineKey @@ -117,18 +116,16 @@ import qualified Command.TestRemote #ifdef WITH_EKG import System.Remote.Monitoring #endif --} cmds :: [Command] cmds = - [ Command.Add.cmd - , Command.Fsck.cmd -{- - , Command.Help.cmd + [ 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 @@ -221,7 +218,6 @@ cmds = , Command.FuzzTest.cmd , Command.TestRemote.cmd #endif --} ] run :: [String] -> IO () diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 02cbcdcfe8..fb1b81acf9 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE FlexibleInstances #-} + module CmdLine.GitAnnex.Options where import System.Console.GetOpt @@ -54,6 +56,54 @@ gitAnnexOptions = commonOptions ++ >>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }) >>= Annex.changeGitRepo +-- 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 + +parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote) +parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p + +data FromToOptions + = FromRemote (DeferredParse Remote) + | ToRemote (DeferredParse Remote) + +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 @@ -150,15 +200,6 @@ combiningOptions = 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" - -fromToOptions :: [Option] -fromToOptions = [fromOption, toOption] - jsonOption :: Option jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput)) "enable JSON output" diff --git a/Command.hs b/Command.hs index b272bba5da..e3508d68c5 100644 --- a/Command.hs +++ b/Command.hs @@ -32,6 +32,7 @@ import CmdLine.Usage as ReExported import CmdLine.Action as ReExported import CmdLine.Option as ReExported import CmdLine.GitAnnex.Options as ReExported +import Options.Applicative as ReExported hiding (command) import qualified Options.Applicative as O diff --git a/Command/Copy.hs b/Command/Copy.hs index 26ff8e2630..a4f157e2fb 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -15,34 +15,43 @@ import Annex.Wanted import Annex.NumCopies cmd :: Command -cmd = withOptions copyOptions $ - command "copy" SectionCommon - "copy content of files to/from another repository" - paramPaths (withParams seek) +cmd = command "copy" SectionCommon + "copy content of files to/from another repository" + paramPaths ((seek <=< finishParse) <$$> optParser) -copyOptions :: [Option] -copyOptions = Command.Move.moveOptions ++ [autoOption] +data CopyOptions = CopyOptions + { moveOptions :: Command.Move.MoveOptions + , autoMode :: Bool + } -seek :: CmdParams -> 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 +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/Drop.hs b/Command/Drop.hs index 3f4ea1a9dc..1c595b6c21 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -19,10 +19,8 @@ import Annex.NumCopies import Annex.Content import Annex.Wanted import Annex.Notification -import Git.Types (RemoteName) import qualified Data.Set as S -import Options.Applicative hiding (command) cmd :: Command cmd = command "drop" SectionCommon @@ -31,9 +29,9 @@ cmd = command "drop" SectionCommon data DropOptions = DropOptions { dropFiles :: CmdParams - , dropFrom :: Maybe RemoteName + , dropFrom :: Maybe (DeferredParse Remote) , autoMode :: Bool - , keyOptions :: KeyOptions + , keyOptions :: Maybe KeyOptions } -- TODO: annexedMatchingOptions @@ -41,12 +39,12 @@ data DropOptions = DropOptions optParser :: CmdParamsDesc -> Parser DropOptions optParser desc = DropOptions <$> cmdParams desc - <*> parseDropFromOption + <*> optional parseDropFromOption <*> parseAutoOption - <*> parseKeyOptions False + <*> optional (parseKeyOptions False) -parseDropFromOption :: Parser (Maybe RemoteName) -parseDropFromOption = optional $ strOption +parseDropFromOption :: Parser (DeferredParse Remote) +parseDropFromOption = parseRemoteOption $ strOption ( long "from" <> short 'f' <> metavar paramRemote <> help "drop content from a remote" ) @@ -62,7 +60,7 @@ start o file key = start' o key (Just file) start' :: DropOptions -> Key -> AssociatedFile -> CommandStart start' o key afile = do - from <- Remote.byNameWithUUID (dropFrom o) + from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o) checkDropAuto (autoMode o) from afile key $ \numcopies -> stopUnless (want from) $ case from of diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 09a3a82c99..dbeeefbcdc 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -40,7 +40,6 @@ import qualified Database.Fsck as FsckDb import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) -import Options.Applicative hiding (command) cmd :: Command cmd = command "fsck" SectionMaintenance diff --git a/Command/Move.hs b/Command/Move.hs index fc13ca2543..153114f8b6 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -18,36 +18,47 @@ import Annex.Transfer import Logs.Presence cmd :: Command -cmd = withOptions moveOptions $ - command "move" SectionCommon - "move content of files to/from another repository" - paramPaths (withParams seek) +cmd = command "move" SectionCommon + "move content of files to/from another repository" + paramPaths ((seek <=< finishParse) <$$> optParser) -moveOptions :: [Option] -moveOptions = fromToOptions ++ [jobsOption] ++ keyOptions ++ annexedMatchingOptions +data MoveOptions = MoveOptions + { moveFiles :: CmdParams + , fromToOptions :: FromToOptions + , keyOptions :: Maybe KeyOptions + } -seek :: CmdParams -> 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 +-- TODO: jobsOption, annexedMatchingOptions -start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> Key -> CommandStart -start to from move = start' to from move . Just +optParser :: CmdParamsDesc -> Parser MoveOptions +optParser desc = MoveOptions + <$> cmdParams desc + <*> parseFromToOptions + <*> optional (parseKeyOptions False) -startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart -startKey to from move = start' to from move Nothing +instance DeferredParseClass MoveOptions where + finishParse v = MoveOptions + <$> pure (moveFiles v) + <*> finishParse (fromToOptions v) + <*> pure (keyOptions v) -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" +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") @@ -61,8 +72,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 @@ -124,8 +135,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/TransferInfo.hs b/Command/TransferInfo.hs index d102be55e0..2b5713d77a 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -49,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 From a7f58634b8aebaf653bd59f44abb62ea37e7d5e1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 16:05:45 -0400 Subject: [PATCH 21/54] wip --- CmdLine/GitAnnex.hs | 28 +++++++++++----------- Command.hs | 12 ++++++++++ Command/Copy.hs | 2 +- Command/Fsck.hs | 11 ++++----- Command/FuzzTest.hs | 6 ++--- Command/Get.hs | 44 +++++++++++++++++++++------------- Command/Info.hs | 4 ++-- Command/Move.hs | 2 +- Command/TransferKey.hs | 53 ++++++++++++++++++++++++----------------- Command/TransferKeys.hs | 8 +++---- Command/Version.hs | 18 +++++++------- 11 files changed, 109 insertions(+), 79 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index fc323a49ba..c42ba2a2d9 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -36,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 @@ -50,8 +50,8 @@ import qualified Command.InitRemote import qualified Command.EnableRemote import qualified Command.Expire import qualified Command.Repair -import qualified Command.Unused -import qualified Command.DropUnused +--import qualified Command.Unused +--import qualified Command.DropUnused import qualified Command.AddUnused import qualified Command.Unlock import qualified Command.Lock @@ -59,7 +59,7 @@ import qualified Command.PreCommit import qualified Command.Find import qualified Command.FindRef import qualified Command.Whereis -import qualified Command.List +--import qualified Command.List import qualified Command.Log import qualified Command.Merge import qualified Command.ResolveMerge @@ -72,16 +72,16 @@ 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.Mirror import qualified Command.AddUrl #ifdef WITH_FEED import qualified Command.ImportFeed @@ -130,7 +130,7 @@ cmds = , Command.Unlock.editcmd , Command.Lock.cmd , Command.Sync.cmd - , Command.Mirror.cmd +-- , Command.Mirror.cmd , Command.AddUrl.cmd #ifdef WITH_FEED , Command.ImportFeed.cmd @@ -150,14 +150,14 @@ cmds = , 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.Vicfg.cmd , Command.LookupKey.cmd , Command.ContentLocation.cmd , Command.ExamineKey.cmd @@ -171,7 +171,7 @@ cmds = , Command.ReadPresentKey.cmd , Command.CheckPresentKey.cmd , Command.ReKey.cmd - , Command.MetaData.cmd +-- , Command.MetaData.cmd , Command.View.cmd , Command.VAdd.cmd , Command.VFilter.cmd @@ -180,13 +180,13 @@ cmds = , Command.Fix.cmd , Command.Expire.cmd , Command.Repair.cmd - , Command.Unused.cmd - , Command.DropUnused.cmd +-- , Command.Unused.cmd +-- , Command.DropUnused.cmd , Command.AddUnused.cmd , Command.Find.cmd , Command.FindRef.cmd , Command.Whereis.cmd - , Command.List.cmd +-- , Command.List.cmd , Command.Log.cmd , Command.Merge.cmd , Command.ResolveMerge.cmd diff --git a/Command.hs b/Command.hs index e3508d68c5..df72ad2a71 100644 --- a/Command.hs +++ b/Command.hs @@ -8,6 +8,7 @@ module Command ( command, withParams, + (<--<), noRepo, noCommit, noMessages, @@ -46,6 +47,17 @@ command name section desc paramdesc mkparser = 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. -} noCommit :: Command -> Command diff --git a/Command/Copy.hs b/Command/Copy.hs index a4f157e2fb..1c817f67c4 100644 --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -17,7 +17,7 @@ import Annex.NumCopies cmd :: Command cmd = command "copy" SectionCommon "copy content of files to/from another repository" - paramPaths ((seek <=< finishParse) <$$> optParser) + paramPaths (seek <--< optParser) data CopyOptions = CopyOptions { moveOptions :: Command.Move.MoveOptions diff --git a/Command/Fsck.hs b/Command/Fsck.hs index dbeeefbcdc..0c5251ecb4 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -34,7 +34,6 @@ import Types.CleanupActions import Utility.HumanTime import Utility.CopyFile import Git.FilePath -import Git.Types (RemoteName) import Utility.PID import qualified Database.Fsck as FsckDb @@ -48,11 +47,13 @@ cmd = command "fsck" SectionMaintenance data FsckOptions = FsckOptions { fsckFiles :: CmdParams - , fsckFromOption :: Maybe RemoteName + , fsckFromOption :: Maybe (DeferredParse Remote) , incrementalOpt :: Maybe IncrementalOpt , keyOptions :: Maybe KeyOptions } +-- TODO: annexedMatchingOptions + data IncrementalOpt = StartIncrementalO | MoreIncrementalO @@ -61,7 +62,7 @@ data IncrementalOpt optParser :: CmdParamsDesc -> Parser FsckOptions optParser desc = FsckOptions <$> cmdParams desc - <*> optional (strOption + <*> optional (parseRemoteOption $ strOption ( long "from" <> short 'f' <> metavar paramRemote <> help "check remote" )) @@ -82,11 +83,9 @@ optParser desc = FsckOptions <> help "schedule incremental fscking" )) --- TODO: annexedMatchingOptions - seek :: FsckOptions -> CommandSeek seek o = do - from <- Remote.byNameWithUUID (fsckFromOption o) + from <- maybe (pure Nothing) (Just <$$> getParsed) (fsckFromOption o) u <- maybe getUUID (pure . Remote.uuid) from i <- prepIncremental u (incrementalOpt o) withKeyOptions (keyOptions o) False diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index e15632c811..fd888e0dff 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -55,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/Get.hs b/Command/Get.hs index 297f5d27b5..3af09b642d 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -17,29 +17,39 @@ import Annex.Wanted import qualified Command.Move cmd :: Command -cmd = withOptions getOptions $ - command "get" SectionCommon - "make content of annexed files available" - paramPaths (withParams seek) +cmd = 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 :: CmdParams -> 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) + +-- TODO: jobsOption, annexedMatchingOptions + +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/Info.hs b/Command/Info.hs index 3012d4649f..9b9e8f6ca9 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -135,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/Move.hs b/Command/Move.hs index 153114f8b6..087ea0a7bf 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -20,7 +20,7 @@ import Logs.Presence cmd :: Command cmd = command "move" SectionCommon "move content of files to/from another repository" - paramPaths ((seek <=< finishParse) <$$> optParser) + paramPaths (seek <--< optParser) data MoveOptions = MoveOptions { moveFiles :: CmdParams diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index de4568f3a9..04dbc1799b 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -16,41 +16,50 @@ import qualified Remote import Types.Remote cmd :: Command -cmd = withOptions transferKeyOptions $ noCommit $ +cmd = noCommit $ command "transferkey" SectionPlumbing "transfers a key from or to a remote" - paramKey (withParams seek) + paramKey (seek <--< optParser) -transferKeyOptions :: [Option] -transferKeyOptions = fileOption : fromToOptions +data TransferKeyOptions = TransferKeyOptions + { keyOptions :: CmdParams + , fromToOptions :: FromToOptions + , fileOption :: AssociatedFile + } -fileOption :: Option -fileOption = fieldOption [] "file" paramFile "the associated file" +optParser :: CmdParamsDesc -> Parser TransferKeyOptions +optParser desc = TransferKeyOptions + <$> cmdParams desc + <*> parseFromToOptions + <*> optional (strOption + ( long "file" <> metavar paramFile + <> help "the associated file" + )) -seek :: CmdParams -> CommandSeek -seek ps = do - to <- getOptionField toOption Remote.byNameWithUUID - from <- getOptionField fromOption Remote.byNameWithUUID - file <- getOptionField fileOption return - withKeys (start to from file) ps +instance DeferredParseClass TransferKeyOptions where + finishParse v = TransferKeyOptions + <$> pure (keyOptions v) + <*> finishParse (fromToOptions v) + <*> pure (fileOption v) -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" +seek :: TransferKeyOptions -> CommandSeek +seek o = withKeys (start o) (keyOptions o) -toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform -toPerform remote key file = go Upload file $ +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 755a7ef3e6..67f201024c 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -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/Version.hs b/Command/Version.hs index 38c7996755..9896f671e2 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -44,9 +44,9 @@ start = do 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 @@ -55,10 +55,10 @@ 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 -info :: String -> String -> IO () -info k v = putStrLn $ k ++ ": " ++ v +vinfo :: String -> String -> IO () +vinfo k v = putStrLn $ k ++ ": " ++ v From e59ba5a70b6d008afae4f9cfaea7e2495a870937 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 16:20:30 -0400 Subject: [PATCH 22/54] refactor --- CmdLine/GitAnnex/Options.hs | 23 +---------------------- Command.hs | 1 + Types/DeferredParse.hs | 33 +++++++++++++++++++++++++++++++++ 3 files changed, 35 insertions(+), 22 deletions(-) create mode 100644 Types/DeferredParse.hs diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index fb1b81acf9..c027c602cc 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -5,8 +5,6 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE FlexibleInstances #-} - module CmdLine.GitAnnex.Options where import System.Console.GetOpt @@ -20,6 +18,7 @@ import Types.NumCopies import Types.Messages import Types.Key import Types.Command +import Types.DeferredParse import qualified Annex import qualified Remote import qualified Limit @@ -56,26 +55,6 @@ gitAnnexOptions = commonOptions ++ >>= pure . (\r -> r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] }) >>= Annex.changeGitRepo --- 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 - parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote) parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p diff --git a/Command.hs b/Command.hs index df72ad2a71..019a657aa0 100644 --- a/Command.hs +++ b/Command.hs @@ -27,6 +27,7 @@ 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 diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs new file mode 100644 index 0000000000..2f463de353 --- /dev/null +++ b/Types/DeferredParse.hs @@ -0,0 +1,33 @@ +{- git-annex deferred parse values + - + - Copyright 2015 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE FlexibleInstances #-} + +module Types.DeferredParse where + +import Annex +import Common + +-- 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 From 820b92ababfd27300b001de40fab3a853c472508 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 9 Jul 2015 19:03:21 -0400 Subject: [PATCH 23/54] wip Current status: * building again, but several commands are commented out * still need to implement global options, file matching options, etc --- CmdLine/GitAnnex.hs | 34 ++++++++--------- CmdLine/GitAnnex/Options.hs | 74 +++++++++++++++++++------------------ CmdLine/GitAnnexShell.hs | 15 ++++---- Command/Drop.hs | 2 +- Command/Sync.hs | 71 +++++++++++++++++++---------------- Command/Unused.hs | 10 ++--- Command/Whereis.hs | 8 ++++ Types/DeferredParse.hs | 17 +++++++++ doc/git-annex-drop.mdwn | 2 +- 9 files changed, 133 insertions(+), 100 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index c42ba2a2d9..2e9bc537f2 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -15,7 +15,7 @@ import Command import Utility.Env import Annex.Ssh -import qualified Command.Help +--import qualified Command.Help import qualified Command.Add import qualified Command.Unannex import qualified Command.Drop @@ -25,7 +25,7 @@ import qualified Command.Get import qualified Command.Fsck import qualified Command.LookupKey import qualified Command.ContentLocation -import qualified Command.ExamineKey +--import qualified Command.ExamineKey import qualified Command.FromKey import qualified Command.RegisterUrl import qualified Command.SetKey @@ -56,15 +56,15 @@ import qualified Command.AddUnused import qualified Command.Unlock import qualified Command.Lock import qualified Command.PreCommit -import qualified Command.Find -import qualified Command.FindRef -import qualified Command.Whereis +--import qualified Command.Find +--import qualified Command.FindRef +--import qualified Command.Whereis --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 @@ -95,7 +95,7 @@ import qualified Command.Upgrade import qualified Command.Forget import qualified Command.Proxy import qualified Command.DiffDriver -import qualified Command.Undo +--import qualified Command.Undo import qualified Command.Version #ifdef WITH_ASSISTANT import qualified Command.Watch @@ -119,8 +119,8 @@ import System.Remote.Monitoring cmds :: [Command] cmds = - [ Command.Help.cmd - , Command.Add.cmd +-- [ Command.Help.cmd + [ Command.Add.cmd , Command.Get.cmd , Command.Drop.cmd , Command.Move.cmd @@ -160,7 +160,7 @@ cmds = -- , Command.Vicfg.cmd , Command.LookupKey.cmd , Command.ContentLocation.cmd - , Command.ExamineKey.cmd +-- , Command.ExamineKey.cmd , Command.FromKey.cmd , Command.RegisterUrl.cmd , Command.SetKey.cmd @@ -183,15 +183,15 @@ cmds = -- , Command.Unused.cmd -- , Command.DropUnused.cmd , Command.AddUnused.cmd - , Command.Find.cmd - , Command.FindRef.cmd - , Command.Whereis.cmd +-- , Command.Find.cmd +-- , Command.FindRef.cmd +-- , Command.Whereis.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 @@ -200,7 +200,7 @@ cmds = , Command.Forget.cmd , Command.Proxy.cmd , Command.DiffDriver.cmd - , Command.Undo.cmd +-- , Command.Undo.cmd , Command.Version.cmd #ifdef WITH_ASSISTANT , Command.Watch.cmd diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index c027c602cc..4ec7bc8753 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -99,11 +99,7 @@ parseKeyOptions allowincomplete = if allowincomplete ) else base where - base = - flag' WantAllKeys - ( long "all" <> short 'A' - <> help "operate on all versions of all files" - ) + base = parseAllOption <|> flag' WantUnusedKeys ( long "unused" <> short 'U' <> help "operate on files found by last run of git-annex unused" @@ -113,6 +109,12 @@ parseKeyOptions allowincomplete = if allowincomplete <> 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 @@ -121,13 +123,13 @@ annexedMatchingOptions :: [Option] annexedMatchingOptions = concat [ nonWorkTreeMatchingOptions' , fileMatchingOptions' - , combiningOptions - , [timeLimitOption] + -- , combiningOptions + -- , [timeLimitOption] ] -- Matching options that don't need to examine work tree files. nonWorkTreeMatchingOptions :: [Option] -nonWorkTreeMatchingOptions = nonWorkTreeMatchingOptions' ++ combiningOptions +nonWorkTreeMatchingOptions = nonWorkTreeMatchingOptions' -- ++ combiningOptions nonWorkTreeMatchingOptions' :: [Option] nonWorkTreeMatchingOptions' = @@ -153,7 +155,7 @@ nonWorkTreeMatchingOptions' = -- Options to match files which may not yet be annexed. fileMatchingOptions :: [Option] -fileMatchingOptions = fileMatchingOptions' ++ combiningOptions +fileMatchingOptions = fileMatchingOptions' -- ++ combiningOptions fileMatchingOptions' :: [Option] fileMatchingOptions' = @@ -167,37 +169,37 @@ fileMatchingOptions' = "match files smaller than a size" ] -combiningOptions :: [Option] -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" - ] +parseCombiningOptions :: Parser [GlobalSetter] +parseCombiningOptions = + many $ 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" where - longopt o = Option [] [o] $ NoArg $ Limit.addToken o - shortopt o = Option o [] $ NoArg $ Limit.addToken o + longopt o h = globalOpt (Limit.addToken o) $ switch + ( long o <> help h ) + shortopt o h = globalOpt (Limit.addToken [o]) $ switch + ( short o <> help h) -jsonOption :: Option -jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput)) - "enable JSON output" +parseJsonOption :: Parser GlobalSetter +parseJsonOption = globalOpt (Annex.setOutput JSONOutput) $ switch + ( long "json" <> short 'j' + <> help "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) +parseJobsOption :: Parser GlobalSetter +parseJobsOption = globalSetter (Annex.setOutput . ParallelOutput) $ + option auto + ( long "jobs" <> short 'J' <> metavar paramNumber + <> help "enable concurrent jobs" + ) -timeLimitOption :: Option -timeLimitOption = Option ['T'] ["time-limit"] - (ReqArg Limit.addTimeLimit paramTime) - "stop after the specified amount of time" - -autoOption :: Option -autoOption = flagOption ['a'] "auto" "automatic mode" +parseTimeLimitOption :: Parser GlobalSetter +parseTimeLimitOption = globalSetter Limit.addTimeLimit $ strOption + ( long "time-limit" <> short 'T' <> metavar paramTime + <> help "stop after the specified amount of time" + ) parseAutoOption :: Parser Bool parseAutoOption = switch diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index bda4f79072..386780addc 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -73,9 +73,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 @@ -142,14 +139,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" diff --git a/Command/Drop.hs b/Command/Drop.hs index 1c595b6c21..7141cbc484 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -24,7 +24,7 @@ import qualified Data.Set as S cmd :: Command cmd = command "drop" SectionCommon - "indicate content of files not currently wanted" + "remove content of files from repository" paramPaths (seek <$$> optParser) data DropOptions = DropOptions diff --git a/Command/Sync.hs b/Command/Sync.hs index 2f7c4af7f2..a5b601076a 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -52,26 +52,32 @@ import Control.Concurrent.MVar import qualified Data.Map as M cmd :: Command -cmd = withOptions syncOptions $ - command "sync" SectionCommon - "synchronize local repository with remotes" - (paramRepeating paramRemote) (withParams seek) +cmd = command "sync" SectionCommon + "synchronize local repository with remotes" + (paramRepeating paramRemote) (seek <$$> optParser) -syncOptions :: [Option] -syncOptions = - [ contentOption - , messageOption - , allOption - ] +data SyncOptions = SyncOptions + { syncWith :: CmdParams + , contentOption :: Bool + , messageOption :: Maybe String + , keyOptions :: Maybe KeyOptions + } -contentOption :: Option -contentOption = flagOption [] "content" "also transfer file contents" +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 -messageOption :: Option -messageOption = fieldOption ['m'] "message" "MSG" "specify commit message" - -seek :: CmdParams -> CommandSeek -seek rs = do +seek :: SyncOptions -> CommandSeek +seek o = do prepMerge -- There may not be a branch checked out until after the commit, @@ -90,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 @@ -151,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 @@ -372,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/Unused.hs b/Command/Unused.hs index e6d5f7c715..4649485c2b 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -57,13 +57,13 @@ start = do !refspec <- maybe cfgrefspec (either error id . parseRefSpec) <$> Annex.getField (optionName refSpecOption) from <- Annex.getField (optionName unusedFromOption) - let (name, action) = case from of + let (name, perform) = case from 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 @@ -127,11 +127,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 diff --git a/Command/Whereis.hs b/Command/Whereis.hs index 05bc706548..fb28daa22a 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -21,6 +21,14 @@ cmd = noCommit $ withOptions (jsonOption : annexedMatchingOptions ++ keyOptions) "lists repositories that have file content" paramPaths (withParams seek) +data WhereisOptions = WhereisOptions + { whereisFiles :: CmdParams + , jsonOption :: GlobalSetter + , keyOptions :: Maybe KeyOptions + } + +-- TODO: annexedMatchingOptions + seek :: CmdParams -> CommandSeek seek ps = do m <- remoteMap id diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs index 2f463de353..4b5ee6d59b 100644 --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -12,6 +12,8 @@ module Types.DeferredParse where import Annex import Common +import Options.Applicative.Types + -- 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. @@ -31,3 +33,18 @@ instance DeferredParseClass (DeferredParse a) where 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 () + +globalOpt :: Annex () -> Parser Bool -> Parser GlobalSetter +globalOpt setter parser = go <$> parser + where + go False = ReadyParse () + go True = DeferredParse setter + +globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter +globalSetter setter parser = DeferredParse . setter <$> parser diff --git a/doc/git-annex-drop.mdwn b/doc/git-annex-drop.mdwn index 813cce6aa4..a3a79f8d7b 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 From adb9fddfdde9505088dced62d14e450ceed575b0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 00:55:53 -0400 Subject: [PATCH 24/54] convert global options (still not used) --- CmdLine.hs | 4 +-- CmdLine/GitAnnex.hs | 2 +- CmdLine/GitAnnex/Options.hs | 72 +++++++++++++++++++++++-------------- CmdLine/GitAnnexShell.hs | 11 +++--- CmdLine/Option.hs | 68 ++++++++++++++++++++--------------- Types/DeferredParse.hs | 13 +++---- 6 files changed, 102 insertions(+), 68 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index 5114bc9843..7d90a25ce2 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -33,8 +33,8 @@ import Command import Types.Messages {- Runs the passed command line. -} -dispatch :: Bool -> CmdParams -> [Command] -> [Option] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () -dispatch fuzzyok allargs allcmds commonoptions fields getgitrepo progname progdesc = do +dispatch :: Bool -> CmdParams -> [Command] -> Parser GlobalSetter -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () +dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progdesc = do setupConsole go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) where diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 2e9bc537f2..32a4b8b10d 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -227,7 +227,7 @@ run args = do #endif go envmodes where - go [] = dispatch True args cmds gitAnnexOptions [] 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 diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 4ec7bc8753..8bc96a14d0 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -19,6 +19,7 @@ import Types.Messages import Types.Key import Types.Command import Types.DeferredParse +import Types.DesktopNotify import qualified Annex import qualified Remote import qualified Limit @@ -26,34 +27,55 @@ import qualified Limit.Wanted import CmdLine.Option import CmdLine.Usage --- 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 :: Parser GlobalSetter +gitAnnexGlobalOptions = globalSetters + [ commonGlobalOptions + , globalSetter setnumcopies $ option auto + ( long "numcopies" <> short 'N' <> metavar paramNumber + <> help "override default number of copies" + ) + , globalSetter (Remote.forceTrust Trusted) $ strOption + ( long "trust" <> metavar paramRemote + <> help "override trust setting" + ) + , globalSetter (Remote.forceTrust SemiTrusted) $ strOption + ( long "semitrust" <> metavar paramRemote + <> help "override trust setting back to default" + ) + , globalSetter (Remote.forceTrust UnTrusted) $ strOption + ( long "untrust" <> metavar paramRemote + <> help "override trust setting to untrusted" + ) + , globalSetter setgitconfig $ strOption + ( long "config" <> short 'c' <> metavar "NAME=VALUE" + <> help "override git configuration setting" + ) + , globalSetter setuseragent $ strOption + ( long "user-agent" <> metavar paramName + <> help "override default User-Agent" + ) + , globalFlag (Annex.setFlag "trustglacier") + ( long "trust-glacier" + <> help "Trust Amazon Glacier inventory" + ) + , globalFlag (setdesktopnotify mkNotifyFinish) + ( long "notify-finish" + <> help "show desktop notification after transfer finishes" + ) + , globalFlag (setdesktopnotify mkNotifyStart) + ( long "notify-start" + <> help "show desktop notification after transfer completes" + ) ] 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 } parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote) parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p @@ -177,13 +199,11 @@ parseCombiningOptions = <|> shortopt '(' "open group of options" <|> shortopt ')' "close group of options" where - longopt o h = globalOpt (Limit.addToken o) $ switch - ( long o <> help h ) - shortopt o h = globalOpt (Limit.addToken [o]) $ switch - ( short o <> help h) + longopt o h = globalFlag (Limit.addToken o) ( long o <> help h ) + shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h) parseJsonOption :: Parser GlobalSetter -parseJsonOption = globalOpt (Annex.setOutput JSONOutput) $ switch +parseJsonOption = globalFlag (Annex.setOutput JSONOutput) ( long "json" <> short 'j' <> help "enable JSON output" ) diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index 386780addc..5bc297a710 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -8,7 +8,6 @@ module CmdLine.GitAnnexShell where import System.Environment -import System.Console.GetOpt import Common.Annex import qualified Git.Construct @@ -54,9 +53,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" +options :: Parser GlobalSetter +options = globalSetters + [ commonGlobalOptions + , globalSetter checkUUID $ strOption + ( long "uuid" <> metavar paramUUID + <> help "local repository uuid" + ) ] where checkUUID expected = getUUID >>= check diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs index 0cda34ba1d..9cb1d41d4b 100644 --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -6,7 +6,7 @@ -} module CmdLine.Option ( - commonOptions, + commonGlobalOptions, flagOption, fieldOption, optionName, @@ -15,35 +15,46 @@ module CmdLine.Option ( OptDescr(..), ) where +import Options.Applicative import System.Console.GetOpt import Common.Annex +import CmdLine.Usage import qualified Annex import Types.Messages -import Types.DesktopNotify -import CmdLine.Usage +import Types.DeferredParse --- 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" +-- Global options accepted by both git-annex and git-annex-shell sub-commands. +commonGlobalOptions :: Parser GlobalSetter +commonGlobalOptions = globalSetters + [ globalFlag (setforce True) + ( long "force" + <> help "allow actions that may lose annexed data" + ) + , globalFlag (setfast True) + ( long "fast" <> short 'F' + <> help "avoid slow operations" + ) + , globalFlag (Annex.setOutput QuietOutput) + ( long "quiet" <> short 'q' + <> help "avoid verbose output" + ) + , globalFlag (Annex.setOutput NormalOutput) + ( long "verbose" <> short 'v' + <> help "allow verbose output (default)" + ) + , globalFlag setdebug + ( long "debug" <> short 'd' + <> help "show debug messages" + ) + , globalFlag unsetdebug + ( long "no-debug" + <> help "don't show debug messages" + ) + , globalSetter setforcebackend $ strOption + ( long "backend" <> short 'b' <> metavar paramName + <> help "specify key-value backend to use" + ) ] where setforce v = Annex.changeState $ \s -> s { Annex.force = v } @@ -51,17 +62,16 @@ 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 +flagOption shortv opt description = + Option shortv [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 +fieldOption shortv opt paramdesc description = + Option shortv [opt] (ReqArg (Annex.setField opt) paramdesc) description {- The flag or field name used for an option. -} optionName :: Option -> String diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs index 4b5ee6d59b..4c6e90175f 100644 --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -12,7 +12,7 @@ module Types.DeferredParse where import Annex import Common -import Options.Applicative.Types +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 @@ -40,11 +40,12 @@ instance DeferredParseClass [DeferredParse a] where -- Use when the Annex action modifies Annex state. type GlobalSetter = DeferredParse () -globalOpt :: Annex () -> Parser Bool -> Parser GlobalSetter -globalOpt setter parser = go <$> parser - where - go False = ReadyParse () - go True = DeferredParse setter +globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> Parser GlobalSetter +globalFlag setter = flag' (DeferredParse setter) globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter globalSetter setter parser = DeferredParse . setter <$> parser + +globalSetters :: [Parser GlobalSetter] -> Parser GlobalSetter +globalSetters l = DeferredParse . sequence_ . map getParsed + <$> many (foldl1 (<|>) l) From b66a2d6c5bf5ca90705025dc8d15380f050013a9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 02:03:03 -0400 Subject: [PATCH 25/54] wired up global options Note that I ran into a problem where parsing the global options looped forever, eating memory. It was somehow caused by stacking combineGlobalSetters inside a combineGlobalSetters. Maybe due to both using "many"? Anyway, changed things to avoid that. --- CmdLine.hs | 21 ++++++++++++--------- CmdLine/GitAnnex/Options.hs | 7 +++---- CmdLine/GitAnnexShell.hs | 13 ++++++------- CmdLine/Option.hs | 4 ++-- Types/DeferredParse.hs | 4 ++-- 5 files changed, 25 insertions(+), 24 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index 7d90a25ce2..e19b54de7e 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -33,7 +33,7 @@ import Command import Types.Messages {- Runs the passed command line. -} -dispatch :: Bool -> CmdParams -> [Command] -> Parser GlobalSetter -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () +dispatch :: Bool -> CmdParams -> [Command] -> [Parser GlobalSetter] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progdesc = do setupConsole go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) @@ -43,30 +43,30 @@ dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progde Annex.eval state $ do checkEnvironment forM_ fields $ uncurry Annex.setField - (cmd, seek) <- parsewith cmdparser + ((cmd, seek), globalconfig) <- parsewith cmdparser (\a -> inRepo $ a . Just) when (cmdnomessages cmd) $ Annex.setOutput QuietOutput - -- TODO: propigate global options to annex state (how?) + getParsed globalconfig whenM (annexDebug <$> Annex.getGitConfig) $ liftIO enableDebugOutput startup performCommandAction cmd seek $ shutdown $ cmdnocommit cmd go (Left norepo) = do - (_, a) <- parsewith + ((_, a), _) <- parsewith (fromMaybe (throw norepo) . cmdnorepo) (\a -> a =<< Git.Config.global) a parsewith getparser ingitrepo = - case parseCmd progname progdesc allargs allcmds getparser of + 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 correctedargs allcmds getparser)) + liftIO (O.handleParseResult (parseCmd progname progdesc globaloptions correctedargs allcmds getparser)) res -> liftIO (O.handleParseResult res) where autocorrect = Git.AutoCorrect.prepare (fromJust inputcmdname) cmdname cmds @@ -81,10 +81,13 @@ dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progde Just n -> n:args {- Parses command line, selecting one of the commands from the list. -} -parseCmd :: String -> String -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v) -parseCmd progname progdesc allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs +parseCmd :: String -> String -> [Parser GlobalSetter] -> 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)) + pinfo = O.info + (O.helper <*> ((,) <$> subcmds <*> combineGlobalSetters globaloptions)) + (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)) diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 8bc96a14d0..bb002a1039 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -29,10 +29,9 @@ import CmdLine.Usage -- Global options that are accepted by all git-annex sub-commands, -- although not always used. -gitAnnexGlobalOptions :: Parser GlobalSetter -gitAnnexGlobalOptions = globalSetters - [ commonGlobalOptions - , globalSetter setnumcopies $ option auto +gitAnnexGlobalOptions :: [Parser GlobalSetter] +gitAnnexGlobalOptions = commonGlobalOptions ++ + [ globalSetter setnumcopies $ option auto ( long "numcopies" <> short 'N' <> metavar paramNumber <> help "override default number of copies" ) diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index 5bc297a710..c653e86267 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -53,14 +53,13 @@ cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly where adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c } -options :: Parser GlobalSetter -options = globalSetters - [ commonGlobalOptions - , globalSetter checkUUID $ strOption +globalOptions :: [Parser GlobalSetter] +globalOptions = + globalSetter checkUUID (strOption ( long "uuid" <> metavar paramUUID <> help "local repository uuid" - ) - ] + )) + : commonGlobalOptions where checkUUID expected = getUUID >>= check where @@ -101,7 +100,7 @@ builtin cmd dir params = do let (params', fieldparams, opts) = partitionParams params rsyncopts = ("RsyncOptions", unwords opts) fields = rsyncopts : filter checkField (parseFields fieldparams) - dispatch False (cmd : params') cmds options fields mkrepo + dispatch False (cmd : params') cmds globalOptions fields mkrepo "git-annex-shell" "Restricted login shell for git-annex only SSH access" where diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs index 9cb1d41d4b..d28c7a7049 100644 --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -25,8 +25,8 @@ import Types.Messages import Types.DeferredParse -- Global options accepted by both git-annex and git-annex-shell sub-commands. -commonGlobalOptions :: Parser GlobalSetter -commonGlobalOptions = globalSetters +commonGlobalOptions :: [Parser GlobalSetter] +commonGlobalOptions = [ globalFlag (setforce True) ( long "force" <> help "allow actions that may lose annexed data" diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs index 4c6e90175f..c11b722bf5 100644 --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -46,6 +46,6 @@ globalFlag setter = flag' (DeferredParse setter) globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter globalSetter setter parser = DeferredParse . setter <$> parser -globalSetters :: [Parser GlobalSetter] -> Parser GlobalSetter -globalSetters l = DeferredParse . sequence_ . map getParsed +combineGlobalSetters :: [Parser GlobalSetter] -> Parser GlobalSetter +combineGlobalSetters l = DeferredParse . sequence_ . map getParsed <$> many (foldl1 (<|>) l) From 7af0893abd92cc27038c311a385738a665432454 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 02:18:08 -0400 Subject: [PATCH 26/54] improve global options display in --help Put them in the help of subcommands, not the main command. And, hide them from the synopsis, to avoid cluttering it. --- CmdLine.hs | 14 +++++++------- CmdLine/GitAnnex/Options.hs | 10 ++++++++++ CmdLine/GitAnnexShell.hs | 1 + CmdLine/GlobalSetter.hs | 24 ++++++++++++++++++++++++ CmdLine/Option.hs | 8 ++++++++ Types/DeferredParse.hs | 10 ---------- 6 files changed, 50 insertions(+), 17 deletions(-) create mode 100644 CmdLine/GlobalSetter.hs diff --git a/CmdLine.hs b/CmdLine.hs index e19b54de7e..de1b3e7da6 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -31,6 +31,7 @@ import Annex.Content import Annex.Environment import Command import Types.Messages +import CmdLine.GlobalSetter {- Runs the passed command line. -} dispatch :: Bool -> CmdParams -> [Command] -> [Parser GlobalSetter] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () @@ -43,7 +44,7 @@ dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progde Annex.eval state $ do checkEnvironment forM_ fields $ uncurry Annex.setField - ((cmd, seek), globalconfig) <- parsewith cmdparser + (cmd, seek, globalconfig) <- parsewith cmdparser (\a -> inRepo $ a . Just) when (cmdnomessages cmd) $ Annex.setOutput QuietOutput @@ -54,7 +55,7 @@ dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progde performCommandAction cmd seek $ shutdown $ cmdnocommit cmd go (Left norepo) = do - ((_, a), _) <- parsewith + (_, a, _globalconfig) <- parsewith (fromMaybe (throw norepo) . cmdnorepo) (\a -> a =<< Git.Config.global) a @@ -81,20 +82,19 @@ dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progde Just n -> n:args {- Parses command line, selecting one of the commands from the list. -} -parseCmd :: String -> String -> [Parser GlobalSetter] -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult ((Command, v), GlobalSetter) +parseCmd :: String -> String -> [Parser GlobalSetter] -> 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 <*> combineGlobalSetters globaloptions)) - (O.progDescDoc (Just intro)) + 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 = (,) + mkparser c = (,,) <$> pure c <*> getparser c + <*> combineGlobalSetters globaloptions synopsis n d = n ++ " - " ++ d intro = mconcat $ concatMap (\l -> [H.text l, H.line]) (synopsis progname progdesc : commandList allcmds) diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index bb002a1039..6965e8e51f 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -26,6 +26,7 @@ import qualified Limit import qualified Limit.Wanted import CmdLine.Option import CmdLine.Usage +import CmdLine.GlobalSetter -- Global options that are accepted by all git-annex sub-commands, -- although not always used. @@ -34,38 +35,47 @@ 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 diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index c653e86267..c1d02a7022 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -13,6 +13,7 @@ import Common.Annex import qualified Git.Construct import qualified Git.Config import CmdLine +import CmdLine.GlobalSetter import Command import Annex.UUID import CmdLine.GitAnnexShell.Fields diff --git a/CmdLine/GlobalSetter.hs b/CmdLine/GlobalSetter.hs new file mode 100644 index 0000000000..eb73f3f121 --- /dev/null +++ b/CmdLine/GlobalSetter.hs @@ -0,0 +1,24 @@ +{- git-annex global options + - + - Copyright 2015 Joey Hess + - + - 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 -> Parser GlobalSetter +globalFlag setter = flag' (DeferredParse setter) + +globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter +globalSetter setter parser = DeferredParse . setter <$> parser + +combineGlobalSetters :: [Parser GlobalSetter] -> Parser GlobalSetter +combineGlobalSetters l = DeferredParse . sequence_ . map getParsed + <$> many (foldl1 (<|>) l) diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs index d28c7a7049..9cc7a1f4b6 100644 --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -20,6 +20,7 @@ import System.Console.GetOpt import Common.Annex import CmdLine.Usage +import CmdLine.GlobalSetter import qualified Annex import Types.Messages import Types.DeferredParse @@ -30,30 +31,37 @@ 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 diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs index c11b722bf5..619d68e9c8 100644 --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -39,13 +39,3 @@ instance DeferredParseClass [DeferredParse a] where -- Use when the Annex action modifies Annex state. type GlobalSetter = DeferredParse () - -globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> Parser GlobalSetter -globalFlag setter = flag' (DeferredParse setter) - -globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter -globalSetter setter parser = DeferredParse . setter <$> parser - -combineGlobalSetters :: [Parser GlobalSetter] -> Parser GlobalSetter -combineGlobalSetters l = DeferredParse . sequence_ . map getParsed - <$> many (foldl1 (<|>) l) From 5cc882a35eae39f91183243f9ee43e0c75dc37e5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 12:47:35 -0400 Subject: [PATCH 27/54] implement withGlobalOptions, and convert Find --- CmdLine.hs | 1 - CmdLine/GitAnnex.hs | 4 ++-- CmdLine/GitAnnex/Options.hs | 8 ++++---- Command.hs | 15 +++++++++++++++ Command/ExamineKey.hs | 2 +- Command/Find.hs | 38 +++++++++++++++++++++---------------- 6 files changed, 44 insertions(+), 24 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index de1b3e7da6..7228818939 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -31,7 +31,6 @@ import Annex.Content import Annex.Environment import Command import Types.Messages -import CmdLine.GlobalSetter {- Runs the passed command line. -} dispatch :: Bool -> CmdParams -> [Command] -> [Parser GlobalSetter] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 32a4b8b10d..d2411ffb45 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -56,7 +56,7 @@ import qualified Command.AddUnused import qualified Command.Unlock import qualified Command.Lock import qualified Command.PreCommit ---import qualified Command.Find +import qualified Command.Find --import qualified Command.FindRef --import qualified Command.Whereis --import qualified Command.List @@ -183,7 +183,7 @@ cmds = -- , Command.Unused.cmd -- , Command.DropUnused.cmd , Command.AddUnused.cmd --- , Command.Find.cmd + , Command.Find.cmd -- , Command.FindRef.cmd -- , Command.Whereis.cmd -- , Command.List.cmd diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 6965e8e51f..9f033aa4d1 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -200,8 +200,8 @@ fileMatchingOptions' = "match files smaller than a size" ] -parseCombiningOptions :: Parser [GlobalSetter] -parseCombiningOptions = +combiningOptions :: Parser [GlobalSetter] +combiningOptions = many $ longopt "not" "negate next option" <|> longopt "and" "both previous and next option must match" <|> longopt "or" "either previous or next option must match" @@ -211,8 +211,8 @@ parseCombiningOptions = longopt o h = globalFlag (Limit.addToken o) ( long o <> help h ) shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h) -parseJsonOption :: Parser GlobalSetter -parseJsonOption = globalFlag (Annex.setOutput JSONOutput) +jsonOption :: Parser GlobalSetter +jsonOption = globalFlag (Annex.setOutput JSONOutput) ( long "json" <> short 'j' <> help "enable JSON output" ) diff --git a/Command.hs b/Command.hs index 019a657aa0..102173f883 100644 --- a/Command.hs +++ b/Command.hs @@ -13,6 +13,7 @@ module Command ( noCommit, noMessages, withOptions, + withGlobalOptions, next, stop, stopUnless, @@ -33,6 +34,7 @@ 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) @@ -78,6 +80,19 @@ noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) } 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 :: [Parser GlobalSetter] -> Command -> Command +withGlobalOptions os c = c { cmdparser = apply <$> mixin (cmdparser c) } + where + mixin p = (,) + <$> p + <*> combineGlobalSetters 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) next a = return $ Just a diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs index 65f4978a64..e0a1d9747d 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -11,7 +11,7 @@ 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 diff --git a/Command/Find.hs b/Command/Find.hs index 5a0a08973a..eb681d219b 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -14,7 +14,6 @@ import Common.Annex import Command import Annex.Content import Limit -import qualified Annex import qualified Utility.Format import Utility.DataUnits import Types.Key @@ -22,27 +21,34 @@ import Types.Key cmd :: Command cmd = withOptions annexedMatchingOptions $ mkCommand $ command "find" SectionQuery "lists available files" - paramPaths (withParams seek) + 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 :: CmdParams -> 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 From 6a4f2087bee8745cc6fed410c836c5de838bb7fe Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 13:18:46 -0400 Subject: [PATCH 28/54] finished converting all the main options --- CmdLine.hs | 6 +- CmdLine/GitAnnex.hs | 8 +- CmdLine/GitAnnex/Options.hs | 170 ++++++++++++++++++++++-------------- CmdLine/GitAnnexShell.hs | 2 +- CmdLine/GlobalSetter.hs | 8 +- CmdLine/Option.hs | 2 +- Command.hs | 4 +- Command/Add.hs | 28 +++--- Command/Drop.hs | 9 +- Command/Find.hs | 2 +- Command/Fix.hs | 2 +- Command/Fsck.hs | 9 +- Command/Get.hs | 9 +- Command/Import.hs | 2 +- Command/Lock.hs | 2 +- Command/Log.hs | 4 +- Command/Migrate.hs | 2 +- Command/Move.hs | 9 +- Command/Unannex.hs | 2 +- Command/Unlock.hs | 2 +- Command/Whereis.hs | 4 +- Types/DeferredParse.hs | 1 + 22 files changed, 165 insertions(+), 122 deletions(-) diff --git a/CmdLine.hs b/CmdLine.hs index 7228818939..492a3b75fd 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -33,7 +33,7 @@ import Command import Types.Messages {- Runs the passed command line. -} -dispatch :: Bool -> CmdParams -> [Command] -> [Parser GlobalSetter] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () +dispatch :: Bool -> CmdParams -> [Command] -> [GlobalOption] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO () dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progdesc = do setupConsole go =<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo)) @@ -81,7 +81,7 @@ dispatch fuzzyok allargs allcmds globaloptions fields getgitrepo progname progde Just n -> n:args {- Parses command line, selecting one of the commands from the list. -} -parseCmd :: String -> String -> [Parser GlobalSetter] -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v, GlobalSetter) +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 @@ -93,7 +93,7 @@ parseCmd progname progdesc globaloptions allargs allcmds getparser = mkparser c = (,,) <$> pure c <*> getparser c - <*> combineGlobalSetters globaloptions + <*> combineGlobalOptions globaloptions synopsis n d = n ++ " - " ++ d intro = mconcat $ concatMap (\l -> [H.text l, H.line]) (synopsis progname progdesc : commandList allcmds) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index d2411ffb45..18964d4dd7 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -60,7 +60,7 @@ import qualified Command.Find --import qualified Command.FindRef --import qualified Command.Whereis --import qualified Command.List -import qualified Command.Log +--import qualified Command.Log import qualified Command.Merge import qualified Command.ResolveMerge --import qualified Command.Info @@ -87,7 +87,7 @@ import qualified Command.AddUrl 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 @@ -136,7 +136,7 @@ cmds = , Command.ImportFeed.cmd #endif , Command.RmUrl.cmd - , Command.Import.cmd +-- , Command.Import.cmd , Command.Init.cmd , Command.Describe.cmd , Command.InitRemote.cmd @@ -187,7 +187,7 @@ cmds = -- , Command.FindRef.cmd -- , Command.Whereis.cmd -- , Command.List.cmd - , Command.Log.cmd +-- , Command.Log.cmd , Command.Merge.cmd , Command.ResolveMerge.cmd -- , Command.Info.cmd diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 9f033aa4d1..f95a4d03eb 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -7,7 +7,6 @@ module CmdLine.GitAnnex.Options where -import System.Console.GetOpt import Options.Applicative import Common.Annex @@ -30,7 +29,7 @@ import CmdLine.GlobalSetter -- Global options that are accepted by all git-annex sub-commands, -- although not always used. -gitAnnexGlobalOptions :: [Parser GlobalSetter] +gitAnnexGlobalOptions :: [GlobalOption] gitAnnexGlobalOptions = commonGlobalOptions ++ [ globalSetter setnumcopies $ option auto ( long "numcopies" <> short 'N' <> metavar paramNumber @@ -86,6 +85,20 @@ gitAnnexGlobalOptions = commonGlobalOptions ++ >>= Annex.changeGitRepo setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } +{- 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" + ) + +parseAutoOption :: Parser Bool +parseAutoOption = switch + ( long "auto" <> short 'a' + <> help "automatic mode" + ) + parseRemoteOption :: Parser RemoteName -> Parser (DeferredParse Remote) parseRemoteOption p = DeferredParse . (fromJust <$$> Remote.byNameWithUUID) . Just <$> p @@ -150,96 +163,125 @@ 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' - -- , combiningOptions - -- , [timeLimitOption] + , combiningOptions + , [timeLimitOption] ] -- Matching options that don't need to examine work tree files. -nonWorkTreeMatchingOptions :: [Option] -nonWorkTreeMatchingOptions = nonWorkTreeMatchingOptions' -- ++ combiningOptions +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 = fileMatchingOptions' -- ++ combiningOptions +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 :: Parser [GlobalSetter] +combiningOptions :: [GlobalOption] combiningOptions = - many $ 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" + [ 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" + ] where - longopt o h = globalFlag (Limit.addToken o) ( long o <> help h ) - shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h) + longopt o h = globalFlag (Limit.addToken o) ( long o <> help h <> hidden ) + shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h <> hidden ) -jsonOption :: Parser GlobalSetter +jsonOption :: GlobalOption jsonOption = globalFlag (Annex.setOutput JSONOutput) ( long "json" <> short 'j' <> help "enable JSON output" + <> hidden ) -parseJobsOption :: Parser GlobalSetter -parseJobsOption = globalSetter (Annex.setOutput . ParallelOutput) $ +jobsOption :: GlobalOption +jobsOption = globalSetter (Annex.setOutput . ParallelOutput) $ option auto ( long "jobs" <> short 'J' <> metavar paramNumber <> help "enable concurrent jobs" + <> hidden ) -parseTimeLimitOption :: Parser GlobalSetter -parseTimeLimitOption = globalSetter Limit.addTimeLimit $ strOption +timeLimitOption :: GlobalOption +timeLimitOption = globalSetter Limit.addTimeLimit $ strOption ( long "time-limit" <> short 'T' <> metavar paramTime <> help "stop after the specified amount of time" - ) - -parseAutoOption :: Parser Bool -parseAutoOption = switch - ( long "auto" <> short 'a' - <> help "automatic mode" - ) - -{- 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" + <> hidden ) diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index c1d02a7022..074257ac51 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -54,7 +54,7 @@ cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly where adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c } -globalOptions :: [Parser GlobalSetter] +globalOptions :: [GlobalOption] globalOptions = globalSetter checkUUID (strOption ( long "uuid" <> metavar paramUUID diff --git a/CmdLine/GlobalSetter.hs b/CmdLine/GlobalSetter.hs index eb73f3f121..831a8b4400 100644 --- a/CmdLine/GlobalSetter.hs +++ b/CmdLine/GlobalSetter.hs @@ -13,12 +13,12 @@ import Annex import Options.Applicative -globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> Parser GlobalSetter +globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> GlobalOption globalFlag setter = flag' (DeferredParse setter) -globalSetter :: (v -> Annex ()) -> Parser v -> Parser GlobalSetter +globalSetter :: (v -> Annex ()) -> Parser v -> GlobalOption globalSetter setter parser = DeferredParse . setter <$> parser -combineGlobalSetters :: [Parser GlobalSetter] -> Parser GlobalSetter -combineGlobalSetters l = DeferredParse . sequence_ . map getParsed +combineGlobalOptions :: [GlobalOption] -> Parser GlobalSetter +combineGlobalOptions l = DeferredParse . sequence_ . map getParsed <$> many (foldl1 (<|>) l) diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs index 9cc7a1f4b6..9f2353f980 100644 --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -26,7 +26,7 @@ import Types.Messages import Types.DeferredParse -- Global options accepted by both git-annex and git-annex-shell sub-commands. -commonGlobalOptions :: [Parser GlobalSetter] +commonGlobalOptions :: [GlobalOption] commonGlobalOptions = [ globalFlag (setforce True) ( long "force" diff --git a/Command.hs b/Command.hs index 102173f883..a9659b78fe 100644 --- a/Command.hs +++ b/Command.hs @@ -83,12 +83,12 @@ 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 :: [Parser GlobalSetter] -> Command -> Command +withGlobalOptions :: [GlobalOption] -> Command -> Command withGlobalOptions os c = c { cmdparser = apply <$> mixin (cmdparser c) } where mixin p = (,) <$> p - <*> combineGlobalSetters os + <*> combineGlobalOptions os apply (seek, globalsetters) = do void $ getParsed globalsetters seek diff --git a/Command/Add.hs b/Command/Add.hs index 270ac7f394..11682207e0 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -35,28 +35,34 @@ import Utility.Tmp import Control.Exception (IOException) cmd :: Command -cmd = notBareRepo $ withOptions addOptions $ +cmd = notBareRepo $ withGlobalOptions fileMatchingOptions $ command "add" SectionCommon "add files to annex" - paramPaths (withParams seek) + 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 :: CmdParams -> 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 diff --git a/Command/Drop.hs b/Command/Drop.hs index 7141cbc484..feb89b70e8 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -23,9 +23,10 @@ import Annex.Notification import qualified Data.Set as S cmd :: Command -cmd = command "drop" SectionCommon - "remove content of files from repository" - paramPaths (seek <$$> optParser) +cmd = withGlobalOptions annexedMatchingOptions $ + command "drop" SectionCommon + "remove content of files from repository" + paramPaths (seek <$$> optParser) data DropOptions = DropOptions { dropFiles :: CmdParams @@ -34,8 +35,6 @@ data DropOptions = DropOptions , keyOptions :: Maybe KeyOptions } --- TODO: annexedMatchingOptions - optParser :: CmdParamsDesc -> Parser DropOptions optParser desc = DropOptions <$> cmdParams desc diff --git a/Command/Find.hs b/Command/Find.hs index eb681d219b..dd82bd4015 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -19,7 +19,7 @@ import Utility.DataUnits import Types.Key cmd :: Command -cmd = withOptions annexedMatchingOptions $ mkCommand $ +cmd = withGlobalOptions annexedMatchingOptions $ mkCommand $ command "find" SectionQuery "lists available files" paramPaths (seek <$$> optParser) diff --git a/Command/Fix.hs b/Command/Fix.hs index a5f385b4f4..abaedb30bc 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -19,7 +19,7 @@ import Utility.Touch #endif cmd :: Command -cmd = notDirect $ noCommit $ withOptions annexedMatchingOptions $ +cmd = notDirect $ noCommit $ withGlobalOptions annexedMatchingOptions $ command "fix" SectionMaintenance "fix up symlinks to point to annexed content" paramPaths (withParams seek) diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 0c5251ecb4..0e0c49d78a 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -41,9 +41,10 @@ import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime) cmd :: Command -cmd = command "fsck" SectionMaintenance - "find and fix problems" - paramPaths (seek <$$> optParser) +cmd = withGlobalOptions annexedMatchingOptions $ + command "fsck" SectionMaintenance + "find and fix problems" + paramPaths (seek <$$> optParser) data FsckOptions = FsckOptions { fsckFiles :: CmdParams @@ -52,8 +53,6 @@ data FsckOptions = FsckOptions , keyOptions :: Maybe KeyOptions } --- TODO: annexedMatchingOptions - data IncrementalOpt = StartIncrementalO | MoreIncrementalO diff --git a/Command/Get.hs b/Command/Get.hs index 3af09b642d..324ff27521 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -17,9 +17,10 @@ import Annex.Wanted import qualified Command.Move cmd :: Command -cmd = command "get" SectionCommon - "make content of annexed files available" - paramPaths (seek <$$> optParser) +cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $ + command "get" SectionCommon + "make content of annexed files available" + paramPaths (seek <$$> optParser) data GetOptions = GetOptions { getFiles :: CmdParams @@ -35,8 +36,6 @@ optParser desc = GetOptions <*> parseAutoOption <*> optional (parseKeyOptions True) --- TODO: jobsOption, annexedMatchingOptions - seek :: GetOptions -> CommandSeek seek o = do from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) diff --git a/Command/Import.hs b/Command/Import.hs index 8d09f84789..684641ea31 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -28,7 +28,7 @@ cmd = withOptions opts $ notBareRepo $ "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 diff --git a/Command/Lock.hs b/Command/Lock.hs index 04c8b94949..7711ec3b8d 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -13,7 +13,7 @@ import qualified Annex.Queue import qualified Annex cmd :: Command -cmd = notDirect $ withOptions annexedMatchingOptions $ +cmd = notDirect $ withGlobalOptions annexedMatchingOptions $ command "lock" SectionCommon "undo unlock command" paramPaths (withParams seek) diff --git a/Command/Log.hs b/Command/Log.hs index 6f3967c6a7..eb740b2495 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -39,11 +39,11 @@ data RefChange = RefChange type Outputter = Bool -> POSIXTime -> [UUID] -> Annex () cmd :: Command -cmd = withOptions options $ +cmd = withGlobalOptions options $ command "log" SectionQuery "shows location log" paramPaths (withParams seek) -options :: [Option] +options :: [GlobalOption] options = passthruOptions ++ [gourceOption] ++ annexedMatchingOptions passthruOptions :: [Option] diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 80d42e87a6..d1c7902d7d 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -19,7 +19,7 @@ import qualified Command.Fsck import qualified Annex cmd :: Command -cmd = notDirect $ withOptions annexedMatchingOptions $ +cmd = notDirect $ withGlobalOptions annexedMatchingOptions $ command "migrate" SectionUtility "switch data to different backend" paramPaths (withParams seek) diff --git a/Command/Move.hs b/Command/Move.hs index 087ea0a7bf..d95bce6abe 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -18,9 +18,10 @@ import Annex.Transfer import Logs.Presence cmd :: Command -cmd = command "move" SectionCommon - "move content of files to/from another repository" - paramPaths (seek <--< optParser) +cmd = withGlobalOptions (jobsOption : annexedMatchingOptions) $ + command "move" SectionCommon + "move content of files to/from another repository" + paramPaths (seek <--< optParser) data MoveOptions = MoveOptions { moveFiles :: CmdParams @@ -28,8 +29,6 @@ data MoveOptions = MoveOptions , keyOptions :: Maybe KeyOptions } --- TODO: jobsOption, annexedMatchingOptions - optParser :: CmdParamsDesc -> Parser MoveOptions optParser desc = MoveOptions <$> cmdParams desc diff --git a/Command/Unannex.hs b/Command/Unannex.hs index ea814560f2..fdf976d3e0 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -23,7 +23,7 @@ import Utility.CopyFile import Command.PreCommit (lockPreCommitHook) cmd :: Command -cmd = withOptions annexedMatchingOptions $ +cmd = withGlobalOptions annexedMatchingOptions $ command "unannex" SectionUtility "undo accidential add command" paramPaths (withParams seek) diff --git a/Command/Unlock.hs b/Command/Unlock.hs index 36b0023d86..d1b1d0e90e 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -20,7 +20,7 @@ editcmd :: Command editcmd = mkcmd "edit" "same as unlock" mkcmd :: String -> String -> Command -mkcmd n d = notDirect $ withOptions annexedMatchingOptions $ +mkcmd n d = notDirect $ withGlobalOptions annexedMatchingOptions $ command n SectionCommon d paramPaths (withParams seek) seek :: CmdParams -> CommandSeek diff --git a/Command/Whereis.hs b/Command/Whereis.hs index fb28daa22a..2c6018b244 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -16,7 +16,7 @@ import Logs.Trust import Logs.Web cmd :: Command -cmd = noCommit $ withOptions (jsonOption : annexedMatchingOptions ++ keyOptions) $ +cmd = noCommit $ withGlobalOptions (jsonOption : annexedMatchingOptions) $ command "whereis" SectionQuery "lists repositories that have file content" paramPaths (withParams seek) @@ -27,8 +27,6 @@ data WhereisOptions = WhereisOptions , keyOptions :: Maybe KeyOptions } --- TODO: annexedMatchingOptions - seek :: CmdParams -> CommandSeek seek ps = do m <- remoteMap id diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs index 619d68e9c8..983ba3f5c2 100644 --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -39,3 +39,4 @@ instance DeferredParseClass [DeferredParse a] where -- Use when the Annex action modifies Annex state. type GlobalSetter = DeferredParse () +type GlobalOption = Parser GlobalSetter From b4d22e6d490de1938b35e333b89f3452c815f93a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 13:49:37 -0400 Subject: [PATCH 29/54] doc updates --- debian/changelog | 7 +++++++ doc/git-annex.mdwn | 12 ++++++++++++ 2 files changed, 19 insertions(+) diff --git a/debian/changelog b/debian/changelog index a357e3fe66..e0a4de90f8 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.20150618) UNRELEASED; urgency=medium * log: Fix reversion introduced in version 5.20150528 that broke this command. diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 73894c0d85..e3790bdf93 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`. From 4064dd4c827abb81f719be0331cd270070325028 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 13:49:46 -0400 Subject: [PATCH 30/54] convert version command, and make --raw work when not in a git repo --- CmdLine/GitAnnex.hs | 40 ++++++++++++++++++------------------ Command.hs | 7 +------ Command/Unused.hs | 2 +- Command/Version.hs | 50 +++++++++++++++++++++++++-------------------- Types/Command.hs | 3 +-- 5 files changed, 51 insertions(+), 51 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 18964d4dd7..81b9cd3d68 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -23,8 +23,8 @@ import qualified Command.Move import qualified Command.Copy import qualified Command.Get import qualified Command.Fsck -import qualified Command.LookupKey -import qualified Command.ContentLocation +--import qualified Command.LookupKey +--import qualified Command.ContentLocation --import qualified Command.ExamineKey import qualified Command.FromKey import qualified Command.RegisterUrl @@ -48,7 +48,7 @@ import qualified Command.Init import qualified Command.Describe import qualified Command.InitRemote import qualified Command.EnableRemote -import qualified Command.Expire +--import qualified Command.Expire import qualified Command.Repair --import qualified Command.Unused --import qualified Command.DropUnused @@ -82,9 +82,9 @@ import qualified Command.Ungroup --import qualified Command.Vicfg import qualified Command.Sync --import qualified Command.Mirror -import qualified Command.AddUrl +--import qualified Command.AddUrl #ifdef WITH_FEED -import qualified Command.ImportFeed +--import qualified Command.ImportFeed #endif import qualified Command.RmUrl --import qualified Command.Import @@ -92,16 +92,16 @@ 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.Version #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,7 +111,7 @@ 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 @@ -131,9 +131,9 @@ cmds = , Command.Lock.cmd , Command.Sync.cmd -- , Command.Mirror.cmd - , Command.AddUrl.cmd +-- , Command.AddUrl.cmd #ifdef WITH_FEED - , Command.ImportFeed.cmd +-- , Command.ImportFeed.cmd #endif , Command.RmUrl.cmd -- , Command.Import.cmd @@ -158,8 +158,8 @@ cmds = , Command.Schedule.cmd , Command.Ungroup.cmd -- , Command.Vicfg.cmd - , Command.LookupKey.cmd - , Command.ContentLocation.cmd +-- , Command.LookupKey.cmd +-- , Command.ContentLocation.cmd -- , Command.ExamineKey.cmd , Command.FromKey.cmd , Command.RegisterUrl.cmd @@ -178,7 +178,7 @@ cmds = , Command.VPop.cmd , Command.VCycle.cmd , Command.Fix.cmd - , Command.Expire.cmd +-- , Command.Expire.cmd , Command.Repair.cmd -- , Command.Unused.cmd -- , Command.DropUnused.cmd @@ -197,16 +197,16 @@ cmds = , 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.Version.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 @@ -216,7 +216,7 @@ cmds = , Command.Test.cmd #ifdef WITH_TESTSUITE , Command.FuzzTest.cmd - , Command.TestRemote.cmd +-- , Command.TestRemote.cmd #endif ] diff --git a/Command.hs b/Command.hs index a9659b78fe..bee63bb741 100644 --- a/Command.hs +++ b/Command.hs @@ -12,7 +12,6 @@ module Command ( noRepo, noCommit, noMessages, - withOptions, withGlobalOptions, next, stop, @@ -43,7 +42,7 @@ 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 + Command commonChecks False False name paramdesc section desc (mkparser paramdesc) Nothing {- Simple option parser that takes all non-option params as-is. -} @@ -76,10 +75,6 @@ noMessages c = c { cmdnomessages = True } 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. -} diff --git a/Command/Unused.hs b/Command/Unused.hs index 4649485c2b..c2ca148b71 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -35,7 +35,7 @@ import Logs.View (is_branchView) import Annex.BloomFilter cmd :: Command -cmd = withOptions [unusedFromOption, refSpecOption] $ +cmd = -- withGlobalOptions [unusedFromOption, refSpecOption] $ command "unused" SectionMaintenance "look for unused file content" paramNothing (withParams seek) diff --git a/Command/Version.hs b/Command/Version.hs index 9896f671e2..72bbe40648 100644 --- a/Command/Version.hs +++ b/Command/Version.hs @@ -18,40 +18,41 @@ import qualified Remote import qualified Backend cmd :: Command -cmd = withOptions [rawOption] $ dontCheck repoExists $ noCommit $ - noRepo (parseparams startNoRepo) $ +cmd = dontCheck repoExists $ noCommit $ + noRepo (seekNoRepo <$$> optParser) $ command "version" SectionQuery "show version info" - paramNothing (parseparams seek) - where - parseparams = withParams + paramNothing (seek <$$> optParser) -rawOption :: Option -rawOption = flagOption [] "raw" "output only program version" +data VersionOptions = VersionOptions + { rawOption :: Bool + } -seek :: CmdParams -> 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 -start :: CommandStart -start = do +seekNoRepo :: VersionOptions -> IO () +seekNoRepo o + | rawOption o = showRawVersion + | otherwise = showPackageVersion + +showVersion :: Annex () +showVersion = do v <- getVersion liftIO $ do - showPackageVersion 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 @@ -60,5 +61,10 @@ showPackageVersion = do 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 + vinfo :: String -> String -> IO () vinfo k v = putStrLn $ k ++ ": " ++ v diff --git a/Types/Command.hs b/Types/Command.hs index acd662bf3f..e12873850a 100644 --- a/Types/Command.hs +++ b/Types/Command.hs @@ -38,8 +38,7 @@ type CommandCleanup = Annex Bool {- A command is defined by specifying these things. -} data Command = Command - { cmdoptions :: [Option] -- command-specific options - , 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 From 160d4b9fe0fb48812f78b01e0156e163950b7359 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 16:05:56 -0400 Subject: [PATCH 31/54] convert Unused, and remove some dead code for old style option parsing --- CmdLine/GitAnnex.hs | 4 ++-- CmdLine/Option.hs | 28 +--------------------------- CmdLine/Seek.hs | 10 ---------- Command/Unused.hs | 38 +++++++++++++++++++++++--------------- 4 files changed, 26 insertions(+), 54 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 81b9cd3d68..7119d14553 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -50,7 +50,7 @@ import qualified Command.InitRemote import qualified Command.EnableRemote --import qualified Command.Expire import qualified Command.Repair ---import qualified Command.Unused +import qualified Command.Unused --import qualified Command.DropUnused import qualified Command.AddUnused import qualified Command.Unlock @@ -180,7 +180,7 @@ cmds = , Command.Fix.cmd -- , Command.Expire.cmd , Command.Repair.cmd --- , Command.Unused.cmd + , Command.Unused.cmd -- , Command.DropUnused.cmd , Command.AddUnused.cmd , Command.Find.cmd diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs index 9f2353f980..4e201cbd47 100644 --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -5,18 +5,9 @@ - Licensed under the GNU GPL version 3 or higher. -} -module CmdLine.Option ( - commonGlobalOptions, - flagOption, - fieldOption, - optionName, - optionParam, - ArgDescr(..), - OptDescr(..), -) where +module CmdLine.Option where import Options.Applicative -import System.Console.GetOpt import Common.Annex import CmdLine.Usage @@ -70,20 +61,3 @@ commonGlobalOptions = setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True } unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False } - -{- An option that sets a flag. -} -flagOption :: String -> String -> String -> Option -flagOption shortv opt description = - Option shortv [opt] (NoArg (Annex.setFlag opt)) description - -{- An option that sets a field. -} -fieldOption :: String -> String -> String -> String -> Option -fieldOption shortv opt paramdesc description = - Option shortv [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 b40e0d17aa..e67c3b908f 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -22,7 +22,6 @@ 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 @@ -152,15 +151,6 @@ 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 -> CmdParams -> CommandSeek withNothing a [] = seekActions $ return [a] withNothing _ _ = error "This command takes no parameters." diff --git a/Command/Unused.hs b/Command/Unused.hs index c2ca148b71..a383d567b0 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -31,6 +31,7 @@ import Annex.CatFile import Types.Key import Types.RefSpec import Git.FilePath +import Git.Types import Logs.View (is_branchView) import Annex.BloomFilter @@ -38,26 +39,33 @@ cmd :: Command cmd = -- withGlobalOptions [unusedFromOption, refSpecOption] $ command "unused" SectionMaintenance "look for unused file content" - paramNothing (withParams seek) + 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 :: CmdParams -> 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, perform) = 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) From decfababe9b54a622492aab48b7f7aab3684677a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 16:15:31 -0400 Subject: [PATCH 32/54] convert DropUnused --- CmdLine/GitAnnex.hs | 4 ++-- Command/DropUnused.hs | 39 +++++++++++++++++++++++---------------- 2 files changed, 25 insertions(+), 18 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 7119d14553..662766f461 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -51,7 +51,7 @@ import qualified Command.EnableRemote --import qualified Command.Expire import qualified Command.Repair import qualified Command.Unused ---import qualified Command.DropUnused +import qualified Command.DropUnused import qualified Command.AddUnused import qualified Command.Unlock import qualified Command.Lock @@ -181,7 +181,7 @@ cmds = -- , Command.Expire.cmd , Command.Repair.cmd , Command.Unused.cmd --- , Command.DropUnused.cmd + , Command.DropUnused.cmd , Command.AddUnused.cmd , Command.Find.cmd -- , Command.FindRef.cmd diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 703cc38906..98fcef6eae 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -9,7 +9,6 @@ module Command.DropUnused where import Common.Annex import Command -import qualified Annex import qualified Command.Drop import qualified Remote import qualified Git @@ -17,27 +16,35 @@ import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused) import Annex.NumCopies cmd :: Command -cmd = withOptions [Command.Drop.dropFromOption] $ - command "dropunused" SectionMaintenance - "drop unused file content" - (paramRepeating paramNumRange) (withParams seek) +cmd = command "dropunused" SectionMaintenance + "drop unused file content" + (paramRepeating paramNumRange) (seek <$$> optParser) -seek :: CmdParams -> 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 From 8eb0a440b95991547e67e3630444082a8c1db85d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 16:26:23 -0400 Subject: [PATCH 33/54] convert Expire --- CmdLine/GitAnnex.hs | 4 ++-- Command/Expire.hs | 48 ++++++++++++++++++++++++++------------------- 2 files changed, 30 insertions(+), 22 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 662766f461..2990a6c386 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -48,7 +48,7 @@ import qualified Command.Init import qualified Command.Describe import qualified Command.InitRemote import qualified Command.EnableRemote ---import qualified Command.Expire +import qualified Command.Expire import qualified Command.Repair import qualified Command.Unused import qualified Command.DropUnused @@ -178,7 +178,7 @@ cmds = , Command.VPop.cmd , Command.VCycle.cmd , Command.Fix.cmd --- , Command.Expire.cmd + , Command.Expire.cmd , Command.Repair.cmd , Command.Unused.cmd , Command.DropUnused.cmd diff --git a/Command/Expire.hs b/Command/Expire.hs index 9552128f11..1e67d1d2ad 100644 --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -21,30 +21,39 @@ import Data.Time.Clock.POSIX import qualified Data.Map as M cmd :: Command -cmd = withOptions [activityOption, noActOption] $ - command "expire" SectionMaintenance - "expire inactive repositories" - paramExpire (withParams seek) +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 :: CmdParams -> 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 = @@ -99,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 From c94e219fea7d83bf5435a4506454fca39a2062ca Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 16:32:33 -0400 Subject: [PATCH 34/54] convert Whereis --- CmdLine/GitAnnex.hs | 10 +++++----- Command/Whereis.hs | 16 ++++++++++------ 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 2990a6c386..68a9e27ca7 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -15,7 +15,7 @@ import Command import Utility.Env import Annex.Ssh ---import qualified Command.Help +import qualified Command.Help import qualified Command.Add import qualified Command.Unannex import qualified Command.Drop @@ -58,7 +58,7 @@ import qualified Command.Lock import qualified Command.PreCommit import qualified Command.Find --import qualified Command.FindRef ---import qualified Command.Whereis +import qualified Command.Whereis --import qualified Command.List --import qualified Command.Log import qualified Command.Merge @@ -119,8 +119,8 @@ import System.Remote.Monitoring cmds :: [Command] cmds = --- [ Command.Help.cmd - [ Command.Add.cmd + [ Command.Help.cmd + , Command.Add.cmd , Command.Get.cmd , Command.Drop.cmd , Command.Move.cmd @@ -185,7 +185,7 @@ cmds = , Command.AddUnused.cmd , Command.Find.cmd -- , Command.FindRef.cmd --- , Command.Whereis.cmd + , Command.Whereis.cmd -- , Command.List.cmd -- , Command.Log.cmd , Command.Merge.cmd diff --git a/Command/Whereis.hs b/Command/Whereis.hs index 2c6018b244..3610eed788 100644 --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -19,21 +19,25 @@ cmd :: Command cmd = noCommit $ withGlobalOptions (jsonOption : annexedMatchingOptions) $ command "whereis" SectionQuery "lists repositories that have file content" - paramPaths (withParams seek) + paramPaths (seek <$$> optParser) data WhereisOptions = WhereisOptions { whereisFiles :: CmdParams - , jsonOption :: GlobalSetter , keyOptions :: Maybe KeyOptions } -seek :: CmdParams -> CommandSeek -seek ps = do +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) From 9659052e3f6fddf3f542887a349c47e2789fbb58 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 17:56:56 -0400 Subject: [PATCH 35/54] devblog --- doc/devblog/day_299__so_many_commands_and_options.mdwn | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 doc/devblog/day_299__so_many_commands_and_options.mdwn diff --git a/doc/devblog/day_299__so_many_commands_and_options.mdwn b/doc/devblog/day_299__so_many_commands_and_options.mdwn new file mode 100644 index 0000000000..04a2c1e2db --- /dev/null +++ b/doc/devblog/day_299__so_many_commands_and_options.mdwn @@ -0,0 +1,9 @@ +Day 3 of the optparse-applicative conversion. +116 files changed, 1607 insertions(+), 1135 deletions(-) +At this point, everything is done except for around 20 sub-commands. +Probably takes 15 minutes work for each. Will finish plowing through +it in the evenings. + +Meanwhile, made the release of version 5.20150710. The Android build for +this version is not available yet, since I broke the autobuilder last week +and haven't fixed it yet. From 02f6d9b33a7cd9cfa4723dd392eba87bfbc8c7c1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 20:38:11 -0400 Subject: [PATCH 36/54] convert FindRef --- CmdLine/GitAnnex.hs | 4 ++-- Command/Find.hs | 8 ++++---- Command/FindRef.hs | 11 +++++------ 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 68a9e27ca7..391237ca1c 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -57,7 +57,7 @@ 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 @@ -184,7 +184,7 @@ cmds = , Command.DropUnused.cmd , Command.AddUnused.cmd , Command.Find.cmd --- , Command.FindRef.cmd + , Command.FindRef.cmd , Command.Whereis.cmd -- , Command.List.cmd -- , Command.Log.cmd diff --git a/Command/Find.hs b/Command/Find.hs index dd82bd4015..ae5595c1d6 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -48,14 +48,14 @@ parseFormatOption = ) seek :: FindOptions -> CommandSeek -seek o = withFilesInGit (whenAnnexed $ start (formatOption o)) (findThese o) +seek o = withFilesInGit (whenAnnexed $ start o) (findThese o) -start :: Maybe Utility.Format.Format -> FilePath -> Key -> CommandStart -start format file key = do +start :: FindOptions -> FilePath -> Key -> CommandStart +start o file key = do -- only files inAnnex are shown, unless the user has requested -- others via a limit whenM (limited <||> inAnnex key) $ - showFormatted format file $ ("file", file) : keyVars key + showFormatted (formatOption o) file $ ("file", file) : keyVars key stop showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex () diff --git a/Command/FindRef.hs b/Command/FindRef.hs index cd7583b96f..8de7d9e594 100644 --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -7,16 +7,15 @@ module Command.FindRef where +import Common.Annex import Command import qualified Command.Find as Find cmd :: Command -cmd = withOptions nonWorkTreeMatchingOptions $ Find.mkCommand $ +cmd = withGlobalOptions nonWorkTreeMatchingOptions $ Find.mkCommand $ command "findref" SectionPlumbing "lists files in a git ref" - paramRef (withParams seek) + paramRef (seek <$$> Find.optParser) -seek :: CmdParams -> CommandSeek -seek refs = do - format <- Find.getFormat - Find.start format `withFilesInRefs` refs +seek :: Find.FindOptions -> CommandSeek +seek o = Find.start o `withFilesInRefs` Find.findThese o From a0b2fcc663e2c15ba1082cc6bab3ba619884a843 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 20:40:30 -0400 Subject: [PATCH 37/54] converted ViCfg (trivially) --- CmdLine/GitAnnex.hs | 4 ++-- Command/Vicfg.hs | 34 +++++++++++++++++----------------- 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 391237ca1c..c60e7ecb65 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -79,7 +79,7 @@ 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 @@ -157,7 +157,7 @@ cmds = , Command.Required.cmd , Command.Schedule.cmd , Command.Ungroup.cmd --- , Command.Vicfg.cmd + , Command.Vicfg.cmd -- , Command.LookupKey.cmd -- , Command.ContentLocation.cmd -- , Command.ExamineKey.cmd diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 677ba5b13a..cec032b80c 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -175,7 +175,7 @@ genCfg cfg descs = unlines $ intercalate [""] (\(s, g) -> gline g s) (\g -> gline g "") where - gline g value = [ unwords ["groupwanted", g, "=", value] ] + gline g val = [ unwords ["groupwanted", g, "=", val] ] allgroups = S.unions $ stdgroups : M.elems (cfgGroupMap cfg) stdgroups = S.fromList $ map fromStandardGroup [minBound..maxBound] @@ -198,9 +198,9 @@ genCfg cfg descs = unlines $ intercalate [""] (\(l, u) -> line "schedule" u $ fromScheduledActivities l) (\u -> line "schedule" u "") - line setting u value = + line setting u val = [ com $ "(for " ++ fromMaybe "" (M.lookup u descs) ++ ")" - , unwords [setting, fromUUID u, "=", value] + , unwords [setting, fromUUID u, "=", val] ] settings :: Ord v => Cfg -> M.Map UUID String -> (Cfg -> M.Map UUID v) -> [String] -> ((v, UUID) -> [String]) -> (UUID -> [String]) -> [String] @@ -235,42 +235,42 @@ parseCfg defcfg = go [] defcfg . lines | null l = Right cfg | "#" `isPrefixOf` l = Right cfg | null setting || null f = Left "missing field" - | otherwise = parsed cfg f setting value' + | otherwise = parsed cfg f setting val' where (setting, rest) = separate isSpace l - (r, value) = separate (== '=') rest - value' = trimspace value + (r, val) = separate (== '=') rest + val' = trimspace val f = reverse $ trimspace $ reverse $ trimspace r trimspace = dropWhile isSpace - parsed cfg f setting value - | setting == "trust" = case readTrustLevel value of - Nothing -> badval "trust value" value + parsed cfg f setting val + | setting == "trust" = case readTrustLevel val of + Nothing -> badval "trust value" val Just t -> let m = M.insert u t (cfgTrustMap cfg) in Right $ cfg { cfgTrustMap = m } | setting == "group" = - let m = M.insert u (S.fromList $ words value) (cfgGroupMap cfg) + let m = M.insert u (S.fromList $ words val) (cfgGroupMap cfg) in Right $ cfg { cfgGroupMap = m } | setting == "wanted" = - case checkPreferredContentExpression value of + case checkPreferredContentExpression val of Just e -> Left e Nothing -> - let m = M.insert u value (cfgPreferredContentMap cfg) + let m = M.insert u val (cfgPreferredContentMap cfg) in Right $ cfg { cfgPreferredContentMap = m } | setting == "required" = - case checkPreferredContentExpression value of + case checkPreferredContentExpression val of Just e -> Left e Nothing -> - let m = M.insert u value (cfgRequiredContentMap cfg) + let m = M.insert u val (cfgRequiredContentMap cfg) in Right $ cfg { cfgRequiredContentMap = m } | setting == "groupwanted" = - case checkPreferredContentExpression value of + case checkPreferredContentExpression val of Just e -> Left e Nothing -> - let m = M.insert f value (cfgGroupPreferredContentMap cfg) + let m = M.insert f val (cfgGroupPreferredContentMap cfg) in Right $ cfg { cfgGroupPreferredContentMap = m } - | setting == "schedule" = case parseScheduledActivities value of + | setting == "schedule" = case parseScheduledActivities val of Left e -> Left e Right l -> let m = M.insert u l (cfgScheduleMap cfg) From e4b3701dfe9f074c7eced0099813254d6bd36260 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 20:46:48 -0400 Subject: [PATCH 38/54] convert List --- CmdLine/GitAnnex.hs | 4 ++-- Command/List.hs | 42 +++++++++++++++++++++++++----------------- 2 files changed, 27 insertions(+), 19 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index c60e7ecb65..6677f3b29c 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -59,7 +59,7 @@ import qualified Command.PreCommit import qualified Command.Find import qualified Command.FindRef import qualified Command.Whereis ---import qualified Command.List +import qualified Command.List --import qualified Command.Log import qualified Command.Merge import qualified Command.ResolveMerge @@ -186,7 +186,7 @@ cmds = , Command.Find.cmd , Command.FindRef.cmd , Command.Whereis.cmd --- , Command.List.cmd + , Command.List.cmd -- , Command.Log.cmd , Command.Merge.cmd , Command.ResolveMerge.cmd diff --git a/Command/List.hs b/Command/List.hs index 723f53b46a..c912e8c3f6 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -20,29 +20,37 @@ import Remote import Logs.Trust import Logs.UUID import Annex.UUID -import qualified Annex import Git.Types (RemoteName) cmd :: Command -cmd = noCommit $ withOptions (allrepos : annexedMatchingOptions) $ +cmd = noCommit $ withGlobalOptions annexedMatchingOptions $ command "list" SectionQuery "show which remotes contain files" - paramPaths (withParams seek) + paramPaths (seek <$$> optParser) -allrepos :: Option -allrepos = flagOption [] "allrepos" "show all repositories, not only remotes" +data ListOptions = ListOptions + { listThese :: CmdParams + , allRepos :: Bool + } -seek :: CmdParams -> CommandSeek -seek ps = do - list <- getList +optParser :: CmdParamsDesc -> Parser ListOptions +optParser desc = ListOptions + <$> cmdParams desc + <*> switch + ( long "allrepos" + <> help "show all repositories, not only remotes" + ) + +seek :: ListOptions -> CommandSeek +seek o = do + list <- getList o printHeader list - withFilesInGit (whenAnnexed $ start list) ps + withFilesInGit (whenAnnexed $ start list) (listThese o) -getList :: Annex [(UUID, RemoteName, TrustLevel)] -getList = ifM (Annex.getFlag $ optionName allrepos) - ( nubBy ((==) `on` fst3) <$> ((++) <$> getRemotes <*> getAllUUIDs) - , getRemotes - ) +getList :: ListOptions -> Annex [(UUID, RemoteName, TrustLevel)] +getList o + | allRepos o = nubBy ((==) `on` fst3) <$> ((++) <$> getRemotes <*> getAllUUIDs) + | otherwise = getRemotes where getRemotes = do rs <- remoteList @@ -60,7 +68,7 @@ getList = ifM (Annex.getFlag $ optionName allrepos) filter (\t -> thd3 t /= DeadTrusted) rs3 printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex () -printHeader l = liftIO $ putStrLn $ header $ map (\(_, n, t) -> (n, t)) l +printHeader l = liftIO $ putStrLn $ lheader $ map (\(_, n, t) -> (n, t)) l start :: [(UUID, RemoteName, TrustLevel)] -> FilePath -> Key -> CommandStart start l file key = do @@ -70,8 +78,8 @@ start l file key = do type Present = Bool -header :: [(RemoteName, TrustLevel)] -> String -header remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length remotes) +lheader :: [(RemoteName, TrustLevel)] -> String +lheader remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length remotes) where formatheader n (remotename, trustlevel) = pipes n ++ remotename ++ trust trustlevel pipes = flip replicate '|' From c70c841d30d3417967dcc558de04d75cb2674348 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Jul 2015 21:05:34 -0400 Subject: [PATCH 39/54] converted Mirror --- CmdLine/GitAnnex.hs | 4 +-- Command/Mirror.hs | 61 +++++++++++++++++++++++++-------------------- 2 files changed, 36 insertions(+), 29 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 6677f3b29c..dd159385a8 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -81,7 +81,7 @@ import qualified Command.Schedule import qualified Command.Ungroup import qualified Command.Vicfg import qualified Command.Sync ---import qualified Command.Mirror +import qualified Command.Mirror --import qualified Command.AddUrl #ifdef WITH_FEED --import qualified Command.ImportFeed @@ -130,7 +130,7 @@ cmds = , Command.Unlock.editcmd , Command.Lock.cmd , Command.Sync.cmd --- , Command.Mirror.cmd + , Command.Mirror.cmd -- , Command.AddUrl.cmd #ifdef WITH_FEED -- , Command.ImportFeed.cmd diff --git a/Command/Mirror.hs b/Command/Mirror.hs index f0880e87ea..0555d025cc 100644 --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -17,42 +17,48 @@ import Annex.Content import Annex.NumCopies cmd :: Command -cmd = withOptions mirrorOptions $ +cmd = withGlobalOptions ([jobsOption] ++ annexedMatchingOptions) $ command "mirror" SectionCommon "mirror content of files to/from another repository" - paramPaths (withParams seek) + paramPaths (seek <--< optParser) -mirrorOptions :: [Option] -mirrorOptions = fromToOptions ++ [jobsOption] ++ annexedMatchingOptions ++ keyOptions +data MirrorOptions = MirrorOptions + { mirrorFiles :: CmdParams + , fromToOptions :: FromToOptions + , keyOptions :: Maybe KeyOptions + } -seek :: CmdParams -> CommandSeek -seek ps = do - to <- getOptionField toOption Remote.byNameWithUUID - from <- getOptionField fromOption Remote.byNameWithUUID - withKeyOptions False - (startKey to from Nothing) - (withFilesInGit $ whenAnnexed $ start to from) - ps +optParser :: CmdParamsDesc -> Parser MirrorOptions +optParser desc = MirrorOptions + <$> cmdParams desc + <*> parseFromToOptions + <*> optional (parseKeyOptions False) -start :: Maybe Remote -> Maybe Remote -> FilePath -> Key -> CommandStart -start to from file = startKey to from (Just file) +instance DeferredParseClass MirrorOptions where + finishParse v = MirrorOptions + <$> pure (mirrorFiles v) + <*> finishParse (fromToOptions v) + <*> pure (keyOptions v) -startKey :: Maybe Remote -> Maybe Remote -> Maybe FilePath -> Key -> CommandStart -startKey to from afile key = - case (from, to) of - (Nothing, Nothing) -> error "specify either --from or --to" - (Nothing, Just r) -> mirrorto r - (Just r, Nothing) -> mirrorfrom r - _ -> error "only one of --from or --to can be specified" - where - mirrorto r = ifM (inAnnex key) - ( Command.Move.toStart r False afile key +seek :: MirrorOptions -> CommandSeek +seek o = withKeyOptions (keyOptions o) False + (startKey o Nothing) + (withFilesInGit $ whenAnnexed $ start o) + (mirrorFiles o) + +start :: MirrorOptions -> FilePath -> Key -> CommandStart +start o file = startKey o (Just file) + +startKey :: MirrorOptions -> Maybe FilePath -> Key -> CommandStart +startKey o afile key = case fromToOptions o of + ToRemote r -> ifM (inAnnex key) + ( Command.Move.toStart False afile key =<< getParsed r , do numcopies <- getnumcopies - Command.Drop.startRemote afile numcopies key r + Command.Drop.startRemote afile numcopies key =<< getParsed r ) - mirrorfrom r = do - haskey <- Remote.hasKey r key + FromRemote r -> do + haskey <- flip Remote.hasKey key =<< getParsed r case haskey of Left _ -> stop Right True -> Command.Get.start' (return True) Nothing key afile @@ -62,4 +68,5 @@ startKey to from afile key = Command.Drop.startLocal afile numcopies key Nothing , stop ) + where getnumcopies = maybe getNumCopies getFileNumCopies afile From 9ad20c2869feb94c19ea81d07f81d6605425b104 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 11 Jul 2015 00:42:32 -0400 Subject: [PATCH 40/54] converted Forget and TestRemote --- CmdLine/GitAnnex.hs | 12 ++++++------ Command/Forget.hs | 32 +++++++++++++++++--------------- Command/TestRemote.hs | 37 +++++++++++++++++++++---------------- 3 files changed, 44 insertions(+), 37 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index dd159385a8..a4d73877df 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -92,10 +92,10 @@ 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 #ifdef WITH_ASSISTANT --import qualified Command.Watch @@ -111,7 +111,7 @@ 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 @@ -197,10 +197,10 @@ cmds = , 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 #ifdef WITH_ASSISTANT -- , Command.Watch.cmd @@ -216,7 +216,7 @@ cmds = , Command.Test.cmd #ifdef WITH_TESTSUITE , Command.FuzzTest.cmd --- , Command.TestRemote.cmd + , Command.TestRemote.cmd #endif ] diff --git a/Command/Forget.hs b/Command/Forget.hs index 24789fe44c..584b56f8ae 100644 --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -16,28 +16,30 @@ import qualified Annex import Data.Time.Clock.POSIX cmd :: Command -cmd = withOptions forgetOptions $ - command "forget" SectionMaintenance - "prune git-annex branch history" - paramNothing (withParams seek) +cmd = command "forget" SectionMaintenance + "prune git-annex branch history" + paramNothing (seek <$$> optParser) -forgetOptions :: [Option] -forgetOptions = [dropDeadOption] +data ForgetOptions = ForgetOptions + { dropDead :: Bool + } -dropDeadOption :: Option -dropDeadOption = flagOption [] "drop-dead" "drop references to dead repositories" +optParser :: CmdParamsDesc -> Parser ForgetOptions +optParser _ = ForgetOptions + <$> switch + ( long "drop-dead" + <> help "drop references to dead repositories" + ) -seek :: CmdParams -> CommandSeek -seek ps = do - dropdead <- getOptionFlag dropDeadOption - withNothing (start dropdead) ps +seek :: ForgetOptions -> CommandSeek +seek = commandAction . start -start :: Bool -> CommandStart -start dropdead = do +start :: ForgetOptions -> CommandStart +start o = do showStart "forget" "git-annex" now <- liftIO getPOSIXTime let basets = addTransition now ForgetGitHistory noTransitions - let ts = if dropdead + let ts = if dropDead o then addTransition now ForgetDeadRemotes basets else basets next $ perform ts =<< Annex.getState Annex.force diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 250c6f41a2..e51dcaeb37 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -27,6 +27,7 @@ import Messages import Types.Messages import Remote.Helper.Chunked import Locations +import Git.Types import Test.Tasty import Test.Tasty.Runners @@ -37,25 +38,29 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map as M cmd :: Command -cmd = withOptions [sizeOption] $ - command "testremote" SectionTesting - "test transfers to/from a remote" - paramRemote (withParams seek) +cmd = command "testremote" SectionTesting + "test transfers to/from a remote" + paramRemote (seek <$$> optParser) -sizeOption :: Option -sizeOption = fieldOption [] "size" paramSize "base key size (default 1MiB)" +data TestRemoteOptions = TestRemoteOptions + { testRemote :: RemoteName + , sizeOption :: ByteSize + } -seek :: CmdParams -> CommandSeek -seek ps = do - basesz <- fromInteger . fromMaybe (1024 * 1024) - <$> getOptionField sizeOption (pure . getsize) - withWords (start basesz) ps - where - getsize v = v >>= readSize dataUnits +optParser :: CmdParamsDesc -> Parser TestRemoteOptions +optParser desc = TestRemoteOptions + <$> argument str ( metavar desc ) + <*> option (str >>= maybe (fail "parse error") return . readSize dataUnits) + ( long "size" <> metavar paramSize + <> value (1024 * 1024) + <> help "base key size (default 1MiB)" + ) -start :: Int -> [String] -> CommandStart -start basesz ws = do - let name = unwords ws +seek :: TestRemoteOptions -> CommandSeek +seek o = commandAction $ start (fromInteger $ sizeOption o) (testRemote o) + +start :: Int -> RemoteName -> CommandStart +start basesz name = do showStart "testremote" name r <- either error id <$> Remote.byName' name showSideAction "generating test keys" From 215f636bb375fa80226a2b05a718d5dbd62be854 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 11 Jul 2015 10:41:52 -0400 Subject: [PATCH 41/54] converted Info --- CmdLine/GitAnnex.hs | 4 +- Command/Info.hs | 111 ++++++++++++++++++++++++-------------------- 2 files changed, 63 insertions(+), 52 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index a4d73877df..bb925fb283 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -63,7 +63,7 @@ import qualified Command.List --import qualified Command.Log import qualified Command.Merge import qualified Command.ResolveMerge ---import qualified Command.Info +import qualified Command.Info --import qualified Command.Status import qualified Command.Migrate import qualified Command.Uninit @@ -190,7 +190,7 @@ cmds = -- , Command.Log.cmd , Command.Merge.cmd , Command.ResolveMerge.cmd --- , Command.Info.cmd + , Command.Info.cmd -- , Command.Status.cmd , Command.Migrate.cmd , Command.Map.cmd diff --git a/Command/Info.hs b/Command/Info.hs index 9b9e8f6ca9..a744f7402e 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -70,80 +70,94 @@ data StatInfo = StatInfo , referencedData :: Maybe KeyData , repoData :: M.Map UUID KeyData , numCopiesStats :: Maybe NumCopiesStats + , infoOptions :: InfoOptions } -emptyStatInfo :: StatInfo +emptyStatInfo :: InfoOptions -> StatInfo 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) $ +cmd = noCommit $ dontCheck repoExists $ withGlobalOptions (jsonOption : annexedMatchingOptions) $ command "info" SectionQuery "shows information about the specified item or the repository as a whole" - (paramRepeating paramItem) (withParams seek) + (paramRepeating paramItem) (seek <$$> optParser) -seek :: CmdParams -> CommandSeek -seek = withWords start +data InfoOptions = InfoOptions + { infoFor :: CmdParams + , bytesOption :: Bool + } -start :: [String] -> CommandStart -start [] = do - globalInfo +optParser :: CmdParamsDesc -> Parser InfoOptions +optParser desc = InfoOptions + <$> cmdParams desc + <*> switch + ( long "bytes" + <> help "display file sizes in bytes" + ) + +seek :: InfoOptions -> CommandSeek +seek o = withWords (start o) (infoFor o) + +start :: InfoOptions -> [String] -> CommandStart +start o [] = do + globalInfo o stop -start ps = do - mapM_ itemInfo ps +start o ps = do + mapM_ (itemInfo o) ps stop -globalInfo :: Annex () -globalInfo = do +globalInfo :: InfoOptions -> Annex () +globalInfo o = do stats <- selStats global_fast_stats global_slow_stats showCustom "info" $ do - evalStateT (mapM_ showStat stats) emptyStatInfo + evalStateT (mapM_ showStat stats) (emptyStatInfo o) return True -itemInfo :: String -> Annex () -itemInfo p = ifM (isdir p) - ( dirInfo p +itemInfo :: InfoOptions -> String -> Annex () +itemInfo o p = ifM (isdir p) + ( dirInfo o p , do v <- Remote.byName' p case v of - Right r -> remoteInfo r + Right r -> remoteInfo o r Left _ -> do v' <- Remote.nameToUUID' p case v' of - Right u -> uuidInfo u - Left _ -> maybe noinfo (fileInfo p) + Right u -> uuidInfo o u + Left _ -> maybe noinfo (fileInfo o p) =<< isAnnexLink p ) where isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus) noinfo = error $ p ++ " is not a directory or an annexed file or a remote or a uuid" -dirInfo :: FilePath -> Annex () -dirInfo dir = showCustom (unwords ["info", dir]) $ do +dirInfo :: InfoOptions -> FilePath -> Annex () +dirInfo o dir = showCustom (unwords ["info", dir]) $ do stats <- selStats (tostats dir_fast_stats) (tostats dir_slow_stats) - evalStateT (mapM_ showStat stats) =<< getDirStatInfo dir + evalStateT (mapM_ showStat stats) =<< getDirStatInfo o dir return True where tostats = map (\s -> s dir) -fileInfo :: FilePath -> Key -> Annex () -fileInfo file k = showCustom (unwords ["info", file]) $ do - evalStateT (mapM_ showStat (file_stats file k)) emptyStatInfo +fileInfo :: InfoOptions -> FilePath -> Key -> Annex () +fileInfo o file k = showCustom (unwords ["info", file]) $ do + evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o) return True -remoteInfo :: Remote -> Annex () -remoteInfo r = showCustom (unwords ["info", Remote.name r]) $ do +remoteInfo :: InfoOptions -> Remote -> Annex () +remoteInfo o r = showCustom (unwords ["info", Remote.name r]) $ do 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 + evalStateT (mapM_ showStat l) (emptyStatInfo o) return True -uuidInfo :: UUID -> Annex () -uuidInfo u = showCustom (unwords ["info", fromUUID u]) $ do +uuidInfo :: InfoOptions -> UUID -> Annex () +uuidInfo o u = showCustom (unwords ["info", fromUUID u]) $ do l <- selStats [] ((uuid_slow_stats u)) - evalStateT (mapM_ showStat l) emptyStatInfo + evalStateT (mapM_ showStat l) (emptyStatInfo o) return True selStats :: [Stat] -> [Stat] -> Annex [Stat] @@ -299,7 +313,7 @@ local_annex_keys = stat "local annex keys" $ json show $ local_annex_size :: Stat local_annex_size = simpleStat "local annex size" $ - lift . showSizeKeys =<< cachedPresentData + showSizeKeys =<< cachedPresentData remote_annex_keys :: UUID -> Stat remote_annex_keys u = stat "remote annex keys" $ json show $ @@ -307,7 +321,7 @@ remote_annex_keys u = stat "remote annex keys" $ json show $ remote_annex_size :: UUID -> Stat remote_annex_size u = simpleStat "remote annex size" $ - lift . showSizeKeys =<< cachedRemoteData u + showSizeKeys =<< cachedRemoteData u known_annex_files :: Stat known_annex_files = stat "annexed files in working tree" $ json show $ @@ -315,7 +329,7 @@ known_annex_files = stat "annexed files in working tree" $ json show $ known_annex_size :: Stat known_annex_size = simpleStat "size of annexed files in working tree" $ - lift . showSizeKeys =<< cachedReferencedData + showSizeKeys =<< cachedReferencedData tmp_size :: Stat tmp_size = staleSize "temporary object directory size" gitAnnexTmpObjectDir @@ -324,7 +338,7 @@ bad_data_size :: Stat bad_data_size = staleSize "bad keys size" gitAnnexBadDir key_size :: Key -> Stat -key_size k = simpleStat "size" $ lift $ showSizeKeys $ foldKeys [k] +key_size k = simpleStat "size" $ showSizeKeys $ foldKeys [k] key_name :: Key -> Stat key_name k = simpleStat "key" $ pure $ key2file k @@ -340,7 +354,7 @@ bloom_info = simpleStat "bloom filter size" $ do -- Two bloom filters are used at the same time when running -- git-annex unused, so double the size of one. - sizer <- lift mkSizer + sizer <- mkSizer size <- sizer memoryUnits False . (* 2) . fromIntegral . fst <$> lift bloomBitsHashes @@ -372,10 +386,10 @@ transfer_list = stat desc $ nojson $ lift $ do ] disk_size :: Stat -disk_size = simpleStat "available local disk space" $ lift $ +disk_size = simpleStat "available local disk space" $ calcfree - <$> (annexDiskReserve <$> Annex.getGitConfig) - <*> inRepo (getDiskFree . gitAnnexDir) + <$> (lift $ annexDiskReserve <$> Annex.getGitConfig) + <*> (lift $ inRepo $ getDiskFree . gitAnnexDir) <*> mkSizer where calcfree reserve (Just have) sizer = unwords @@ -409,7 +423,7 @@ numcopies_stats = stat "numcopies stats" $ json fmt $ reposizes_stats :: Stat reposizes_stats = stat desc $ nojson $ do - sizer <- lift mkSizer + sizer <- mkSizer l <- map (\(u, kd) -> (u, sizer storageUnits True (sizeKeys kd))) . sortBy (flip (comparing (sizeKeys . snd))) . M.toList @@ -466,14 +480,14 @@ cachedNumCopiesStats = numCopiesStats <$> get cachedRepoData :: StatState (M.Map UUID KeyData) cachedRepoData = repoData <$> get -getDirStatInfo :: FilePath -> Annex StatInfo -getDirStatInfo dir = do +getDirStatInfo :: InfoOptions -> FilePath -> Annex StatInfo +getDirStatInfo o dir = do fast <- Annex.getState Annex.fast matcher <- Limit.getMatcher (presentdata, referenceddata, numcopiesstats, repodata) <- Command.Unused.withKeysFilesReferencedIn dir initial (update matcher fast) - return $ StatInfo (Just presentdata) (Just referenceddata) repodata (Just numcopiesstats) + return $ StatInfo (Just presentdata) (Just referenceddata) repodata (Just numcopiesstats) o where initial = (emptyKeyData, emptyKeyData, emptyNumCopiesStats, M.empty) update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) = @@ -530,7 +544,7 @@ updateNumCopiesStats file (NumCopiesStats m) locs = do let !ret = NumCopiesStats m' return ret -showSizeKeys :: KeyData -> Annex String +showSizeKeys :: KeyData -> StatState String showSizeKeys d = do sizer <- mkSizer return $ total sizer ++ missingnote @@ -550,7 +564,7 @@ staleSize label dirspec = go =<< lift (dirKeys dirspec) onsize 0 = nostat onsize size = stat label $ json (++ aside "clean up with git-annex unused") $ do - sizer <- lift mkSizer + sizer <- mkSizer return $ sizer storageUnits False size keysizes keys = do dir <- lift $ fromRepo dirspec @@ -563,11 +577,8 @@ aside s = " (" ++ s ++ ")" multiLine :: [String] -> String multiLine = concatMap (\l -> "\n\t" ++ l) -mkSizer :: Annex ([Unit] -> Bool -> ByteSize -> String) -mkSizer = ifM (getOptionFlag bytesOption) +mkSizer :: StatState ([Unit] -> Bool -> ByteSize -> String) +mkSizer = ifM (bytesOption . infoOptions <$> get) ( return (const $ const show) , return roughSize ) - -bytesOption :: Option -bytesOption = flagOption [] "bytes" "display file sizes in bytes" From c6375a9158eb3fa7bd2f55df2153735ac1669bb0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 11 Jul 2015 10:42:46 -0400 Subject: [PATCH 42/54] converted Status --- CmdLine/GitAnnex.hs | 4 ++-- Command/Status.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index bb925fb283..74a831f8b8 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -64,7 +64,7 @@ import qualified Command.List import qualified Command.Merge import qualified Command.ResolveMerge import qualified Command.Info ---import qualified Command.Status +import qualified Command.Status import qualified Command.Migrate import qualified Command.Uninit import qualified Command.Reinit @@ -191,7 +191,7 @@ cmds = , Command.Merge.cmd , Command.ResolveMerge.cmd , Command.Info.cmd --- , Command.Status.cmd + , Command.Status.cmd , Command.Migrate.cmd , Command.Map.cmd , Command.Direct.cmd diff --git a/Command/Status.hs b/Command/Status.hs index c8aeaef0af..7c19185ac9 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -17,7 +17,7 @@ import qualified Git.Ref import qualified Git cmd :: Command -cmd = notBareRepo $ noCommit $ noMessages $ withOptions [jsonOption] $ +cmd = notBareRepo $ noCommit $ noMessages $ withGlobalOptions [jsonOption] $ command "status" SectionCommon "show the working tree status" paramPaths (withParams seek) From fdcb54d4f287b43a2bf818044b39dcd2d62fca4b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 11 Jul 2015 20:43:45 -0400 Subject: [PATCH 43/54] converted ContentLocation, ExampleKey, LookupKey --- CmdLine/Batch.hs | 35 ++++++++++++++++++++++++----------- CmdLine/GitAnnex.hs | 12 ++++++------ Command/ContentLocation.hs | 17 ++++++++--------- Command/ExamineKey.hs | 21 +++++++++------------ Command/LookupKey.hs | 21 +++++++++++---------- 5 files changed, 58 insertions(+), 48 deletions(-) diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs index 24f942978e..57823b67b8 100644 --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -10,29 +10,42 @@ module CmdLine.Batch where import Common.Annex import Command -batchOption :: Option -batchOption = flagOption [] "batch" "enable batch mode" - data BatchMode = Batch | NoBatch + +batchOption :: Parser BatchMode +batchOption = flag NoBatch Batch + ( long "batch" + <> help "enable batch mode" + ) + type Batchable t = BatchMode -> t -> CommandStart -- A Batchable command can run in batch mode, or not. -- 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) -> CmdParams -> CommandSeek) -> Batchable t -> CmdParams -> CommandSeek -batchable seeker starter params = ifM (getOptionFlag batchOption) - ( batchloop - , seeker (starter NoBatch) params - ) +batchable :: (opts -> String -> Annex Bool) -> Parser opts -> CmdParamsDesc -> CommandParser +batchable handler parser paramdesc = batchseeker <$> batchparser where - batchloop = do + batchparser = (,,) + <$> parser + <*> batchOption + <*> cmdParams paramdesc + + batchseeker (opts, NoBatch, params) = mapM_ (go NoBatch opts) params + batchseeker (opts, Batch, _) = batchloop opts + + batchloop opts = do mp <- liftIO $ catchMaybeIO getLine case mp of Nothing -> return () Just p -> do - seeker (starter Batch) [p] - batchloop + go Batch opts p + batchloop opts + + go batchmode opts p = + unlessM (handler opts p) $ + batchBadInput batchmode -- bad input is indicated by an empty line in batch mode. In non batch -- mode, exit on bad input. diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 74a831f8b8..c569519e58 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -23,9 +23,9 @@ import qualified Command.Move import qualified Command.Copy import qualified Command.Get import qualified Command.Fsck ---import qualified Command.LookupKey ---import qualified Command.ContentLocation ---import qualified Command.ExamineKey +import qualified Command.LookupKey +import qualified Command.ContentLocation +import qualified Command.ExamineKey import qualified Command.FromKey import qualified Command.RegisterUrl import qualified Command.SetKey @@ -158,9 +158,9 @@ cmds = , Command.Schedule.cmd , Command.Ungroup.cmd , Command.Vicfg.cmd --- , Command.LookupKey.cmd --- , Command.ContentLocation.cmd --- , Command.ExamineKey.cmd + , Command.LookupKey.cmd + , Command.ContentLocation.cmd + , Command.ExamineKey.cmd , Command.FromKey.cmd , Command.RegisterUrl.cmd , Command.SetKey.cmd diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs index bca73f9260..8a5eaa7a95 100644 --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -11,21 +11,20 @@ import Common.Annex import Command import CmdLine.Batch import Annex.Content +import Types.Key cmd :: Command -cmd = withOptions [batchOption] $ noCommit $ noMessages $ +cmd = noCommit $ noMessages $ command "contentlocation" SectionPlumbing "looks up content for a key" - (paramRepeating paramKey) (withParams seek) + (paramRepeating paramKey) + (batchable run (pure ())) -seek :: CmdParams -> CommandSeek -seek = batchable withKeys start - -start :: Batchable Key -start batchmode k = do - maybe (batchBadInput batchmode) (liftIO . putStrLn) +run :: () -> String -> Annex Bool +run _ p = do + let k = fromMaybe (error "bad key") $ file2key p + maybe (return False) (\f -> liftIO (putStrLn f) >> return True) =<< inAnnex' (pure True) Nothing check k - stop where check f = ifM (liftIO (doesFileExist f)) ( return (Just f) diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs index e0a1d9747d..55f72f71bb 100644 --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -11,21 +11,18 @@ import Common.Annex import Command import CmdLine.Batch import qualified Utility.Format -import Command.Find (FindOptions(..), showFormatted, keyVars) +import Command.Find (parseFormatOption, showFormatted, keyVars) import Types.Key cmd :: Command -cmd = noCommit $ noMessages $ withOptions [formatOption, jsonOption, batchOption] $ +cmd = noCommit $ noMessages $ withGlobalOptions [jsonOption] $ command "examinekey" SectionPlumbing "prints information from a key" - (paramRepeating paramKey) (withParams seek) + (paramRepeating paramKey) + (batchable run (optional parseFormatOption)) -seek :: CmdParams -> CommandSeek -seek ps = do - format <- getFormat - batchable withKeys (start format) ps - -start :: Maybe Utility.Format.Format -> Batchable Key -start format _ key = do - showFormatted format (key2file key) (keyVars key) - stop +run :: Maybe Utility.Format.Format -> String -> Annex Bool +run format p = do + let k = fromMaybe (error "bad key") $ file2key p + showFormatted format (key2file k) (keyVars k) + return True diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs index 021dc963bc..54023eab79 100644 --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -14,16 +14,17 @@ import Annex.CatFile import Types.Key cmd :: Command -cmd = withOptions [batchOption] $ notBareRepo $ noCommit $ noMessages $ +cmd = notBareRepo $ noCommit $ noMessages $ command "lookupkey" SectionPlumbing "looks up key used for file" - (paramRepeating paramFile) (withParams seek) + (paramRepeating paramFile) + (batchable run (pure ())) -seek :: CmdParams -> CommandSeek -seek = batchable withStrings start - -start :: Batchable String -start batchmode file = do - maybe (batchBadInput batchmode) (liftIO . putStrLn . key2file) - =<< catKeyFile file - stop +run :: () -> String -> Annex Bool +run _ file = do + mk <- catKeyFile file + case mk of + Just k -> do + liftIO $ putStrLn $ key2file k + return True + Nothing -> return False From adec382bc207b570ba2dcae17f509055a3ad739d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 12 Jul 2015 09:25:43 -0400 Subject: [PATCH 44/54] converted MetaData, eliminating a global value from Annex state .. beautiful --- Annex.hs | 3 -- CmdLine/GitAnnex.hs | 4 +- Command/MetaData.hs | 109 +++++++++++++++++++++----------------------- debian/changelog | 4 +- 4 files changed, 58 insertions(+), 62 deletions(-) diff --git a/Annex.hs b/Annex.hs index 48c6b6237e..78a6bf3699 100644 --- a/Annex.hs +++ b/Annex.hs @@ -57,7 +57,6 @@ import Types.UUID import Types.FileMatcher import Types.NumCopies import Types.LockCache -import Types.MetaData import Types.DesktopNotify import Types.CleanupActions #ifdef WITH_QUVI @@ -121,7 +120,6 @@ data AnnexState = AnnexState , lockcache :: LockCache , flags :: M.Map String Bool , fields :: M.Map String String - , modmeta :: [ModMeta] , cleanup :: M.Map CleanupAction (Annex ()) , sentinalstatus :: Maybe SentinalStatus , useragent :: Maybe String @@ -166,7 +164,6 @@ newState c r = AnnexState , lockcache = M.empty , flags = M.empty , fields = M.empty - , modmeta = [] , cleanup = M.empty , sentinalstatus = Nothing , useragent = Nothing diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index c569519e58..640507380a 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -36,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 @@ -171,7 +171,7 @@ cmds = , Command.ReadPresentKey.cmd , Command.CheckPresentKey.cmd , Command.ReKey.cmd --- , Command.MetaData.cmd + , Command.MetaData.cmd , Command.View.cmd , Command.VAdd.cmd , Command.VFilter.cmd diff --git a/Command/MetaData.hs b/Command/MetaData.hs index 3b38c8b95d..b0076b4cd2 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -8,7 +8,6 @@ module Command.MetaData where import Common.Annex -import qualified Annex import Command import Annex.MetaData import Logs.MetaData @@ -17,71 +16,69 @@ import qualified Data.Set as S import Data.Time.Clock.POSIX cmd :: Command -cmd = withOptions metaDataOptions $ - command "metadata" - SectionMetaData "sets or gets metadata of a file" - paramPaths (withParams seek) +cmd = withGlobalOptions ([jsonOption] ++ annexedMatchingOptions) $ + command "metadata" SectionMetaData + "sets or gets metadata of a file" + paramPaths (seek <$$> optParser) -metaDataOptions :: [Option] -metaDataOptions = - [ setOption - , tagOption - , untagOption - , getOption - , jsonOption - ] ++ keyOptions ++ annexedMatchingOptions +data MetaDataOptions = MetaDataOptions + { forFiles :: CmdParams + , getSet :: GetSet + , keyOptions :: Maybe KeyOptions + } -storeModMeta :: ModMeta -> Annex () -storeModMeta modmeta = Annex.changeState $ - \s -> s { Annex.modmeta = modmeta:Annex.modmeta s } +data GetSet = Get MetaField | Set [ModMeta] -setOption :: Option -setOption = Option ['s'] ["set"] (ReqArg mkmod "FIELD[+-]=VALUE") "set metadata" +optParser :: CmdParamsDesc -> Parser MetaDataOptions +optParser desc = MetaDataOptions + <$> cmdParams desc + <*> ((Get <$> getopt) <|> (Set <$> many modopts)) + <*> optional (parseKeyOptions False) where - mkmod = either error storeModMeta . parseModMeta + getopt = option (eitherReader mkMetaField) + ( long "get" <> short 'g' <> metavar paramField + <> help "get single metadata field" + ) + modopts = option (eitherReader parseModMeta) + ( long "set" <> short 's' <> metavar "FIELD[+-]=VALUE" + <> help "set or unset metadata value" + ) + <|> (AddMeta tagMetaField . toMetaValue <$> strOption + ( long "tag" <> short 't' <> metavar "TAG" + <> help "set a tag" + )) + <|> (AddMeta tagMetaField . mkMetaValue (CurrentlySet False) <$> strOption + ( long "untag" <> short 'u' <> metavar "TAG" + <> help "remove a tag" + )) -getOption :: Option -getOption = fieldOption ['g'] "get" paramField "get single metadata field" - -tagOption :: Option -tagOption = Option ['t'] ["tag"] (ReqArg mkmod "TAG") "set a tag" - where - mkmod = storeModMeta . AddMeta tagMetaField . toMetaValue - -untagOption :: Option -untagOption = Option ['u'] ["untag"] (ReqArg mkmod "TAG") "remove a tag" - where - mkmod = storeModMeta . AddMeta tagMetaField . mkMetaValue (CurrentlySet False) - -seek :: CmdParams -> CommandSeek -seek ps = do - modmeta <- Annex.getState Annex.modmeta - getfield <- getOptionField getOption $ \ms -> - return $ either error id . mkMetaField <$> ms +seek :: MetaDataOptions -> CommandSeek +seek o = do now <- liftIO getPOSIXTime - let seeker = if null modmeta - then withFilesInGit - else withFilesInGitNonRecursive - withKeyOptions False - (startKeys now getfield modmeta) - (seeker $ whenAnnexed $ start now getfield modmeta) - ps + let seeker = case getSet o of + Get _ -> withFilesInGit + Set _ -> withFilesInGitNonRecursive + withKeyOptions (keyOptions o) False + (startKeys now o) + (seeker $ whenAnnexed $ start now o) + (forFiles o) -start :: POSIXTime -> Maybe MetaField -> [ModMeta] -> FilePath -> Key -> CommandStart -start now f ms file = start' (Just file) now f ms +start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart +start now o file = start' (Just file) now o -startKeys :: POSIXTime -> Maybe MetaField -> [ModMeta] -> Key -> CommandStart +startKeys :: POSIXTime -> MetaDataOptions -> Key -> CommandStart startKeys = start' Nothing -start' :: AssociatedFile -> POSIXTime -> Maybe MetaField -> [ModMeta] -> Key -> CommandStart -start' afile now Nothing ms k = do - showStart' "metadata" k afile - next $ perform now ms k -start' _ _ (Just f) _ k = do - l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k - liftIO $ forM_ l $ - putStrLn . fromMetaValue - stop +start' :: AssociatedFile -> POSIXTime -> MetaDataOptions -> Key -> CommandStart +start' afile now o k = case getSet o of + Set ms -> do + showStart' "metadata" k afile + next $ perform now ms k + Get f -> do + l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k + liftIO $ forM_ l $ + putStrLn . fromMetaValue + stop perform :: POSIXTime -> [ModMeta] -> Key -> CommandPerform perform _ [] k = next $ cleanup k diff --git a/debian/changelog b/debian/changelog index 118ff330c2..f4d6c51c32 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,8 @@ * 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. + edge cases of option parsing. (For example, the metadata command no + longer accepts the combination of --get and --set, which never actually + worked.) * 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. From 3d8a8e979219cb1db07befa133087c22f6574663 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 10:26:54 -0400 Subject: [PATCH 45/54] convert Dead, and allow multiple --key options --- CmdLine/GitAnnex.hs | 4 ++-- Command/Dead.hs | 25 ++++++++++++++----------- debian/changelog | 1 + 3 files changed, 17 insertions(+), 13 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 640507380a..37f5ce8ba9 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -72,7 +72,7 @@ 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 @@ -150,7 +150,7 @@ cmds = , Command.Trust.cmd , Command.Untrust.cmd , Command.Semitrust.cmd --- , Command.Dead.cmd + , Command.Dead.cmd , Command.Group.cmd , Command.Wanted.cmd , Command.GroupWanted.cmd diff --git a/Command/Dead.hs b/Command/Dead.hs index e487b3b5e1..04c754d07b 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -9,26 +9,29 @@ module Command.Dead where import Command import Common.Annex -import qualified Annex import Types.TrustLevel import Types.Key import Command.Trust (trustCommand) import Logs.Location import Remote (keyLocations) +import Git.Types cmd :: Command -cmd = withOptions [keyOption] $ - command "dead" SectionSetup "hide a lost repository or key" - (paramRepeating paramRemote) (withParams seek) +cmd = command "dead" SectionSetup "hide a lost repository or key" + (paramRepeating paramRemote) (seek <$$> optParser) -seek :: CmdParams -> CommandSeek -seek ps = maybe (trustCommand "dead" DeadTrusted ps) (flip seekKey ps) - =<< Annex.getField "key" +data DeadOptions = DeadRemotes [RemoteName] | DeadKeys [Key] -seekKey :: String -> CmdParams -> CommandSeek -seekKey ks = case file2key ks of - Nothing -> error "Invalid key" - Just key -> withNothing (startKey key) +optParser :: CmdParamsDesc -> Parser DeadOptions +optParser desc = (DeadRemotes <$> cmdParams desc) + <|> (DeadKeys <$> many (option (str >>= parseKey) + ( long "key" <> metavar paramKey + <> help "keys whose content has been irretrievably lost" + ))) + +seek :: DeadOptions -> CommandSeek +seek (DeadRemotes rs) = trustCommand "dead" DeadTrusted rs +seek (DeadKeys ks) = seekActions $ pure $ map startKey ks startKey :: Key -> CommandStart startKey key = do diff --git a/debian/changelog b/debian/changelog index f4d6c51c32..36cde0735b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -6,6 +6,7 @@ * 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. + * dead now accepts multiple --key options. git-annex (5.20150710) unstable; urgency=medium From 3639b4f8eabed3d05ec0f5e92ab89f8e57dd5436 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 10:44:51 -0400 Subject: [PATCH 46/54] converted Log --- CmdLine/GitAnnex.hs | 4 +-- Command/Log.hs | 63 ++++++++++++++++++++++++++------------------- 2 files changed, 38 insertions(+), 29 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 37f5ce8ba9..bbd66eca8d 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -60,7 +60,7 @@ import qualified Command.Find import qualified Command.FindRef import qualified Command.Whereis import qualified Command.List ---import qualified Command.Log +import qualified Command.Log import qualified Command.Merge import qualified Command.ResolveMerge import qualified Command.Info @@ -187,7 +187,7 @@ cmds = , Command.FindRef.cmd , Command.Whereis.cmd , Command.List.cmd --- , Command.Log.cmd + , Command.Log.cmd , Command.Merge.cmd , Command.ResolveMerge.cmd , Command.Info.cmd diff --git a/Command/Log.hs b/Command/Log.hs index eb740b2495..86b32b9372 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -39,52 +39,61 @@ data RefChange = RefChange type Outputter = Bool -> POSIXTime -> [UUID] -> Annex () cmd :: Command -cmd = withGlobalOptions options $ +cmd = withGlobalOptions annexedMatchingOptions $ command "log" SectionQuery "shows location log" - paramPaths (withParams seek) + paramPaths (seek <$$> optParser) -options :: [GlobalOption] -options = passthruOptions ++ [gourceOption] ++ annexedMatchingOptions +data LogOptions = LogOptions + { logFiles :: CmdParams + , gourceOption :: Bool + , passthruOptions :: [CommandParam] + } -passthruOptions :: [Option] -passthruOptions = map odate ["since", "after", "until", "before"] ++ - [ fieldOption ['n'] "max-count" paramNumber - "limit number of logs displayed" - ] +optParser :: CmdParamsDesc -> Parser LogOptions +optParser desc = LogOptions + <$> cmdParams desc + <*> switch + ( long "gource" + <> help "format output for gource" + ) + <*> (concat <$> many passthru) where - odate n = fieldOption [] n paramDate $ "show log " ++ n ++ " date" + passthru :: Parser [CommandParam] + passthru = datepassthru "since" + <|> datepassthru "after" + <|> datepassthru "until" + <|> datepassthru "before" + <|> (mkpassthru "max-count" <$> strOption + ( long "max-count" <> metavar paramNumber + <> help "limit number of logs displayed" + )) + datepassthru n = mkpassthru n <$> strOption + ( long n <> metavar paramDate + <> help ("show log " ++ n ++ " date") + ) + mkpassthru n v = [Param ("--" ++ n), Param v] -gourceOption :: Option -gourceOption = flagOption [] "gource" "format output for gource" - -seek :: CmdParams -> CommandSeek -seek ps = do +seek :: LogOptions -> CommandSeek +seek o = do m <- Remote.uuidDescriptions zone <- liftIO getCurrentTimeZone - os <- concat <$> mapM getoption passthruOptions - gource <- getOptionFlag gourceOption - withFilesInGit (whenAnnexed $ start m zone os gource) ps - where - getoption o = maybe [] (use o) <$> - Annex.getField (optionName o) - use o v = [Param ("--" ++ optionName o), Param v] + withFilesInGit (whenAnnexed $ start m zone o) (logFiles o) start :: M.Map UUID String -> TimeZone - -> [CommandParam] - -> Bool + -> LogOptions -> FilePath -> Key -> CommandStart -start m zone os gource file key = do - showLog output =<< readLog <$> getLog key os +start m zone o file key = do + showLog output =<< readLog <$> getLog key (passthruOptions o) -- getLog produces a zombie; reap it liftIO reapZombies stop where output - | gource = gourceOutput lookupdescription file + | (gourceOption o) = gourceOutput lookupdescription file | otherwise = normalOutput lookupdescription file zone lookupdescription u = fromMaybe (fromUUID u) $ M.lookup u m From aff4b9a3dcf744e2bf089b9e913185dcf79a6543 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 10:57:49 -0400 Subject: [PATCH 47/54] converted addurl --- CmdLine/GitAnnex.hs | 4 ++-- Command/AddUrl.hs | 57 +++++++++++++++++++++++++++------------------ 2 files changed, 36 insertions(+), 25 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index bbd66eca8d..cdeac1b512 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -82,7 +82,7 @@ import qualified Command.Ungroup import qualified Command.Vicfg import qualified Command.Sync import qualified Command.Mirror ---import qualified Command.AddUrl +import qualified Command.AddUrl #ifdef WITH_FEED --import qualified Command.ImportFeed #endif @@ -131,7 +131,7 @@ cmds = , Command.Lock.cmd , Command.Sync.cmd , Command.Mirror.cmd --- , Command.AddUrl.cmd + , Command.AddUrl.cmd #ifdef WITH_FEED -- , Command.ImportFeed.cmd #endif diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 45edca283c..ed76e6c35e 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -38,33 +38,44 @@ import qualified Utility.Quvi as Quvi #endif cmd :: Command -cmd = notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption, rawOption] $ +cmd = notBareRepo $ command "addurl" SectionCommon "add urls to annex" - (paramRepeating paramUrl) (withParams seek) + (paramRepeating paramUrl) (seek <$$> optParser) -fileOption :: Option -fileOption = fieldOption [] "file" paramFile "specify what file the url is added to" +data AddUrlOptions = AddUrlOptions + { addUrls :: CmdParams + , fileOption :: Maybe FilePath + , pathdepthOption :: Maybe Int + , relaxedOption :: Bool + , rawOption :: Bool + } -pathdepthOption :: Option -pathdepthOption = fieldOption [] "pathdepth" paramNumber "path components to use in filename" +optParser :: CmdParamsDesc -> Parser AddUrlOptions +optParser desc = AddUrlOptions + <$> cmdParams desc + <*> optional (strOption + ( long "file" <> metavar paramFile + <> help "specify what file the url is added to" + )) + <*> optional (option auto + ( long "pathdepth" <> metavar paramNumber + <> help "path components to use in filename" + )) + <*> switch + ( long "relaxed" + <> help "skip size check" + ) + <*> switch + ( long "raw" + <> help "disable special handling for torrents, quvi, etc" + ) -relaxedOption :: Option -relaxedOption = flagOption [] "relaxed" "skip size check" - -rawOption :: Option -rawOption = flagOption [] "raw" "disable special handling for torrents, quvi, etc" - -seek :: CmdParams -> CommandSeek -seek us = do - optfile <- getOptionField fileOption return - relaxed <- getOptionFlag relaxedOption - raw <- getOptionFlag rawOption - pathdepth <- getOptionField pathdepthOption (return . maybe Nothing readish) - forM_ us $ \u -> do - r <- Remote.claimingUrl u - if Remote.uuid r == webUUID || raw - then void $ commandAction $ startWeb relaxed optfile pathdepth u - else checkUrl r u optfile relaxed pathdepth +seek :: AddUrlOptions -> CommandSeek +seek o = forM_ (addUrls o) $ \u -> do + r <- Remote.claimingUrl u + if Remote.uuid r == webUUID || rawOption o + then void $ commandAction $ startWeb (relaxedOption o) (fileOption o) (pathdepthOption o) u + else checkUrl r u (fileOption o) (relaxedOption o) (pathdepthOption o) checkUrl :: Remote -> URLString -> Maybe FilePath -> Bool -> Maybe Int -> Annex () checkUrl r u optfile relaxed pathdepth = do From 9c1a42873ca4376bd58223959a17715051d27ebf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 11:06:41 -0400 Subject: [PATCH 48/54] converted ImportFeed --- CmdLine/GitAnnex.hs | 4 +-- Command/AddUrl.hs | 22 +++++++++++------ Command/ImportFeed.hs | 57 +++++++++++++++++++++++-------------------- 3 files changed, 47 insertions(+), 36 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index cdeac1b512..21e7803982 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -84,7 +84,7 @@ import qualified Command.Sync 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 @@ -133,7 +133,7 @@ cmds = , Command.Mirror.cmd , Command.AddUrl.cmd #ifdef WITH_FEED --- , Command.ImportFeed.cmd + , Command.ImportFeed.cmd #endif , Command.RmUrl.cmd -- , Command.Import.cmd diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index ed76e6c35e..4ae80d9d42 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -61,14 +61,20 @@ optParser desc = AddUrlOptions ( long "pathdepth" <> metavar paramNumber <> help "path components to use in filename" )) - <*> switch - ( long "relaxed" - <> help "skip size check" - ) - <*> switch - ( long "raw" - <> help "disable special handling for torrents, quvi, etc" - ) + <*> parseRelaxedOption + <*> parseRawOption + +parseRelaxedOption :: Parser Bool +parseRelaxedOption = switch + ( long "relaxed" + <> help "skip size check" + ) + +parseRawOption :: Parser Bool +parseRawOption = switch + ( long "raw" + <> help "disable special handling for torrents, quvi, etc" + ) seek :: AddUrlOptions -> CommandSeek seek o = forM_ (addUrls o) $ \u -> do diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index 5e4869b306..5afbb192a7 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -30,7 +30,7 @@ import Types.UrlContents import Logs.Web import qualified Utility.Format import Utility.Tmp -import Command.AddUrl (addUrlFile, downloadRemoteFile, relaxedOption, rawOption) +import Command.AddUrl (addUrlFile, downloadRemoteFile, parseRelaxedOption, parseRawOption) import Annex.Perms import Annex.UUID import Backend.URL (fromUrl) @@ -44,33 +44,38 @@ import Logs.MetaData import Annex.MetaData cmd :: Command -cmd = notBareRepo $ withOptions [templateOption, relaxedOption, rawOption] $ +cmd = notBareRepo $ command "importfeed" SectionCommon "import files from podcast feeds" - (paramRepeating paramUrl) (withParams seek) + (paramRepeating paramUrl) (seek <$$> optParser) -templateOption :: Option -templateOption = fieldOption [] "template" paramFormat "template for filenames" - -seek :: CmdParams -> CommandSeek -seek ps = do - tmpl <- getOptionField templateOption return - relaxed <- getOptionFlag relaxedOption - raw <- getOptionFlag rawOption - let opts = Opts { relaxedOpt = relaxed, rawOpt = raw } - cache <- getCache tmpl - withStrings (start opts cache) ps - -data Opts = Opts - { relaxedOpt :: Bool - , rawOpt :: Bool +data ImportFeedOptions = ImportFeedOptions + { feedUrls :: CmdParams + , templateOption :: Maybe String + , relaxedOption :: Bool + , rawOption :: Bool } -start :: Opts -> Cache -> URLString -> CommandStart +optParser :: CmdParamsDesc -> Parser ImportFeedOptions +optParser desc = ImportFeedOptions + <$> cmdParams desc + <*> optional (strOption + ( long "template" <> metavar paramFormat + <> help "template for filenames" + )) + <*> parseRelaxedOption + <*> parseRawOption + +seek :: ImportFeedOptions -> CommandSeek +seek o = do + cache <- getCache (templateOption o) + withStrings (start o cache) (feedUrls o) + +start :: ImportFeedOptions -> Cache -> URLString -> CommandStart start opts cache url = do showStart "importfeed" url next $ perform opts cache url -perform :: Opts -> Cache -> URLString -> CommandPerform +perform :: ImportFeedOptions -> Cache -> URLString -> CommandPerform perform opts cache url = do v <- findDownloads url case v of @@ -160,15 +165,15 @@ downloadFeed url , return Nothing ) -performDownload :: Opts -> Cache -> ToDownload -> Annex Bool +performDownload :: ImportFeedOptions -> Cache -> ToDownload -> Annex Bool performDownload opts cache todownload = case location todownload of Enclosure url -> checkknown url $ rundownload url (takeExtension url) $ \f -> do r <- Remote.claimingUrl url - if Remote.uuid r == webUUID || rawOpt opts + if Remote.uuid r == webUUID || rawOption opts then do urlinfo <- Url.withUrlOptions (Url.getUrlInfo url) - maybeToList <$> addUrlFile (relaxedOpt opts) url urlinfo f + maybeToList <$> addUrlFile (relaxedOption opts) url urlinfo f else do res <- tryNonAsync $ maybe (error $ "unable to checkUrl of " ++ Remote.name r) @@ -178,10 +183,10 @@ performDownload opts cache todownload = case location todownload of Left _ -> return [] Right (UrlContents sz _) -> maybeToList <$> - downloadRemoteFile r (relaxedOpt opts) url f sz + downloadRemoteFile r (relaxedOption opts) url f sz Right (UrlMulti l) -> do kl <- forM l $ \(url', sz, subf) -> - downloadRemoteFile r (relaxedOpt opts) url' (f fromSafeFilePath subf) sz + downloadRemoteFile r (relaxedOption opts) url' (f fromSafeFilePath subf) sz return $ if all isJust kl then catMaybes kl else [] @@ -199,7 +204,7 @@ performDownload opts cache todownload = case location todownload of let videourl = Quvi.linkUrl link checkknown videourl $ rundownload videourl ("." ++ fromMaybe "m" (Quvi.linkSuffix link)) $ \f -> - maybeToList <$> addUrlFileQuvi (relaxedOpt opts) quviurl videourl f + maybeToList <$> addUrlFileQuvi (relaxedOption opts) quviurl videourl f #else return False #endif From 084f8d9ac77c661f5796ff32a47a08c2b1605def Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 11:15:21 -0400 Subject: [PATCH 49/54] convert Import --- CmdLine/GitAnnex.hs | 4 +-- Command/Import.hs | 69 ++++++++++++++++++++++----------------------- 2 files changed, 35 insertions(+), 38 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 21e7803982..ede943804b 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -87,7 +87,7 @@ import qualified Command.AddUrl 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 @@ -136,7 +136,7 @@ cmds = , Command.ImportFeed.cmd #endif , Command.RmUrl.cmd --- , Command.Import.cmd + , Command.Import.cmd , Command.Init.cmd , Command.Describe.cmd , Command.InitRemote.cmd diff --git a/Command/Import.hs b/Command/Import.hs index 684641ea31..e846181733 100644 --- a/Command/Import.hs +++ b/Command/Import.hs @@ -23,53 +23,50 @@ import Types.TrustLevel import Logs.Trust cmd :: Command -cmd = withOptions opts $ notBareRepo $ +cmd = withGlobalOptions fileMatchingOptions $ notBareRepo $ command "import" SectionCommon "move and add files from outside git working copy" - paramPaths (withParams seek) - -opts :: [GlobalOption] -opts = duplicateModeOptions ++ fileMatchingOptions + paramPaths (seek <$$> optParser) data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates - deriving (Eq, Enum, Bounded) + deriving (Eq) -associatedOption :: DuplicateMode -> Maybe Option -associatedOption Default = Nothing -associatedOption Duplicate = Just $ - flagOption [] "duplicate" "do not delete source files" -associatedOption DeDuplicate = Just $ - flagOption [] "deduplicate" "delete source files whose content was imported before" -associatedOption CleanDuplicates = Just $ - flagOption [] "clean-duplicates" "delete duplicate source files (import nothing)" -associatedOption SkipDuplicates = Just $ - flagOption [] "skip-duplicates" "import only new files" +data ImportOptions = ImportOptions + { importFiles :: CmdParams + , duplicateMode :: DuplicateMode + } -duplicateModeOptions :: [Option] -duplicateModeOptions = mapMaybe associatedOption [minBound..maxBound] +optParser :: CmdParamsDesc -> Parser ImportOptions +optParser desc = ImportOptions + <$> cmdParams desc + <*> (fromMaybe Default <$> optional duplicateModeParser) -getDuplicateMode :: Annex DuplicateMode -getDuplicateMode = go . catMaybes <$> mapM getflag [minBound..maxBound] - where - getflag m = case associatedOption m of - Nothing -> return Nothing - Just o -> ifM (Annex.getFlag (optionName o)) - ( return (Just m) - , return Nothing - ) - go [] = Default - go [m] = m - go ms = error $ "cannot combine " ++ - unwords (map (optionParam . fromJust . associatedOption) ms) +duplicateModeParser :: Parser DuplicateMode +duplicateModeParser = + flag' Duplicate + ( long "duplicate" + <> help "do not delete source files" + ) + <|> flag' DeDuplicate + ( long "deduplicate" + <> help "delete source files whose content was imported before" + ) + <|> flag' CleanDuplicates + ( long "clean-duplicates" + <> help "delete duplicate source files (import nothing)" + ) + <|> flag' SkipDuplicates + ( long "skip-duplicates" + <> help "import only new files" + ) -seek :: CmdParams -> CommandSeek -seek ps = do - mode <- getDuplicateMode +seek :: ImportOptions -> CommandSeek +seek o = do repopath <- liftIO . absPath =<< fromRepo Git.repoPath - inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath ps + inrepops <- liftIO $ filter (dirContains repopath) <$> mapM absPath (importFiles o) unless (null inrepops) $ do error $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops - withPathContents (start mode) ps + withPathContents (start (duplicateMode o)) (importFiles o) start :: DuplicateMode -> (FilePath, FilePath) -> CommandStart start mode (srcfile, destfile) = From b95a48fe45a240ec0a8039594c3ccb1d1d303cef Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 11:42:42 -0400 Subject: [PATCH 50/54] converted Assistant and Watch; avoid duplicate arg parsing for no repo mode --- CmdLine/GitAnnex.hs | 8 ++-- CmdLine/GitAnnex/Options.hs | 16 +++++++ Command/Assistant.hs | 89 +++++++++++++++++-------------------- Command/Watch.hs | 25 ++++------- Command/XMPPGit.hs | 2 +- debian/changelog | 1 + 6 files changed, 71 insertions(+), 70 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index ede943804b..28a741b790 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -98,8 +98,8 @@ import qualified Command.DiffDriver import qualified Command.Undo import qualified Command.Version #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 #endif @@ -203,8 +203,8 @@ cmds = , Command.Undo.cmd , Command.Version.cmd #ifdef WITH_ASSISTANT --- , Command.Watch.cmd --- , Command.Assistant.cmd + , Command.Watch.cmd + , Command.Assistant.cmd #ifdef WITH_WEBAPP -- , Command.WebApp.cmd #endif diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index f95a4d03eb..a050f57e39 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -285,3 +285,19 @@ timeLimitOption = globalSetter Limit.addTimeLimit $ strOption <> help "stop after the specified amount of time" <> hidden ) + +data DaemonOptions = DaemonOptions + { foregroundDaemonOption :: Bool + , stopDaemonOption :: Bool + } + +parseDaemonOptions :: Parser DaemonOptions +parseDaemonOptions = DaemonOptions + <$> switch + ( long "foreground" + <> help "do not daemonize" + ) + <*> switch + ( long "stop" + <> help "stop daemon" + ) diff --git a/Command/Assistant.hs b/Command/Assistant.hs index 08e96da076..836be7b67d 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -1,6 +1,6 @@ {- git-annex assistant - - - Copyright 2012 Joey Hess + - Copyright 2012-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -17,67 +17,60 @@ import qualified Build.SysConfig import Utility.HumanTime import Assistant.Install -import System.Environment - cmd :: Command -cmd = dontCheck repoExists $ withOptions options $ notBareRepo $ - noRepo (withParams checkNoRepoOpts) $ +cmd = dontCheck repoExists $ notBareRepo $ + noRepo (startNoRepo <$$> optParser) $ command "assistant" SectionCommon "automatically sync changes" - paramNothing (withParams seek) + paramNothing (seek <$$> optParser) -options :: [Option] -options = - [ Command.Watch.foregroundOption - , Command.Watch.stopOption - , autoStartOption - , startDelayOption - , autoStopOption - ] +data AssistantOptions = AssistantOptions + { daemonOptions :: DaemonOptions + , autoStartOption :: Bool + , startDelayOption :: Maybe Duration + , autoStopOption :: Bool + } -autoStartOption :: Option -autoStartOption = flagOption [] "autostart" "start in known repositories" +optParser :: CmdParamsDesc -> Parser AssistantOptions +optParser _ = AssistantOptions + <$> parseDaemonOptions + <*> switch + ( long "autostart" + <> help "start in known repositories" + ) + <*> optional (option (str >>= parseDuration) + ( long "startdelay" <> metavar paramNumber + <> help "delay before running startup scan" + )) + <*> switch + ( long "autostop" + <> help "stop in known repositories" + ) -autoStopOption :: Option -autoStopOption = flagOption [] "autostop" "stop in known repositories" +seek :: AssistantOptions -> CommandSeek +seek = commandAction . start -startDelayOption :: Option -startDelayOption = fieldOption [] "startdelay" paramNumber "delay before running startup scan" - -seek :: CmdParams -> CommandSeek -seek ps = do - stopdaemon <- getOptionFlag Command.Watch.stopOption - foreground <- getOptionFlag Command.Watch.foregroundOption - autostart <- getOptionFlag autoStartOption - autostop <- getOptionFlag autoStopOption - startdelay <- getOptionField startDelayOption (pure . maybe Nothing parseDuration) - withNothing (start foreground stopdaemon autostart autostop startdelay) ps - -start :: Bool -> Bool -> Bool -> Bool -> Maybe Duration -> CommandStart -start foreground stopdaemon autostart autostop startdelay - | autostart = do - liftIO $ autoStart startdelay +start :: AssistantOptions -> CommandStart +start o + | autoStartOption o = do + liftIO $ autoStart o stop - | autostop = do + | autoStopOption o = do liftIO autoStop stop | otherwise = do liftIO ensureInstalled ensureInitialized - Command.Watch.start True foreground stopdaemon startdelay + Command.Watch.start True (daemonOptions o) (startDelayOption o) -{- Run outside a git repository; support autostart and autostop mode. -} -checkNoRepoOpts :: CmdParams -> IO () -checkNoRepoOpts _ = ifM (elem "--autostart" <$> getArgs) - ( autoStart Nothing - , ifM (elem "--autostop" <$> getArgs) - ( autoStop - , error "Not in a git repository." - ) - ) +startNoRepo :: AssistantOptions -> IO () +startNoRepo o + | autoStartOption o = autoStart o + | autoStopOption o = autoStop + | otherwise = error "Not in a git repository." -autoStart :: Maybe Duration -> IO () -autoStart startdelay = do +autoStart :: AssistantOptions -> IO () +autoStart o = do dirs <- liftIO readAutoStartFile when (null dirs) $ do f <- autoStartFile @@ -105,7 +98,7 @@ autoStart startdelay = do where baseparams = [ Param "assistant" - , Param $ "--startdelay=" ++ fromDuration (fromMaybe (Duration 5) startdelay) + , Param $ "--startdelay=" ++ fromDuration (fromMaybe (Duration 5) (startDelayOption o)) ] autoStop :: IO () diff --git a/Command/Watch.hs b/Command/Watch.hs index cc7356ddfe..ac2f273978 100644 --- a/Command/Watch.hs +++ b/Command/Watch.hs @@ -13,26 +13,17 @@ import Command import Utility.HumanTime cmd :: Command -cmd = notBareRepo $ withOptions [foregroundOption, stopOption] $ +cmd = notBareRepo $ command "watch" SectionCommon "watch for changes and autocommit" - paramNothing (withParams seek) + paramNothing (seek <$$> const parseDaemonOptions) -seek :: CmdParams -> CommandSeek -seek ps = do - stopdaemon <- getOptionFlag stopOption - foreground <- getOptionFlag foregroundOption - withNothing (start False foreground stopdaemon Nothing) ps +seek :: DaemonOptions -> CommandSeek +seek o = commandAction $ start False o Nothing -foregroundOption :: Option -foregroundOption = flagOption [] "foreground" "do not daemonize" - -stopOption :: Option -stopOption = flagOption [] "stop" "stop daemon" - -start :: Bool -> Bool -> Bool -> Maybe Duration -> CommandStart -start assistant foreground stopdaemon startdelay = do - if stopdaemon +start :: Bool -> DaemonOptions -> Maybe Duration -> CommandStart +start assistant o startdelay = do + if stopDaemonOption o then stopDaemon - else startDaemon assistant foreground startdelay Nothing Nothing Nothing -- does not return + else startDaemon assistant (foregroundDaemonOption o) startdelay Nothing Nothing Nothing -- does not return stop diff --git a/Command/XMPPGit.hs b/Command/XMPPGit.hs index 86d8dbc112..20e7f07430 100644 --- a/Command/XMPPGit.hs +++ b/Command/XMPPGit.hs @@ -22,7 +22,7 @@ cmd = noCommit $ dontCheck repoExists $ seek :: CmdParams -> CommandSeek seek = withWords start -start :: [String] -> CommandStart +start :: CmdParams -> CommandStart start _ = do liftIO gitRemoteHelper liftIO xmppGitRelay diff --git a/debian/changelog b/debian/changelog index 36cde0735b..71b08394ae 100644 --- a/debian/changelog +++ b/debian/changelog @@ -6,6 +6,7 @@ * 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. + * assistant --startdelay now works when run outside a git repository. * dead now accepts multiple --key options. git-annex (5.20150710) unstable; urgency=medium From fd086c57528919fbf639fe5243af19b600fb4bd9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 11:53:42 -0400 Subject: [PATCH 51/54] convert WebApp; avoid duplicate arg parsing for no repo mode --- CmdLine/GitAnnex.hs | 4 +-- Command/WebApp.hs | 79 +++++++++++++++++++++------------------------ 2 files changed, 39 insertions(+), 44 deletions(-) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 28a741b790..9c60956f6c 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -101,7 +101,7 @@ import qualified Command.Version 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 @@ -206,7 +206,7 @@ cmds = , Command.Watch.cmd , Command.Assistant.cmd #ifdef WITH_WEBAPP --- , Command.WebApp.cmd + , Command.WebApp.cmd #endif #ifdef WITH_XMPP , Command.XMPPGit.cmd diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 2e41ebe7df..f2935380d1 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -34,35 +34,37 @@ import Annex.Version import Control.Concurrent import Control.Concurrent.STM -import Network.Socket (HostName) -import System.Environment (getArgs) cmd :: Command -cmd = withOptions [listenOption] $ - noCommit $ dontCheck repoExists $ notBareRepo $ - noRepo (withParams startNoRepo) $ +cmd = noCommit $ dontCheck repoExists $ notBareRepo $ + noRepo (startNoRepo <$$> optParser) $ command "webapp" SectionCommon "launch webapp" - paramNothing (withParams seek) + paramNothing (seek <$$> optParser) -listenOption :: Option -listenOption = fieldOption [] "listen" paramAddress - "accept connections to this address" +data WebAppOptions = WebAppOptions + { listenAddress :: Maybe String + } -seek :: CmdParams -> CommandSeek -seek ps = do - listenhost <- getOptionField listenOption return - withNothing (start listenhost) ps +optParser :: CmdParamsDesc -> Parser WebAppOptions +optParser _ = WebAppOptions + <$> optional (strOption + ( long "listen" <> metavar paramAddress + <> help "accept connections to this address" + )) -start :: Maybe HostName -> CommandStart +seek :: WebAppOptions -> CommandSeek +seek = commandAction . start + +start :: WebAppOptions -> CommandStart start = start' True -start' :: Bool -> Maybe HostName -> CommandStart -start' allowauto listenhost = do +start' :: Bool -> WebAppOptions -> CommandStart +start' allowauto o = do liftIO ensureInstalled ifM isInitialized ( maybe notinitialized (go <=< needsUpgrade) =<< getVersion , if allowauto - then liftIO $ startNoRepo [] + then liftIO $ startNoRepo o else notinitialized ) stop @@ -70,22 +72,22 @@ start' allowauto listenhost = do go cannotrun = do browser <- fromRepo webBrowser f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim - listenhost' <- if isJust listenhost - then pure listenhost + listenAddress' <- if isJust (listenAddress o) + then pure (listenAddress o) else annexListen <$> Annex.getGitConfig ifM (checkpid <&&> checkshim f) - ( if isJust listenhost + ( if isJust (listenAddress o) then error "The assistant is already running, so --listen cannot be used." else do url <- liftIO . readFile =<< fromRepo gitAnnexUrlFile - liftIO $ if isJust listenhost' + liftIO $ if isJust listenAddress' then putStrLn url else liftIO $ openBrowser browser f url Nothing Nothing , do - startDaemon True True Nothing cannotrun listenhost' $ Just $ + startDaemon True True Nothing cannotrun listenAddress' $ Just $ \origout origerr url htmlshim -> - if isJust listenhost' + if isJust listenAddress' then maybe noop (`hPutStrLn` url) origout else openBrowser browser htmlshim url origout origerr ) @@ -96,34 +98,27 @@ start' allowauto listenhost = do notinitialized = do g <- Annex.gitRepo liftIO $ cannotStartIn (Git.repoLocation g) "repository has not been initialized by git-annex" - liftIO $ firstRun listenhost + liftIO $ firstRun o {- When run without a repo, start the first available listed repository in - the autostart file. If none, it's our first time being run! -} -startNoRepo :: CmdParams -> IO () -startNoRepo _ = do - -- FIXME should be able to reuse regular getopt, but - -- it currently runs in the Annex monad. - args <- getArgs - let listenhost = headMaybe $ map (snd . separate (== '=')) $ - filter ("--listen=" `isPrefixOf`) args - - go listenhost =<< liftIO (filterM doesDirectoryExist =<< readAutoStartFile) +startNoRepo :: WebAppOptions -> IO () +startNoRepo o = go =<< liftIO (filterM doesDirectoryExist =<< readAutoStartFile) where - go listenhost [] = firstRun listenhost - go listenhost (d:ds) = do + go [] = firstRun o + go (d:ds) = do v <- tryNonAsync $ do setCurrentDirectory d Annex.new =<< Git.CurrentRepo.get case v of Left e -> do cannotStartIn d (show e) - go listenhost ds + go ds Right state -> void $ Annex.eval state $ do whenM (fromRepo Git.repoIsLocalBare) $ error $ d ++ " is a bare git repository, cannot run the webapp in it" callCommandAction $ - start' False listenhost + start' False o cannotStartIn :: FilePath -> String -> IO () cannotStartIn d reason = warningIO $ "unable to start webapp in repository " ++ d ++ ": " ++ reason @@ -141,8 +136,8 @@ cannotStartIn d reason = warningIO $ "unable to start webapp in repository " ++ - Note that it's important that mainthread never terminates! Much - of this complication is due to needing to keep the mainthread running. -} -firstRun :: Maybe HostName -> IO () -firstRun listenhost = do +firstRun :: WebAppOptions -> IO () +firstRun o = do checkEnvironmentIO {- Without a repository, we cannot have an Annex monad, so cannot - get a ThreadState. This is only safe because the @@ -159,7 +154,7 @@ firstRun listenhost = do startNamedThread urlrenderer $ webAppThread d urlrenderer True Nothing (callback signaler) - listenhost + (listenAddress o) (callback mainthread) waitNamedThreads where @@ -167,7 +162,7 @@ firstRun listenhost = do putMVar v "" takeMVar v mainthread v url htmlshim - | isJust listenhost = do + | isJust (listenAddress o)= do putStrLn url hFlush stdout go @@ -181,7 +176,7 @@ firstRun listenhost = do _wait <- takeMVar v state <- Annex.new =<< Git.CurrentRepo.get Annex.eval state $ - startDaemon True True Nothing Nothing listenhost $ Just $ + startDaemon True True Nothing Nothing (listenAddress o) $ Just $ sendurlback v sendurlback v _origout _origerr url _htmlshim = do recordUrl url From 02d522a12eee595d95f4119f3dba465508248694 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 12:26:06 -0400 Subject: [PATCH 52/54] Debian package (and any other packages built using make install) now includes bash completion. --- Makefile | 2 ++ debian/changelog | 6 ++++++ git-annex.cabal | 2 +- 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 1ce0a5f9b8..2f7d3b2443 100644 --- a/Makefile +++ b/Makefile @@ -48,6 +48,8 @@ install: build install-docs Build/InstallDesktopFile install git-annex $(DESTDIR)$(PREFIX)/bin ln -sf git-annex $(DESTDIR)$(PREFIX)/bin/git-annex-shell ./Build/InstallDesktopFile $(PREFIX)/bin/git-annex || true + install -d $(DESTDIR)$(PREFIX)/share/bash-completion/completions + ./git-annex --bash-completion-script git-annex > $(DESTDIR)$(PREFIX)/share/bash-completion/completions/git-annex test: git-annex ./git-annex test diff --git a/debian/changelog b/debian/changelog index 71b08394ae..787be67169 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,5 @@ +git-annex (5.20150713) unstable; urgency=medium + * 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. (For example, the metadata command no @@ -5,10 +7,14 @@ worked.) * Bash completion code is built-in to git-annex, and can be enabled by running: source <(git-annex --bash-completion-script git-annex) + * Debian package (and any other packages built using make install) + now includes bash completion. * version --raw now works when run outside a git repository. * assistant --startdelay now works when run outside a git repository. * dead now accepts multiple --key options. + -- Joey Hess Fri, 10 Jul 2015 16:36:42 -0400 + 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/git-annex.cabal b/git-annex.cabal index 905b945ae5..edcaa71212 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 5.20150710 +Version: 5.20150713 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess From 730cc3feb52d59e0bcfa420f327c4185df1bc6b4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 13:19:20 -0400 Subject: [PATCH 53/54] wire tasty's option parser into the main program option parser This makes bash completion work for git-annex test, and is generally cleaner. --- CmdLine/GitAnnex.hs | 17 +++++++++------- Command/Test.hs | 40 +++++++++++++++--------------------- Test.hs | 49 ++++++++++++++++++++++++++++++--------------- Types/Test.hs | 22 ++++++++++++++++++++ Utility/SubTasty.hs | 25 ----------------------- git-annex.hs | 11 +--------- 6 files changed, 82 insertions(+), 82 deletions(-) create mode 100644 Types/Test.hs delete mode 100644 Utility/SubTasty.hs diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 9c60956f6c..f585bff3ed 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -1,6 +1,6 @@ {- git-annex main program - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -14,6 +14,7 @@ import CmdLine import Command import Utility.Env import Annex.Ssh +import Types.Test import qualified Command.Help import qualified Command.Add @@ -117,8 +118,8 @@ import qualified Command.TestRemote import System.Remote.Monitoring #endif -cmds :: [Command] -cmds = +cmds :: Parser TestOptions -> Maybe TestRunner -> [Command] +cmds testoptparser testrunner = [ Command.Help.cmd , Command.Add.cmd , Command.Get.cmd @@ -213,21 +214,23 @@ cmds = #endif , Command.RemoteDaemon.cmd #endif - , Command.Test.cmd + , Command.Test.cmd testoptparser testrunner #ifdef WITH_TESTSUITE , Command.FuzzTest.cmd , Command.TestRemote.cmd #endif ] -run :: [String] -> IO () -run args = do +run :: Parser TestOptions -> Maybe TestRunner -> [String] -> IO () +run testoptparser testrunner args = do #ifdef WITH_EKG _ <- forkServer "localhost" 4242 #endif go envmodes where - go [] = dispatch True args cmds gitAnnexGlobalOptions [] Git.CurrentRepo.get + go [] = dispatch True args + (cmds testoptparser testrunner) + 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 diff --git a/Command/Test.hs b/Command/Test.hs index 57a9b16d30..35d6e15046 100644 --- a/Command/Test.hs +++ b/Command/Test.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2013 Joey Hess + - Copyright 2013-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,31 +10,23 @@ module Command.Test where import Common import Command import Messages +import Types.Test -cmd :: Command -cmd = noRepo (parseparams startIO) $ dontCheck repoExists $ - command "test" SectionTesting - "run built-in test suite" - paramNothing (parseparams seek) - where - parseparams = withParams +cmd :: Parser TestOptions -> Maybe TestRunner -> Command +cmd optparser runner = noRepo (startIO runner <$$> const optparser) $ + dontCheck repoExists $ + command "test" SectionTesting + "run built-in test suite" + paramNothing (seek runner <$$> const optparser) -seek :: CmdParams -> CommandSeek -seek = withWords start +seek :: Maybe TestRunner -> TestOptions -> CommandSeek +seek runner o = commandAction $ start runner o -{- We don't actually run the test suite here because of a dependency loop. - - The main program notices when the command is test and runs it; this - - function is never run if that works. - - - - However, if git-annex is built without the test suite, just print a - - warning, and do not exit nonzero. This is so git-annex test can be run - - in debian/rules despite some architectures not being able to build the - - test suite. - -} -start :: [String] -> CommandStart -start ps = do - liftIO $ startIO ps +start :: Maybe TestRunner -> TestOptions -> CommandStart +start runner o = do + liftIO $ startIO runner o stop -startIO :: CmdParams -> IO () -startIO _ = warningIO "git-annex was built without its test suite; not testing" +startIO :: Maybe TestRunner -> TestOptions -> IO () +startIO Nothing _ = warningIO "git-annex was built without its test suite; not testing" +startIO (Just runner) o = runner o diff --git a/Test.hs b/Test.hs index 762854f1fc..46bb236a60 100644 --- a/Test.hs +++ b/Test.hs @@ -1,6 +1,6 @@ {- git-annex test suite - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2015 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -9,7 +9,22 @@ module Test where +import Options.Applicative.Types + +#ifndef WITH_TESTSUITE + +import Options.Applicative (pure) + +optParser :: Parser () +optParser = pure () + +runner :: Maybe (() -> IO ()) +runner = Nothing + +#else + import Test.Tasty +import Test.Tasty.Options import Test.Tasty.Runners import Test.Tasty.HUnit import Test.Tasty.QuickCheck @@ -20,7 +35,6 @@ import qualified Text.JSON import Common -import qualified Utility.SubTasty import qualified Utility.SafeCommand import qualified Annex import qualified Annex.UUID @@ -81,18 +95,19 @@ import qualified Types.Crypto import qualified Utility.Gpg #endif -main :: [String] -> IO () -main ps = do - opts <- Utility.SubTasty.parseOpts "test" ingredients tests ("test":ps) - case tryIngredients ingredients opts tests of - Nothing -> error "No tests found!?" - Just act -> ifM act - ( exitSuccess - , do - putStrLn " (This could be due to a bug in git-annex, or an incompatability" - putStrLn " with utilities, such as git, installed on this system.)" - exitFailure - ) +optParser :: Parser OptionSet +optParser = suiteOptionParser ingredients tests + +runner :: Maybe (OptionSet -> IO ()) +runner = Just $ \opts -> case tryIngredients ingredients opts tests of + Nothing -> error "No tests found!?" + Just act -> ifM act + ( exitSuccess + , do + putStrLn " (This could be due to a bug in git-annex, or an incompatability" + putStrLn " with utilities, such as git, installed on this system.)" + exitFailure + ) ingredients :: [Ingredient] ingredients = @@ -1419,12 +1434,12 @@ test_addurl = intmpclonerepo $ do git_annex :: String -> [String] -> IO Bool git_annex command params = do -- catch all errors, including normally fatal errors - r <- try run::IO (Either SomeException ()) + r <- try run ::IO (Either SomeException ()) case r of Right _ -> return True Left _ -> return False where - run = GitAnnex.run (command:"-q":params) + run = GitAnnex.run optParser Nothing (command:"-q":params) {- Runs git-annex and returns its output. -} git_annex_output :: String -> [String] -> IO String @@ -1762,3 +1777,5 @@ backendWORM = backend_ "WORM" backend_ :: String -> Types.Backend backend_ = Backend.lookupBackendName + +#endif diff --git a/Types/Test.hs b/Types/Test.hs new file mode 100644 index 0000000000..35c4c3c235 --- /dev/null +++ b/Types/Test.hs @@ -0,0 +1,22 @@ +{- git-annex test data types. + - + - Copyright 2011-2015 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Types.Test where + +#ifdef WITH_TESTSUITE +import Test.Tasty.Options +#endif + +#ifdef WITH_TESTSUITE +type TestOptions = OptionSet +#else +type TestOptions = () +#endif + +type TestRunner = TestOptions -> IO () diff --git a/Utility/SubTasty.hs b/Utility/SubTasty.hs deleted file mode 100644 index 5164f9d1b2..0000000000 --- a/Utility/SubTasty.hs +++ /dev/null @@ -1,25 +0,0 @@ -{- Running tasty as a subcommand. - - - - Copyright 2015 Joey Hess - - - - License: BSD-2-clause - -} - -module Utility.SubTasty where - -import Test.Tasty -import Test.Tasty.Options -import Test.Tasty.Runners -import Options.Applicative - --- Uses tasty's option parser, modified to expect a subcommand. -parseOpts :: String -> [Ingredient] -> TestTree -> [String] -> IO OptionSet -parseOpts subcommand is ts = - handleParseResult . execParserPure (prefs idm) pinfo - where - pinfo = info (helper <*> subpinfo) (fullDesc <> header desc) - subpinfo = subparser $ command subcommand $ - suiteOptionParser is ts - `info` - progDesc desc - desc = "Builtin test suite" diff --git a/git-annex.hs b/git-annex.hs index 17ce807af2..ca8eecd2a8 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -13,9 +13,7 @@ import Network.Socket (withSocketsDo) import qualified CmdLine.GitAnnex import qualified CmdLine.GitAnnexShell -#ifdef WITH_TESTSUITE import qualified Test -#endif #ifdef mingw32_HOST_OS import Utility.UserInfo @@ -37,14 +35,7 @@ main = withSocketsDo $ do #else gitannex ps #endif - gitannex ps = -#ifdef WITH_TESTSUITE - case ps of - ("test":ps') -> Test.main ps' - _ -> CmdLine.GitAnnex.run ps -#else - CmdLine.GitAnnex.run ps -#endif + gitannex = CmdLine.GitAnnex.run Test.optParser Test.runner isshell n = takeFileName n == "git-annex-shell" #ifdef mingw32_HOST_OS From 42948e960fcbde41965f96bce981e541b496c8a2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 13 Jul 2015 13:25:49 -0400 Subject: [PATCH 54/54] typo --- doc/git-annex.mdwn | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index e3790bdf93..5cbab59781 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -770,7 +770,7 @@ 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. +be written to a bash completion file so bash 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!