diff options
| -rw-r--r-- | CmdLine.hs | 9 | ||||
| -rw-r--r-- | Command.hs | 24 | ||||
| -rw-r--r-- | Command/Fsck.hs | 88 | ||||
| -rw-r--r-- | Types/Command.hs | 4 |
4 files changed, 76 insertions, 49 deletions
diff --git a/CmdLine.hs b/CmdLine.hs index 82c9b4289..89f9964b7 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 ec8ffadd9..e72bd1660 100644 --- a/Command.hs +++ b/Command.hs @@ -1,6 +1,6 @@ {- git-annex command infrastructure - - - Copyright 2010-2014 Joey Hess <id@joeyh.name> + - Copyright 2010-2015 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -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 29ef01032..c2a819e9d 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) - -fsckFromOption :: Option -fsckFromOption = fieldOption ['f'] "from" paramRemote "check remote" - -startIncrementalOption :: Option -startIncrementalOption = flagOption ['S'] "incremental" "start an incremental fsck" - -moreIncrementalOption :: Option -moreIncrementalOption = flagOption ['m'] "more" "continue an incremental fsck" - -incrementalScheduleOption :: Option -incrementalScheduleOption = fieldOption [] "incremental-schedule" paramTime - "schedule incremental fscking" - -fsckOptions :: [Option] -fsckOptions = - [ fsckFromOption - , startIncrementalOption - , moreIncrementalOption - , incrementalScheduleOption - ] ++ keyOptions ++ annexedMatchingOptions - -seek :: CmdParams -> CommandSeek -seek ps = do - from <- getOptionField fsckFromOption Remote.byNameWithUUID +cmd = command "fsck" SectionMaintenance "check for problems" + paramPaths (seek <$$> optParser) + +data FsckOptions = FsckOptions + { fsckFiles :: CmdParams + , fsckFromOption :: Maybe String + , startIncrementalOption :: Bool + , moreIncrementalOption :: Bool + , incrementalScheduleOption :: Maybe Duration + } + +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" + )) + +-- TODO: keyOptions, annexedMatchingOptions + +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 99920e657..acd662bf3 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 |