summaryrefslogtreecommitdiff
path: root/CmdLine
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-01-26 16:25:55 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-01-26 16:25:55 -0400
commit4f050ca9b80d0565e408137f2422e808b82cfd11 (patch)
tree5aca9688e49dee8915a962de4baf4c305ccbfa9e /CmdLine
parent541178b499d084e4041ae4b9d62bf86f5a97c3ff (diff)
reorganize some files and imports
Diffstat (limited to 'CmdLine')
-rw-r--r--CmdLine/GitAnnex.hs182
-rw-r--r--CmdLine/GitAnnex/Options.hs99
-rw-r--r--CmdLine/GitAnnexShell.hs199
-rw-r--r--CmdLine/Option.hs77
-rw-r--r--CmdLine/Seek.hs182
-rw-r--r--CmdLine/Usage.hs111
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