broke subcommands out into separate modules
This commit is contained in:
parent
606ed6bb35
commit
0eae5b806c
14 changed files with 780 additions and 556 deletions
201
CmdLine.hs
Normal file
201
CmdLine.hs
Normal file
|
@ -0,0 +1,201 @@
|
|||
{- 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.State (liftIO)
|
||||
import System.Directory
|
||||
import Data.String.Utils
|
||||
import Control.Monad (filterM)
|
||||
import Monad (when)
|
||||
|
||||
import qualified GitRepo as Git
|
||||
import qualified Annex
|
||||
import Locations
|
||||
import qualified Backend
|
||||
import Types
|
||||
import Core
|
||||
|
||||
import Command
|
||||
import qualified Command.Add
|
||||
import qualified Command.Unannex
|
||||
import qualified Command.Drop
|
||||
import qualified Command.Move
|
||||
import qualified Command.Get
|
||||
import qualified Command.FromKey
|
||||
import qualified Command.DropKey
|
||||
import qualified Command.SetKey
|
||||
import qualified Command.Fix
|
||||
import qualified Command.Init
|
||||
|
||||
data SubCommand = SubCommand {
|
||||
subcmdname :: String,
|
||||
subcmdparams :: String,
|
||||
subcmdseek :: SubCmdSeek,
|
||||
subcmddesc :: String
|
||||
}
|
||||
subCmds :: [SubCommand]
|
||||
subCmds = [
|
||||
(SubCommand "add" path (withFilesNotInGit Command.Add.start)
|
||||
"add files to annex")
|
||||
, (SubCommand "get" path (withFilesInGit Command.Get.start)
|
||||
"make content of annexed files available")
|
||||
, (SubCommand "drop" path (withFilesInGit Command.Drop.start)
|
||||
"indicate content of files not currently wanted")
|
||||
, (SubCommand "move" path (withFilesInGit Command.Move.start)
|
||||
"transfer content of files to/from another repository")
|
||||
, (SubCommand "init" desc (withDescription Command.Init.start)
|
||||
"initialize git-annex with repository description")
|
||||
, (SubCommand "unannex" path (withFilesInGit Command.Unannex.start)
|
||||
"undo accidential add command")
|
||||
, (SubCommand "fix" path (withFilesInGit Command.Fix.start)
|
||||
"fix up symlinks to point to annexed content")
|
||||
, (SubCommand "pre-commit" path (withFilesToBeCommitted Command.Fix.start)
|
||||
"fix up symlinks before they are committed")
|
||||
, (SubCommand "fromkey" key (withFilesMissing Command.FromKey.start)
|
||||
"adds a file using a specific key")
|
||||
, (SubCommand "dropkey" key (withKeys Command.DropKey.start)
|
||||
"drops annexed content for specified keys")
|
||||
, (SubCommand "setkey" key (withTempFile Command.SetKey.start)
|
||||
"sets annexed content for a key using a temp file")
|
||||
]
|
||||
where
|
||||
path = "PATH ..."
|
||||
key = "KEY ..."
|
||||
desc = "DESCRIPTION"
|
||||
|
||||
-- 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"
|
||||
]
|
||||
where
|
||||
storebool n b = Annex.flagChange n $ FlagBool b
|
||||
storestring n s = Annex.flagChange n $ FlagString s
|
||||
|
||||
header :: String
|
||||
header = "Usage: git-annex " ++ (join "|" $ map subcmdname subCmds)
|
||||
|
||||
{- Usage message with lists of options and subcommands. -}
|
||||
usage :: String
|
||||
usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
|
||||
where
|
||||
cmddescs = unlines $ map (\c -> indent $ showcmd c) subCmds
|
||||
showcmd c =
|
||||
(subcmdname c) ++
|
||||
(pad 11 (subcmdname c)) ++
|
||||
(subcmdparams c) ++
|
||||
(pad 13 (subcmdparams c)) ++
|
||||
(subcmddesc c)
|
||||
indent l = " " ++ l
|
||||
pad n s = take (n - (length s)) $ repeat ' '
|
||||
|
||||
{- Prepares a list of actions to run to perform a subcommand, based on
|
||||
- the parameters passed to it. -}
|
||||
prepSubCmd :: SubCommand -> AnnexState -> [String] -> IO [Annex Bool]
|
||||
prepSubCmd SubCommand { subcmdseek = seek } state params = do
|
||||
list <- Annex.eval state $ seek params
|
||||
return $ map (\a -> doSubCmd a) list
|
||||
|
||||
{- Runs a subcommand through the start, perform and cleanup stages -}
|
||||
doSubCmd :: SubCmdStart -> SubCmdCleanup
|
||||
doSubCmd start = do
|
||||
s <- start
|
||||
case (s) of
|
||||
Nothing -> return True
|
||||
Just perform -> do
|
||||
p <- perform
|
||||
case (p) of
|
||||
Nothing -> do
|
||||
showEndFail
|
||||
return False
|
||||
Just cleanup -> do
|
||||
c <- cleanup
|
||||
if (c)
|
||||
then do
|
||||
showEndOk
|
||||
return True
|
||||
else do
|
||||
showEndFail
|
||||
return False
|
||||
|
||||
{- These functions find appropriate files or other things based on a
|
||||
user's parameters. -}
|
||||
withFilesNotInGit :: SubCmdSeekBackendFiles
|
||||
withFilesNotInGit a params = do
|
||||
repo <- Annex.gitRepo
|
||||
files <- liftIO $ mapM (Git.notInRepo repo) params
|
||||
let files' = foldl (++) [] files
|
||||
pairs <- Backend.chooseBackends files'
|
||||
return $ map a $ filter (\(f,_) -> notState f) pairs
|
||||
withFilesInGit :: SubCmdSeekStrings
|
||||
withFilesInGit a params = do
|
||||
repo <- Annex.gitRepo
|
||||
files <- liftIO $ mapM (Git.inRepo repo) params
|
||||
return $ map a $ filter notState $ foldl (++) [] files
|
||||
withFilesMissing :: SubCmdSeekStrings
|
||||
withFilesMissing a params = do
|
||||
files <- liftIO $ filterM missing params
|
||||
return $ map a $ filter notState files
|
||||
where
|
||||
missing f = do
|
||||
e <- doesFileExist f
|
||||
return $ not e
|
||||
withDescription :: SubCmdSeekStrings
|
||||
withDescription a params = do
|
||||
return $ [a $ unwords params]
|
||||
withFilesToBeCommitted :: SubCmdSeekStrings
|
||||
withFilesToBeCommitted a params = do
|
||||
repo <- Annex.gitRepo
|
||||
files <- liftIO $ mapM (Git.stagedFiles repo) params
|
||||
return $ map a $ filter notState $ foldl (++) [] files
|
||||
withKeys :: SubCmdSeekStrings
|
||||
withKeys a params = return $ map a params
|
||||
withTempFile :: SubCmdSeekStrings
|
||||
withTempFile a params = return $ map a params
|
||||
|
||||
{- filter out files from the state directory -}
|
||||
notState :: FilePath -> Bool
|
||||
notState f = stateLoc /= take (length stateLoc) f
|
||||
|
||||
{- Parses command line and returns two lists of actions to be
|
||||
- run in the Annex monad. The first actions configure it
|
||||
- according to command line options, while the second actions
|
||||
- handle subcommands. -}
|
||||
parseCmd :: [String] -> AnnexState -> IO ([Annex Bool], [Annex Bool])
|
||||
parseCmd argv state = do
|
||||
(flags, params) <- getopt
|
||||
when (null params) $ error usage
|
||||
case lookupCmd (params !! 0) of
|
||||
[] -> error usage
|
||||
[subcommand] -> do
|
||||
actions <- prepSubCmd subcommand state (drop 1 params)
|
||||
let configactions = map (\flag -> do
|
||||
flag
|
||||
return True) flags
|
||||
return (configactions, actions)
|
||||
_ -> 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
|
Loading…
Add table
Add a link
Reference in a new issue