diff options
| -rw-r--r-- | CmdLine/GitAnnex.hs | 34 | ||||
| -rw-r--r-- | CmdLine/GitAnnex/Options.hs | 78 | ||||
| -rw-r--r-- | CmdLine/GitAnnexShell.hs | 15 | ||||
| -rw-r--r-- | Command/Drop.hs | 2 | ||||
| -rw-r--r-- | Command/Sync.hs | 77 | ||||
| -rw-r--r-- | Command/Unused.hs | 10 | ||||
| -rw-r--r-- | Command/Whereis.hs | 8 | ||||
| -rw-r--r-- | Types/DeferredParse.hs | 17 | ||||
| -rw-r--r-- | doc/git-annex-drop.mdwn | 2 |
9 files changed, 138 insertions, 105 deletions
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index c42ba2a2d..2e9bc537f 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 c027c602c..4ec7bc875 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" - ] - where - longopt o = Option [] [o] $ NoArg $ Limit.addToken o - shortopt o = Option o [] $ NoArg $ Limit.addToken o - -jsonOption :: Option -jsonOption = Option ['j'] ["json"] (NoArg (Annex.setOutput JSONOutput)) - "enable JSON output" - -jobsOption :: Option -jobsOption = Option ['J'] ["jobs"] (ReqArg set paramNumber) - "enable concurrent jobs" +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 - set s = case readish s of - Nothing -> error "Bad --jobs number" - Just n -> Annex.setOutput (ParallelOutput n) - -timeLimitOption :: Option -timeLimitOption = Option ['T'] ["time-limit"] - (ReqArg Limit.addTimeLimit paramTime) - "stop after the specified amount of time" + longopt o h = globalOpt (Limit.addToken o) $ switch + ( long o <> help h ) + shortopt o h = globalOpt (Limit.addToken [o]) $ switch + ( short o <> help h) + +parseJsonOption :: Parser GlobalSetter +parseJsonOption = globalOpt (Annex.setOutput JSONOutput) $ switch + ( long "json" <> short 'j' + <> help "enable JSON output" + ) -autoOption :: Option -autoOption = flagOption ['a'] "auto" "automatic mode" +parseJobsOption :: Parser GlobalSetter +parseJobsOption = globalSetter (Annex.setOutput . ParallelOutput) $ + option auto + ( long "jobs" <> short 'J' <> metavar paramNumber + <> help "enable concurrent jobs" + ) + +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 bda4f7907..386780add 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 1c595b6c2..7141cbc48 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 2f7c4af7f..a5b601076 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) - -syncOptions :: [Option] -syncOptions = - [ contentOption - , messageOption - , allOption - ] - -contentOption :: Option -contentOption = flagOption [] "content" "also transfer file contents" - -messageOption :: Option -messageOption = fieldOption ['m'] "message" "MSG" "specify commit message" - -seek :: CmdParams -> CommandSeek -seek rs = do +cmd = command "sync" SectionCommon + "synchronize local repository with remotes" + (paramRepeating paramRemote) (seek <$$> optParser) + +data SyncOptions = SyncOptions + { syncWith :: CmdParams + , contentOption :: Bool + , messageOption :: Maybe String + , keyOptions :: Maybe KeyOptions + } + +optParser :: CmdParamsDesc -> Parser SyncOptions +optParser desc = SyncOptions + <$> cmdParams desc + <*> switch + ( long "content" + <> help "also transfer file contents" + ) + <*> optional (strOption + ( long "message" <> short 'm' <> metavar "MSG" + <> help "commit message" + )) + <*> optional parseAllOption + +seek :: SyncOptions -> CommandSeek +seek o = do prepMerge -- There may not be a branch checked out until after the commit, @@ -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 e6d5f7c71..4649485c2 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 05bc70654..fb28daa22 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 2f463de35..4b5ee6d59 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 813cce6aa..a3a79f8d7 100644 --- a/doc/git-annex-drop.mdwn +++ b/doc/git-annex-drop.mdwn @@ -1,6 +1,6 @@ # NAME -git-annex drop - indicate content of files not currently wanted +git-annex drop - remove content of files from repository # SYNOPSIS |