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)