1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
{- 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 Common.Annex
import qualified Annex
import qualified Annex.Queue
import qualified Git
import Annex.Content
import Command
import Options
import Init
{- Runs the passed command line. -}
dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO ()
dispatch args cmds options header gitrepo = do
setupConsole
state <- Annex.new gitrepo
(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
checkCmdEnviron command
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
{- Checks that the command can be run in the current environment. -}
checkCmdEnviron :: Command -> Annex ()
checkCmdEnviron command = when (cmdusesrepo command) ensureInitialized
{- 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 = tryRun' 0
tryRun' :: Integer -> Annex.AnnexState -> [Annex Bool] -> IO ()
tryRun' errnum state (a:as) = do
result <- try $ Annex.run state $ do
Annex.Queue.flushWhenFull
a
case result of
Left err -> do
Annex.eval state $ do
showErr err
showEndFail
tryRun' (errnum + 1) state as
Right (True,state') -> tryRun' errnum state' as
Right (False,state') -> tryRun' (errnum + 1) state' as
tryRun' errnum _ [] = when (errnum > 0) $ error $ show errnum ++ " failed"
{- Actions to perform each time ran. -}
startup :: Annex Bool
startup = return True
{- Cleanup actions. -}
shutdown :: Annex Bool
shutdown = do
saveState
liftIO Git.reap -- zombies from long-running git processes
return True
|
