147 lines
4.9 KiB
Haskell
147 lines
4.9 KiB
Haskell
{- git-annex command line
|
|
-
|
|
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module CmdLine (parseCmd) where
|
|
|
|
import System.Console.GetOpt
|
|
import Control.Monad (when)
|
|
import Control.Monad.State (liftIO)
|
|
|
|
import qualified Annex
|
|
import Types
|
|
|
|
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.FromKey
|
|
import qualified Command.DropKey
|
|
import qualified Command.SetKey
|
|
import qualified Command.Fix
|
|
import qualified Command.Init
|
|
import qualified Command.Fsck
|
|
import qualified Command.Unused
|
|
import qualified Command.DropUnused
|
|
import qualified Command.Unlock
|
|
import qualified Command.Lock
|
|
import qualified Command.PreCommit
|
|
import qualified Command.Find
|
|
import qualified Command.Uninit
|
|
|
|
subCmds :: [SubCommand]
|
|
subCmds =
|
|
[ SubCommand "add" path Command.Add.seek
|
|
"add files to annex"
|
|
, SubCommand "get" path Command.Get.seek
|
|
"make content of annexed files available"
|
|
, SubCommand "drop" path Command.Drop.seek
|
|
"indicate content of files not currently wanted"
|
|
, SubCommand "move" path Command.Move.seek
|
|
"move content of files to/from another repository"
|
|
, SubCommand "copy" path Command.Copy.seek
|
|
"copy content of files to/from another repository"
|
|
, SubCommand "unlock" path Command.Unlock.seek
|
|
"unlock files for modification"
|
|
, SubCommand "edit" path Command.Unlock.seek
|
|
"same as unlock"
|
|
, SubCommand "lock" path Command.Lock.seek
|
|
"undo unlock command"
|
|
, SubCommand "init" desc Command.Init.seek
|
|
"initialize git-annex with repository description"
|
|
, SubCommand "unannex" path Command.Unannex.seek
|
|
"undo accidential add command"
|
|
, SubCommand "uninit" path Command.Uninit.seek
|
|
"de-initialize git-annex and clean out repository"
|
|
, SubCommand "pre-commit" path Command.PreCommit.seek
|
|
"run by git pre-commit hook"
|
|
, SubCommand "fromkey" key Command.FromKey.seek
|
|
"adds a file using a specific key"
|
|
, SubCommand "dropkey" key Command.DropKey.seek
|
|
"drops annexed content for specified keys"
|
|
, SubCommand "setkey" key Command.SetKey.seek
|
|
"sets annexed content for a key using a temp file"
|
|
, SubCommand "fix" path Command.Fix.seek
|
|
"fix up symlinks to point to annexed content"
|
|
, SubCommand "fsck" maybepath Command.Fsck.seek
|
|
"check for problems"
|
|
, SubCommand "unused" nothing Command.Unused.seek
|
|
"look for unused file content"
|
|
, SubCommand "dropunused" number Command.DropUnused.seek
|
|
"drop unused file content"
|
|
, SubCommand "find" maybepath Command.Find.seek
|
|
"lists available files"
|
|
]
|
|
where
|
|
path = "PATH ..."
|
|
maybepath = "[PATH ...]"
|
|
key = "KEY ..."
|
|
desc = "DESCRIPTION"
|
|
number = "NUMBER ..."
|
|
nothing = ""
|
|
|
|
-- Each dashed command-line option results in generation of an action
|
|
-- in the Annex monad that performs the necessary setting.
|
|
options :: [OptDescr (Annex ())]
|
|
options = [
|
|
Option ['f'] ["force"] (NoArg (storebool "force" True))
|
|
"allow actions that may lose annexed data"
|
|
, Option ['q'] ["quiet"] (NoArg (storebool "quiet" True))
|
|
"avoid verbose output"
|
|
, Option ['v'] ["verbose"] (NoArg (storebool "quiet" False))
|
|
"allow verbose output"
|
|
, Option ['b'] ["backend"] (ReqArg (storestring "backend") "NAME")
|
|
"specify default key-value backend to use"
|
|
, Option ['k'] ["key"] (ReqArg (storestring "key") "KEY")
|
|
"specify a key to use"
|
|
, Option ['t'] ["to"] (ReqArg (storestring "torepository") "REPOSITORY")
|
|
"specify to where to transfer content"
|
|
, Option ['f'] ["from"] (ReqArg (storestring "fromrepository") "REPOSITORY")
|
|
"specify from where to transfer content"
|
|
, Option ['x'] ["exclude"] (ReqArg (storestring "exclude") "GLOB")
|
|
"skip files matching the glob pattern"
|
|
]
|
|
where
|
|
storebool n b = Annex.flagChange n $ FlagBool b
|
|
storestring n s = Annex.flagChange n $ FlagString s
|
|
|
|
header :: String
|
|
header = "Usage: git-annex subcommand [option ..]"
|
|
|
|
{- Usage message with lists of options and subcommands. -}
|
|
usage :: String
|
|
usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
|
|
where
|
|
cmddescs = unlines $ map (indent . showcmd) subCmds
|
|
showcmd c =
|
|
subcmdname c ++
|
|
pad 11 (subcmdname c) ++
|
|
subcmdparams c ++
|
|
pad 13 (subcmdparams c) ++
|
|
subcmddesc c
|
|
indent l = " " ++ l
|
|
pad n s = replicate (n - length s) ' '
|
|
|
|
{- Parses command line, stores configure flags, and returns a
|
|
- list of actions to be run in the Annex monad. -}
|
|
parseCmd :: [String] -> Annex [Annex Bool]
|
|
parseCmd argv = do
|
|
(flags, params) <- liftIO $ getopt
|
|
when (null params) $ error usage
|
|
case lookupCmd (head params) of
|
|
[] -> error usage
|
|
[subcommand] -> do
|
|
_ <- sequence flags
|
|
prepSubCmd subcommand (drop 1 params)
|
|
_ -> error "internal error: multiple matching subcommands"
|
|
where
|
|
getopt = case getOpt Permute options argv of
|
|
(flags, params, []) -> return (flags, params)
|
|
(_, _, errs) -> ioError (userError (concat errs ++ usage))
|
|
lookupCmd cmd = filter (\c -> cmd == subcmdname c) subCmds
|