diff options
Diffstat (limited to 'CmdLine')
| -rw-r--r-- | CmdLine/GitAnnex.hs | 182 | ||||
| -rw-r--r-- | CmdLine/GitAnnex/Options.hs | 99 | ||||
| -rw-r--r-- | CmdLine/GitAnnexShell.hs | 199 | ||||
| -rw-r--r-- | CmdLine/Option.hs | 77 | ||||
| -rw-r--r-- | CmdLine/Seek.hs | 182 | ||||
| -rw-r--r-- | CmdLine/Usage.hs | 111 |
6 files changed, 850 insertions, 0 deletions
diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs new file mode 100644 index 000000000..b25082963 --- /dev/null +++ b/CmdLine/GitAnnex.hs @@ -0,0 +1,182 @@ +{- git-annex main program + - + - Copyright 2010-2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP, OverloadedStrings #-} + +module CmdLine.GitAnnex where + +import qualified Git.CurrentRepo +import CmdLine +import Command + +import qualified Command.Add +import qualified Command.Unannex +import qualified Command.Drop +import qualified Command.Move +import qualified Command.Copy +import qualified Command.Get +import qualified Command.LookupKey +import qualified Command.ExamineKey +import qualified Command.FromKey +import qualified Command.DropKey +import qualified Command.TransferKey +import qualified Command.TransferKeys +import qualified Command.ReKey +import qualified Command.Reinject +import qualified Command.Fix +import qualified Command.Init +import qualified Command.Describe +import qualified Command.InitRemote +import qualified Command.EnableRemote +import qualified Command.Fsck +import qualified Command.Repair +import qualified Command.Unused +import qualified Command.DropUnused +import qualified Command.AddUnused +import qualified Command.Unlock +import qualified Command.Lock +import qualified Command.PreCommit +import qualified Command.Find +import qualified Command.Whereis +import qualified Command.List +import qualified Command.Log +import qualified Command.Merge +import qualified Command.Info +import qualified Command.Status +import qualified Command.Migrate +import qualified Command.Uninit +import qualified Command.NumCopies +import qualified Command.Trust +import qualified Command.Untrust +import qualified Command.Semitrust +import qualified Command.Dead +import qualified Command.Group +import qualified Command.Wanted +import qualified Command.Schedule +import qualified Command.Ungroup +import qualified Command.Vicfg +import qualified Command.Sync +import qualified Command.Mirror +import qualified Command.AddUrl +#ifdef WITH_FEED +import qualified Command.ImportFeed +#endif +import qualified Command.RmUrl +import qualified Command.Import +import qualified Command.Map +import qualified Command.Direct +import qualified Command.Indirect +import qualified Command.Upgrade +import qualified Command.Forget +import qualified Command.Version +import qualified Command.Help +#ifdef WITH_ASSISTANT +import qualified Command.Watch +import qualified Command.Assistant +#ifdef WITH_WEBAPP +import qualified Command.WebApp +#endif +#ifdef WITH_XMPP +import qualified Command.XMPPGit +#endif +#endif +import qualified Command.Test +#ifdef WITH_TESTSUITE +import qualified Command.FuzzTest +#endif +#ifdef WITH_EKG +import System.Remote.Monitoring +#endif + +cmds :: [Command] +cmds = concat + [ Command.Add.def + , Command.Get.def + , Command.Drop.def + , Command.Move.def + , Command.Copy.def + , Command.Unlock.def + , Command.Lock.def + , Command.Sync.def + , Command.Mirror.def + , Command.AddUrl.def +#ifdef WITH_FEED + , Command.ImportFeed.def +#endif + , Command.RmUrl.def + , Command.Import.def + , Command.Init.def + , Command.Describe.def + , Command.InitRemote.def + , Command.EnableRemote.def + , Command.Reinject.def + , Command.Unannex.def + , Command.Uninit.def + , Command.PreCommit.def + , Command.NumCopies.def + , Command.Trust.def + , Command.Untrust.def + , Command.Semitrust.def + , Command.Dead.def + , Command.Group.def + , Command.Wanted.def + , Command.Schedule.def + , Command.Ungroup.def + , Command.Vicfg.def + , Command.LookupKey.def + , Command.ExamineKey.def + , Command.FromKey.def + , Command.DropKey.def + , Command.TransferKey.def + , Command.TransferKeys.def + , Command.ReKey.def + , Command.Fix.def + , Command.Fsck.def + , Command.Repair.def + , Command.Unused.def + , Command.DropUnused.def + , Command.AddUnused.def + , Command.Find.def + , Command.Whereis.def + , Command.List.def + , Command.Log.def + , Command.Merge.def + , Command.Info.def + , Command.Status.def + , Command.Migrate.def + , Command.Map.def + , Command.Direct.def + , Command.Indirect.def + , Command.Upgrade.def + , Command.Forget.def + , Command.Version.def + , Command.Help.def +#ifdef WITH_ASSISTANT + , Command.Watch.def + , Command.Assistant.def +#ifdef WITH_WEBAPP + , Command.WebApp.def +#endif +#ifdef WITH_XMPP + , Command.XMPPGit.def +#endif +#endif + , Command.Test.def +#ifdef WITH_TESTSUITE + , Command.FuzzTest.def +#endif + ] + +header :: String +header = "git-annex command [option ...]" + +run :: [String] -> IO () +run args = do +#ifdef WITH_EKG + _ <- forkServer "localhost" 4242 +#endif + dispatch True args cmds gitAnnexOptions [] header Git.CurrentRepo.get diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs new file mode 100644 index 000000000..fcf5deaf0 --- /dev/null +++ b/CmdLine/GitAnnex/Options.hs @@ -0,0 +1,99 @@ +{- git-annex options + - + - Copyright 2010, 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module CmdLine.GitAnnex.Options where + +import System.Console.GetOpt + +import Common.Annex +import qualified Git.Config +import Git.Types +import Types.TrustLevel +import Types.NumCopies +import Types.Messages +import qualified Annex +import qualified Remote +import qualified Limit +import qualified Limit.Wanted +import CmdLine.Option +import CmdLine.Usage + +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 ['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 ['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 [] ["largerthan"] (ReqArg Limit.addLargerThan paramSize) + "match files larger than a size" + , Option [] ["smallerthan"] (ReqArg Limit.addSmallerThan paramSize) + "match files smaller than a size" + , 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" + , Option ['T'] ["time-limit"] (ReqArg Limit.addTimeLimit paramTime) + "stop after the specified amount of time" + , Option [] ["user-agent"] (ReqArg setuseragent paramName) + "override default User-Agent" + , Option [] ["trust-glacier"] (NoArg (Annex.setFlag "trustglacier")) + "Trust Amazon Glacier inventory" + ] ++ matcherOptions + where + trustArg t = ReqArg (Remote.forceTrust t) paramRemote + setnumcopies v = maybe noop + (\n -> Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n }) + (readish v) + 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 + +keyOptions :: [Option] +keyOptions = + [ Option ['A'] ["all"] (NoArg (Annex.setFlag "all")) + "operate on all versions of all files" + , Option ['U'] ["unused"] (NoArg (Annex.setFlag "unused")) + "operate on files found by last run of git-annex unused" + , Option [] ["key"] (ReqArg (Annex.setField "key") paramKey) + "operate on specified key" + ] + +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/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs new file mode 100644 index 000000000..c7b5bd1c9 --- /dev/null +++ b/CmdLine/GitAnnexShell.hs @@ -0,0 +1,199 @@ +{- git-annex-shell main program + - + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module CmdLine.GitAnnexShell where + +import System.Environment +import System.Console.GetOpt + +import Common.Annex +import qualified Git.Construct +import CmdLine +import Command +import Annex.UUID +import Annex (setField) +import Fields +import Utility.UserInfo +import Remote.GCrypt (getGCryptUUID) +import qualified Annex +import Init + +import qualified Command.ConfigList +import qualified Command.InAnnex +import qualified Command.DropKey +import qualified Command.RecvKey +import qualified Command.SendKey +import qualified Command.TransferInfo +import qualified Command.Commit +import qualified Command.GCryptSetup + +cmds_readonly :: [Command] +cmds_readonly = concat + [ gitAnnexShellCheck Command.ConfigList.def + , gitAnnexShellCheck Command.InAnnex.def + , gitAnnexShellCheck Command.SendKey.def + , gitAnnexShellCheck Command.TransferInfo.def + ] + +cmds_notreadonly :: [Command] +cmds_notreadonly = concat + [ gitAnnexShellCheck Command.RecvKey.def + , gitAnnexShellCheck Command.DropKey.def + , gitAnnexShellCheck Command.Commit.def + , Command.GCryptSetup.def + ] + +cmds :: [Command] +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" + ] + where + checkUUID expected = getUUID >>= check + where + check u | u == toUUID expected = noop + check NoUUID = checkGCryptUUID expected + check u = unexpectedUUID expected u + checkGCryptUUID expected = check =<< getGCryptUUID True =<< gitRepo + where + check (Just u) | u == toUUID expected = noop + check Nothing = unexpected expected "uninitialized repository" + check (Just u) = unexpectedUUID expected u + unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u + 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 +run ("-c":p) = run p +-- a command can be either a builtin or something to pass to git-shell +run c@(cmd:dir:params) + | cmd `elem` builtins = builtin cmd dir params + | otherwise = external c +run c@(cmd:_) + -- Handle the case of being the user's login shell. It will be passed + -- a single string containing all the real parameters. + | "git-annex-shell " `isPrefixOf` cmd = run $ drop 1 $ shellUnEscape cmd + | cmd `elem` builtins = failure + | otherwise = external c + +builtins :: [String] +builtins = map cmdname cmds + +builtin :: String -> String -> [String] -> IO () +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 $ + Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath + where + addrsyncopts opts seek k = setField "RsyncOptions" opts >> seek k + newcmd opts c = c { cmdseek = addrsyncopts opts (cmdseek c) } + +external :: [String] -> IO () +external params = do + {- Normal git-shell commands all have the directory as their last + - parameter. -} + let lastparam = lastMaybe =<< shellUnEscape <$> lastMaybe params + (params', _, _) = partitionParams params + checkDirectory lastparam + checkNotLimited + unlessM (boolSystem "git-shell" $ map Param $ "-c":params') $ + error "git-shell failed" + +{- Split the input list into 3 groups separated with a double dash --. + - Parameters between two -- markers are field settings, in the form: + - field=value field=value + - + - Parameters after the last -- are the command itself and its arguments e.g., + - rsync --bandwidth=100. + -} +partitionParams :: [String] -> ([String], [String], [String]) +partitionParams ps = case segment (== "--") ps of + params:fieldparams:rest -> ( params, fieldparams, intercalate ["--"] rest ) + [params] -> (params, [], []) + _ -> ([], [], []) + +parseFields :: [String] -> [(String, String)] +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 + | otherwise = False + +failure :: IO () +failure = error $ "bad parameters\n\n" ++ usage header cmds + +checkNotLimited :: IO () +checkNotLimited = checkEnv "GIT_ANNEX_SHELL_LIMITED" + +checkNotReadOnly :: String -> IO () +checkNotReadOnly cmd + | cmd `elem` map cmdname cmds_readonly = noop + | otherwise = checkEnv "GIT_ANNEX_SHELL_READONLY" + +checkDirectory :: Maybe FilePath -> IO () +checkDirectory mdir = do + v <- catchMaybeIO $ getEnv "GIT_ANNEX_SHELL_DIRECTORY" + case (v, mdir) of + (Nothing, _) -> noop + (Just d, Nothing) -> req d Nothing + (Just d, Just dir) + | d `equalFilePath` dir -> noop + | otherwise -> do + home <- myHomeDir + d' <- canondir home d + dir' <- canondir home dir + if d' `equalFilePath` dir' + then noop + else req d' (Just dir') + where + req d mdir' = error $ unwords + [ "Only allowed to access" + , d + , maybe "and could not determine directory from command line" ("not " ++) mdir' + ] + + {- A directory may start with ~/ or in some cases, even /~/, + - or could just be relative to home, or of course could + - be absolute. -} + canondir home d + | "~/" `isPrefixOf` d = return d + | "/~/" `isPrefixOf` d = return $ drop 1 d + | otherwise = relHome $ absPathFrom home d + +checkEnv :: String -> IO () +checkEnv var = do + v <- catchMaybeIO $ getEnv var + case v of + Nothing -> noop + Just "" -> noop + Just _ -> error $ "Action blocked by " ++ var + +{- 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 + where + okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $ + error "Not a git-annex or gcrypt repository." diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs new file mode 100644 index 000000000..915b06849 --- /dev/null +++ b/CmdLine/Option.hs @@ -0,0 +1,77 @@ +{- common command-line options + - + - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module CmdLine.Option ( + commonOptions, + matcherOptions, + flagOption, + fieldOption, + optionName, + ArgDescr(..), + OptDescr(..), +) where + +import System.Console.GetOpt + +import Common.Annex +import qualified Annex +import Types.Messages +import Limit +import CmdLine.Usage + +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 ['a'] ["auto"] (NoArg (setauto True)) + "automatic mode" + , 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" + ] + where + setforce v = Annex.changeState $ \s -> s { Annex.force = v } + setfast v = Annex.changeState $ \s -> s { Annex.fast = v } + setauto v = Annex.changeState $ \s -> s { Annex.auto = v } + setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } + setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True } + unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False } + +matcherOptions :: [Option] +matcherOptions = + [ 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 $ addToken o + shortopt o = Option o [] $ NoArg $ addToken o + +{- An option that sets a flag. -} +flagOption :: String -> String -> String -> Option +flagOption short opt description = + Option short [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 + +{- The flag or field name used for an option. -} +optionName :: Option -> String +optionName (Option _ o _ _) = Prelude.head o diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs new file mode 100644 index 000000000..d6d7fbc8b --- /dev/null +++ b/CmdLine/Seek.hs @@ -0,0 +1,182 @@ +{- git-annex command seeking + - + - These functions find appropriate files or other things based on + - the values a user passes to a command, and prepare actions operating + - on them. + - + - Copyright 2010-2014 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module CmdLine.Seek where + +import System.PosixCompat.Files + +import Common.Annex +import Types.Command +import Types.Key +import Types.FileMatcher +import qualified Annex +import qualified Git +import qualified Git.Command +import qualified Git.LsFiles as LsFiles +import qualified Limit +import CmdLine.Option +import Logs.Location +import Logs.Unused +import Annex.CatFile +import RunCommand + +withFilesInGit :: (FilePath -> CommandStart) -> CommandSeek +withFilesInGit a params = seekActions $ prepFiltered a $ + seekHelper LsFiles.inRepo params + +withFilesNotInGit :: (FilePath -> CommandStart) -> CommandSeek +withFilesNotInGit a params = do + {- dotfiles are not acted on unless explicitly listed -} + files <- filter (not . dotfile) <$> + seekunless (null ps && not (null params)) ps + dotfiles <- seekunless (null dotps) dotps + seekActions $ prepFiltered a $ + return $ concat $ segmentPaths params (files++dotfiles) + where + (dotps, ps) = partition dotfile params + seekunless True _ = return [] + seekunless _ l = do + force <- Annex.getState Annex.force + g <- gitRepo + liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g + +withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek +withPathContents a params = seekActions $ + map a . concat <$> liftIO (mapM get params) + where + get p = ifM (isDirectory <$> getFileStatus p) + ( map (\f -> (f, makeRelative (parentDir p) f)) + <$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) True p + , return [(p, takeFileName p)] + ) + +withWords :: ([String] -> CommandStart) -> CommandSeek +withWords a params = seekActions $ return [a params] + +withStrings :: (String -> CommandStart) -> CommandSeek +withStrings a params = seekActions $ return $ map a params + +withPairs :: ((String, String) -> CommandStart) -> 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 a params = seekActions $ prepFiltered a $ + seekHelper LsFiles.stagedNotDeleted params + +withFilesUnlocked :: (FilePath -> CommandStart) -> CommandSeek +withFilesUnlocked = withFilesUnlocked' LsFiles.typeChanged + +withFilesUnlockedToBeCommitted :: (FilePath -> CommandStart) -> CommandSeek +withFilesUnlockedToBeCommitted = withFilesUnlocked' LsFiles.typeChangedStaged + +{- Unlocked files have changed type from a symlink to a regular file. + - + - 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' typechanged a params = seekActions $ + prepFiltered a unlockedfiles + where + check f = liftIO (notSymlink f) <&&> + (isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f) + unlockedfiles = filterM check =<< seekHelper typechanged params + +{- Finds files that may be modified. -} +withFilesMaybeModified :: (FilePath -> CommandStart) -> CommandSeek +withFilesMaybeModified a params = seekActions $ + prepFiltered a $ seekHelper LsFiles.modified params + +withKeys :: (Key -> CommandStart) -> CommandSeek +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 -> CommandSeek +withNothing a [] = seekActions $ return [a] +withNothing _ _ = error "This command takes no parameters." + +{- If --all is specified, or in a bare repo, runs an action on all + - known keys. + - + - If --unused is specified, runs an action on all keys found by + - the last git annex unused scan. + - + - If --key is specified, operates only on that key. + - + - Otherwise, fall back to a regular CommandSeek action on + - whatever params were passed. -} +withKeyOptions :: (Key -> CommandStart) -> CommandSeek -> CommandSeek +withKeyOptions keyop fallbackop params = do + bare <- fromRepo Git.repoIsLocalBare + allkeys <- Annex.getFlag "all" + unused <- Annex.getFlag "unused" + specifickey <- Annex.getField "key" + auto <- Annex.getState Annex.auto + when (auto && bare) $ + error "Cannot use --auto in a bare repository" + case (allkeys, unused, null params, specifickey) of + (False , False , True , Nothing) + | bare -> go auto loggedKeys + | otherwise -> fallbackop params + (False , False , _ , Nothing) -> fallbackop params + (True , False , True , Nothing) -> go auto loggedKeys + (False , True , True , Nothing) -> go auto unusedKeys' + (False , False , True , Just ks) -> case file2key ks of + Nothing -> error "Invalid key" + Just k -> go auto $ return [k] + _ -> error "Can only specify one of file names, --all, --unused, or --key" + where + go True _ = error "Cannot use --auto with --all or --unused or --key" + go False a = do + matcher <- Limit.getMatcher + seekActions $ map (process matcher) <$> a + process matcher k = ifM (matcher $ MatchingKey k) + ( keyop k , return Nothing) + +prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart] +prepFiltered a fs = do + matcher <- Limit.getMatcher + map (process matcher) <$> fs + where + process matcher f = ifM (matcher $ MatchingFile $ FileInfo f f) + ( a f , return Nothing ) + +seekActions :: Annex [CommandStart] -> Annex () +seekActions gen = do + as <- gen + mapM_ commandAction as + +seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath] +seekHelper a params = do + ll <- inRepo $ \g -> + runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a fs g) params + {- Show warnings only for files/directories that do not exist. -} + forM_ (map fst $ filter (null . snd) $ zip params ll) $ \p -> + unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ + fileNotFound p + return $ concat ll + +notSymlink :: FilePath -> IO Bool +notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs new file mode 100644 index 000000000..64b512144 --- /dev/null +++ b/CmdLine/Usage.hs @@ -0,0 +1,111 @@ +{- git-annex usage messages + - + - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module CmdLine.Usage where + +import Common.Annex + +import Types.Command + +import System.Console.GetOpt + +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..] + where + go section + | null cs = [] + | otherwise = + [ "" + , descSection section ++ ":" + , "" + ] ++ map cmdline cs + where + cs = filter (\c -> cmdsection c == section) scmds + cmdline c = concat + [ cmdname c + , namepad (cmdname c) + , cmdparamdesc c + , descpad (cmdparamdesc c) + , cmddesc c + ] + pad n s = replicate (n - length s) ' ' + namepad = pad $ longest cmdname + 1 + descpad = pad $ longest cmdparamdesc + 2 + 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 = paramOptional $ paramRepeating paramPath -- most often used +paramPath :: String +paramPath = "PATH" +paramKey :: String +paramKey = "KEY" +paramDesc :: String +paramDesc = "DESC" +paramUrl :: String +paramUrl = "URL" +paramNumber :: String +paramNumber = "NUMBER" +paramNumRange :: String +paramNumRange = "NUM|RANGE" +paramRemote :: String +paramRemote = "REMOTE" +paramGlob :: String +paramGlob = "GLOB" +paramName :: String +paramName = "NAME" +paramValue :: String +paramValue = "VALUE" +paramUUID :: String +paramUUID = "UUID" +paramType :: String +paramType = "TYPE" +paramDate :: String +paramDate = "DATE" +paramTime :: String +paramTime = "TIME" +paramFormat :: String +paramFormat = "FORMAT" +paramFile :: String +paramFile = "FILE" +paramGroup :: String +paramGroup = "GROUP" +paramExpression :: String +paramExpression = "EXPR" +paramSize :: String +paramSize = "SIZE" +paramAddress :: String +paramAddress = "ADDRESS" +paramKeyValue :: String +paramKeyValue = "K=V" +paramNothing :: String +paramNothing = "" +paramRepeating :: String -> String +paramRepeating s = s ++ " ..." +paramOptional :: String -> String +paramOptional s = "[" ++ s ++ "]" +paramPair :: String -> String -> String +paramPair a b = a ++ " " ++ b |