git-annex/CmdLine.hs

109 lines
3.1 KiB
Haskell
Raw Normal View History

{- 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
2010-12-30 19:44:15 +00:00
import qualified GitRepo as Git
import Content
import Types
import Command
2010-12-30 19:44:15 +00:00
import BackendList
import Version
import Options
import Messages
import UUID
{- Runs the passed command line. -}
2011-06-02 06:40:43 +00:00
dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO ()
dispatch args cmds options header gitrepo = do
setupConsole
2010-12-30 19:44:15 +00:00
state <- Annex.new gitrepo allBackends
(actions, state') <- Annex.run state $ parseCmd args header cmds options
tryRun state' $ [startup] ++ actions ++ [shutdown]
2010-12-30 19:44:15 +00:00
{- 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
2010-11-06 21:06:19 +00:00
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 ++
2010-12-30 19:15:22 +00:00
pad (longest cmdname + 1) (cmdname c) ++
cmdparams c ++
2010-12-30 19:15:22 +00:00
pad (longest cmdparams + 2) (cmdparams c) ++
cmddesc c
pad n s = replicate (n - length s) ' '
2010-12-30 19:15:22 +00:00
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
2011-01-30 03:32:32 +00:00
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. -}
2011-01-30 03:32:32 +00:00
shutdown :: Annex Bool
shutdown = do
saveState
liftIO $ Git.reap
2011-01-30 03:32:32 +00:00
return True