reorganize some files and imports
This commit is contained in:
Joey Hess
parent
3149a62a35
commit
86ffeb73d1
34 changed files with 92 additions and 120 deletions
182
CmdLine/GitAnnex.hs
Normal file
182
CmdLine/GitAnnex.hs
Normal file
|
|
@ -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
|
||||
99
CmdLine/GitAnnex/Options.hs
Normal file
99
CmdLine/GitAnnex/Options.hs
Normal file
|
|
@ -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"
|
||||
199
CmdLine/GitAnnexShell.hs
Normal file
199
CmdLine/GitAnnexShell.hs
Normal file
|
|
@ -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."
|
||||
77
CmdLine/Option.hs
Normal file
77
CmdLine/Option.hs
Normal file
|
|
@ -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
|
||||
182
CmdLine/Seek.hs
Normal file
182
CmdLine/Seek.hs
Normal file
|
|
@ -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
|
||||
111
CmdLine/Usage.hs
Normal file
111
CmdLine/Usage.hs
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue