wip

CmdLine/GitAnnex/Options.hs

@@ -1,4 +1,4 @@
-{- git-annex options
+{- git-annex command-line option parsing
  -
  - Copyright 2010-2015 Joey Hess <id@joeyh.name>
  -
@@ -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.
+-- Options for acting on keys, rather than work tree files.
-keyOptions :: [Option]
+data KeyOptions = KeyOptions
-keyOptions = [ allOption, unusedOption, keyOption]
+	{ wantAllKeys :: Bool
+	, wantUnusedKeys :: Bool
+	, wantIncompleteKeys :: Bool
+	, wantSpecificKey :: Maybe Key
+	}
 
-allOption :: Option
+parseKeyOptions :: Bool -> Parser KeyOptions
-allOption = Option ['A'] ["all"] (NoArg (Annex.setFlag "all"))
+parseKeyOptions allowincomplete = KeyOptions
-	"operate on all versions of all files"
+	<$> parseAllKeysOption
+	<*> parseUnusedKeysOption
+	<*> (if allowincomplete then parseIncompleteOption else pure False)
+	<*> parseSpecificKeyOption
 
-unusedOption :: Option
+parseAllKeysOption :: Parser Bool
-unusedOption = Option ['U'] ["unused"] (NoArg (Annex.setFlag "unused"))
+parseAllKeysOption = switch
-	"operate on files found by last run of git-annex unused"
+	( long "all"
+	<> short 'A'
+	<> help "operate on all versions of all files"
+	)
 
-keyOption :: Option
+parseUnusedKeysOption :: Parser Bool
-keyOption = Option [] ["key"] (ReqArg (Annex.setField "key") paramKey)
+parseUnusedKeysOption = switch
-		"operate on specified key"
+	( long "unused"
+	<> short 'U'
+	<> help "operate on files found by last run of git-annex unused"
+	)
 
-incompleteOption :: Option
+parseSpecificKeyOption :: Parser (Maybe Key)
-incompleteOption = flagOption [] "incomplete" "resume previous downloads"
+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

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 :: KeyOptions -> Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek
-withKeyOptions auto keyop = withKeyOptions' auto $ \getkeys -> do
+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' :: KeyOptions -> Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek
-withKeyOptions' auto keyop fallbackop params = do
+withKeyOptions' ko auto keyaction fallbackaction params = do
 	bare <- fromRepo Git.repoIsLocalBare
-	allkeys <- Annex.getFlag "all"
+	let allkeys = wantAllKeys ko
-	unused <- Annex.getFlag "unused"
+	let unused = wantUnusedKeys ko
-	incomplete <- Annex.getFlag "incomplete"
+	let incomplete = wantIncompleteKeys ko
-	specifickey <- Annex.getField "key"
+	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
+			| otherwise -> fallbackaction params
-		(False  , False , False     , _          , Nothing) -> fallbackop 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
+		(False  , False , False     , True       , Just k) -> go auto $ return [k]
-			Nothing -> error "Invalid key"
-			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]

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

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) $ 
+cmd = command "drop" SectionCommon
-	command "drop" SectionCommon
+	"indicate content of files not currently wanted"
-		"indicate content of files not currently wanted"
+	paramPaths (seek <$$> optParser)
-		paramPaths (withParams seek)
 
-dropOptions :: [Option]
+data DropOptions = DropOptions
-dropOptions = dropFromOption : annexedMatchingOptions ++ [autoOption] ++ keyOptions
+	{ dropFiles :: CmdParams
+	, dropFrom :: Maybe RemoteName
+	, autoMode :: Bool
+	, keyOptions :: KeyOptions
+	}
 
-dropFromOption :: Option
+-- TODO: annexedMatchingOptions
-dropFromOption = fieldOption ['f'] "from" paramRemote "drop content from a remote"
 
-seek :: CmdParams -> CommandSeek
+optParser :: CmdParamsDesc -> Parser DropOptions
-seek ps = do
+optParser desc = DropOptions
-	from <- getOptionField dropFromOption Remote.byNameWithUUID
+	<$> cmdParams desc
-	auto <- getOptionFlag autoOption
+	<*> parseDropFromOption
-	withKeyOptions auto
+	<*> parseAutoOption
-		(startKeys auto from)
+	<*> parseKeyOptions False
-		(withFilesInGit $ whenAnnexed $ start auto from)
-		ps
 
-start :: Bool -> Maybe Remote -> FilePath -> Key -> CommandStart
+parseDropFromOption :: Parser (Maybe RemoteName)
-start auto from file key = start' auto from key (Just file)
+parseDropFromOption = finalOpt $ strOption
+        ( long "from"
+        <> short 'f'
+	<> metavar paramRemote
+        <> help "drop content from a remote"
+	)
 
-start' :: Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart
+seek :: DropOptions -> CommandSeek
-start' auto from key afile = checkDropAuto auto from afile key $ \numcopies ->
+seek o = withKeyOptions (keyOptions o) (autoMode o)
-	stopUnless want $
+	(startKeys o)
-		case from of
+	(withFilesInGit $ whenAnnexed $ start o)
-			Nothing -> startLocal afile numcopies key Nothing
+	(dropFiles o)
-			Just remote -> do
-				u <- getUUID
-				if Remote.uuid remote == u
-					then startLocal afile numcopies key Nothing
-					else startRemote afile numcopies key remote
-  where
-	want
-		| auto = wantDrop False (Remote.uuid <$> from) (Just key) afile
-		| otherwise = return True
 
-startKeys :: Bool -> Maybe Remote -> Key -> CommandStart
+start :: DropOptions -> FilePath -> Key -> CommandStart
-startKeys auto from key = start' auto from key Nothing
+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

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)