bc51387e6d
Since the queue is flushed in between subcommand actions being run, there should be no issues with actions that expect to queue up some stuff and have it run after they do other stuff. So I didn't have to audit for such assumptions.
109 lines
3.1 KiB
Haskell
109 lines
3.1 KiB
Haskell
{- git-annex command line parsing and dispatch
|
|
-
|
|
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module CmdLine (
|
|
dispatch,
|
|
usage,
|
|
shutdown
|
|
) where
|
|
|
|
import System.IO.Error (try)
|
|
import System.Console.GetOpt
|
|
import Control.Monad.State (liftIO)
|
|
import Control.Monad (when)
|
|
|
|
import qualified Annex
|
|
import qualified AnnexQueue
|
|
import qualified GitRepo as Git
|
|
import Types
|
|
import Command
|
|
import BackendList
|
|
import Version
|
|
import Options
|
|
import Messages
|
|
import UUID
|
|
|
|
{- Runs the passed command line. -}
|
|
dispatch :: Git.Repo -> [String] -> [Command] -> [Option] -> String -> IO ()
|
|
dispatch gitrepo args cmds options header = do
|
|
setupConsole
|
|
state <- Annex.new gitrepo allBackends
|
|
(actions, state') <- Annex.run state $ parseCmd args header cmds options
|
|
tryRun state' $ [startup] ++ actions ++ [shutdown]
|
|
|
|
{- Parses command line, stores configure flags, and returns a
|
|
- list of actions to be run in the Annex monad. -}
|
|
parseCmd :: [String] -> String -> [Command] -> [Option] -> Annex [Annex Bool]
|
|
parseCmd argv header cmds options = do
|
|
(flags, params) <- liftIO $ getopt
|
|
when (null params) $ error $ "missing command" ++ usagemsg
|
|
case lookupCmd (head params) of
|
|
[] -> error $ "unknown command" ++ usagemsg
|
|
[command] -> do
|
|
_ <- sequence flags
|
|
when (cmdusesrepo command) $
|
|
checkVersion
|
|
prepCommand command (drop 1 params)
|
|
_ -> error "internal error: multiple matching commands"
|
|
where
|
|
getopt = case getOpt Permute options argv of
|
|
(flags, params, []) ->
|
|
return (flags, params)
|
|
(_, _, errs) ->
|
|
ioError (userError (concat errs ++ usagemsg))
|
|
lookupCmd cmd = filter (\c -> cmd == cmdname c) cmds
|
|
usagemsg = "\n\n" ++ usage header cmds options
|
|
|
|
{- Usage message with lists of commands and options. -}
|
|
usage :: String -> [Command] -> [Option] -> String
|
|
usage header cmds options =
|
|
usageInfo (header ++ "\n\nOptions:") options ++
|
|
"\nCommands:\n" ++ cmddescs
|
|
where
|
|
cmddescs = unlines $ map (indent . showcmd) cmds
|
|
showcmd c =
|
|
cmdname c ++
|
|
pad (longest cmdname + 1) (cmdname c) ++
|
|
cmdparams c ++
|
|
pad (longest cmdparams + 2) (cmdparams c) ++
|
|
cmddesc c
|
|
pad n s = replicate (n - length s) ' '
|
|
longest f = foldl max 0 $ map (length . f) cmds
|
|
|
|
{- Runs a list of Annex actions. Catches IO errors and continues
|
|
- (but explicitly thrown errors terminate the whole command).
|
|
-}
|
|
tryRun :: Annex.AnnexState -> [Annex Bool] -> IO ()
|
|
tryRun state actions = tryRun' state 0 actions
|
|
tryRun' :: Annex.AnnexState -> Integer -> [Annex Bool] -> IO ()
|
|
tryRun' state errnum (a:as) = do
|
|
result <- try $ Annex.run state $ do
|
|
AnnexQueue.flushWhenFull
|
|
a
|
|
case result of
|
|
Left err -> do
|
|
Annex.eval state $ showErr err
|
|
tryRun' state (errnum + 1) as
|
|
Right (True,state') -> tryRun' state' errnum as
|
|
Right (False,state') -> tryRun' state' (errnum + 1) as
|
|
tryRun' _ errnum [] = do
|
|
when (errnum > 0) $ error $ show errnum ++ " failed"
|
|
|
|
{- Actions to perform each time ran. -}
|
|
startup :: Annex Bool
|
|
startup = do
|
|
prepUUID
|
|
return True
|
|
|
|
{- Cleanup actions. -}
|
|
shutdown :: Annex Bool
|
|
shutdown = do
|
|
AnnexQueue.flush False
|
|
|
|
liftIO $ Git.reap
|
|
|
|
return True
|