git-annex/CmdLine.hs

103 lines
3.2 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 qualified Control.Exception as E
import qualified Data.Map as M
import Control.Exception (throw)
import System.Console.GetOpt
2011-10-05 20:02:51 +00:00
import Common.Annex
import qualified Annex
2011-10-04 04:40:47 +00:00
import qualified Annex.Queue
import qualified Git
2011-12-14 19:56:11 +00:00
import qualified Git.Command
2011-10-04 04:40:47 +00:00
import Annex.Content
import Annex.Ssh
import Command
2011-10-31 00:04:15 +00:00
type Params = [String]
type Flags = [Annex ()]
{- Runs the passed command line. -}
dispatch :: Params -> [Command] -> [Option] -> String -> IO Git.Repo -> IO ()
dispatch args cmds commonoptions header getgitrepo = do
setupConsole
r <- E.try getgitrepo :: IO (Either E.SomeException Git.Repo)
case r of
2011-12-09 05:57:13 +00:00
Left e -> fromMaybe (throw e) (cmdnorepo cmd)
Right g -> do
state <- Annex.new g
(actions, state') <- Annex.run state $ do
sequence_ flags
prepCommand cmd params
tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdoneshot cmd]
2011-10-31 00:04:15 +00:00
where
(flags, cmd, params) = parseCmd args cmds commonoptions header
2010-12-30 19:44:15 +00:00
2011-10-31 00:04:15 +00:00
{- Parses command line, and returns actions to run to configure flags,
- the Command being run, and the remaining parameters for the command. -}
parseCmd :: Params -> [Command] -> [Option] -> String -> (Flags, Command, Params)
parseCmd argv cmds commonoptions header
2012-01-10 19:36:54 +00:00
| isNothing name = err "missing command"
| null matches = err $ "unknown command " ++ fromJust name
| otherwise = check $ getOpt Permute (commonoptions ++ cmdoptions cmd) args
where
(name, args) = findname argv []
findname [] c = (Nothing, reverse c)
findname (a:as) c
| "-" `isPrefixOf` a = findname as (a:c)
| otherwise = (Just a, reverse c ++ as)
matches = filter (\c -> name == Just (cmdname c)) cmds
cmd = Prelude.head matches
check (flags, rest, []) = (flags, cmd, rest)
2011-10-31 00:04:15 +00:00
check (_, _, errs) = err $ concat errs
err msg = error $ msg ++ "\n\n" ++ usage header cmds commonoptions
{- Runs a list of Annex actions. Catches IO errors and continues
- (but explicitly thrown errors terminate the whole command).
-}
2011-10-31 00:04:15 +00:00
tryRun :: Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
tryRun = tryRun' 0
2011-10-31 00:04:15 +00:00
tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
tryRun' errnum _ cmd []
| errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
| otherwise = return ()
tryRun' errnum state cmd (a:as) = do
r <- run
handle $! r
2011-10-31 00:04:15 +00:00
where
run = tryIO $ Annex.run state $ do
2011-10-31 00:04:15 +00:00
Annex.Queue.flushWhenFull
a
handle (Left err) = showerr err >> cont False state
handle (Right (success, state')) = cont success state'
cont success s = do
let errnum' = if success then errnum else errnum + 1
(tryRun' $! errnum') s cmd as
2011-10-31 00:04:15 +00:00
showerr err = Annex.eval state $ do
showErr err
showEndFail
{- Actions to perform each time ran. -}
startup :: Annex Bool
startup = return True
{- Cleanup actions. -}
shutdown :: Bool -> Annex Bool
shutdown oneshot = do
saveState oneshot
sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
2011-12-14 19:56:11 +00:00
liftIO Git.Command.reap -- zombies from long-running git processes
sshCleanup -- ssh connection caching
2011-01-30 03:32:32 +00:00
return True