9f1577f746
The only remaining vestiage of backends is different types of keys. These are still called "backends", mostly to avoid needing to change user interface and configuration. But everything to do with storing keys in different backends was gone; instead different types of remotes are used. In the refactoring, lots of code was moved out of odd corners like Backend.File, to closer to where it's used, like Command.Drop and Command.Fsck. Quite a lot of dead code was removed. Several data structures became simpler, which may result in better runtime efficiency. There should be no user-visible changes.
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 Git
|
|
import Content
|
|
import Types
|
|
import Command
|
|
import Version
|
|
import Options
|
|
import Messages
|
|
import UUID
|
|
|
|
{- 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
|
|
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 $ do
|
|
showEndFail
|
|
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
|
|
saveState
|
|
liftIO $ Git.reap
|
|
return True
|