2011-01-16 20:05:05 +00:00
|
|
|
|
{- git-annex command line parsing and dispatch
|
2010-11-02 23:04:24 +00:00
|
|
|
|
-
|
|
|
|
|
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
|
|
|
|
-
|
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
|
-}
|
|
|
|
|
|
2010-12-30 19:06:26 +00:00
|
|
|
|
module CmdLine (
|
2010-12-30 20:52:24 +00:00
|
|
|
|
dispatch,
|
2010-12-31 00:08:22 +00:00
|
|
|
|
usage,
|
2011-01-16 20:05:05 +00:00
|
|
|
|
shutdown
|
2010-12-30 19:06:26 +00:00
|
|
|
|
) where
|
2010-11-02 23:04:24 +00:00
|
|
|
|
|
2011-11-16 04:49:09 +00:00
|
|
|
|
import qualified Control.Exception as E
|
2012-02-25 22:02:49 +00:00
|
|
|
|
import qualified Data.Map as M
|
2011-11-16 04:49:09 +00:00
|
|
|
|
import Control.Exception (throw)
|
2010-11-02 23:04:24 +00:00
|
|
|
|
import System.Console.GetOpt
|
|
|
|
|
|
2011-10-05 20:02:51 +00:00
|
|
|
|
import Common.Annex
|
2010-11-02 23:04:24 +00:00
|
|
|
|
import qualified Annex
|
2011-10-04 04:40:47 +00:00
|
|
|
|
import qualified Annex.Queue
|
2011-06-30 17:16:57 +00:00
|
|
|
|
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
|
2012-01-20 19:34:52 +00:00
|
|
|
|
import Annex.Ssh
|
2010-11-02 23:04:24 +00:00
|
|
|
|
import Command
|
|
|
|
|
|
2011-10-31 00:04:15 +00:00
|
|
|
|
type Params = [String]
|
|
|
|
|
type Flags = [Annex ()]
|
|
|
|
|
|
2010-12-30 20:52:24 +00:00
|
|
|
|
{- Runs the passed command line. -}
|
2012-02-14 16:40:40 +00:00
|
|
|
|
dispatch :: Params -> [Command] -> [Option] -> String -> IO Git.Repo -> IO ()
|
|
|
|
|
dispatch args cmds commonoptions header getgitrepo = do
|
2011-03-12 19:30:17 +00:00
|
|
|
|
setupConsole
|
2011-11-16 04:49:09 +00:00
|
|
|
|
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)
|
2011-11-16 04:49:09 +00:00
|
|
|
|
Right g -> do
|
|
|
|
|
state <- Annex.new g
|
|
|
|
|
(actions, state') <- Annex.run state $ do
|
|
|
|
|
sequence_ flags
|
|
|
|
|
prepCommand cmd params
|
2012-02-14 16:40:40 +00:00
|
|
|
|
tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdoneshot cmd]
|
2011-10-31 00:04:15 +00:00
|
|
|
|
where
|
2012-01-06 02:48:59 +00:00
|
|
|
|
(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)
|
2012-01-06 02:48:59 +00:00
|
|
|
|
parseCmd argv cmds commonoptions header
|
2012-01-10 19:36:54 +00:00
|
|
|
|
| isNothing name = err "missing command"
|
2012-01-06 02:48:59 +00:00
|
|
|
|
| null matches = err $ "unknown command " ++ fromJust name
|
|
|
|
|
| otherwise = check $ getOpt Permute (commonoptions ++ cmdoptions cmd) args
|
2010-11-02 23:04:24 +00:00
|
|
|
|
where
|
2012-01-06 02:48:59 +00:00
|
|
|
|
(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
|
2012-01-06 02:48:59 +00:00
|
|
|
|
err msg = error $ msg ++ "\n\n" ++ usage header cmds commonoptions
|
2011-01-16 20:05:05 +00:00
|
|
|
|
|
|
|
|
|
{- 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 ()
|
2011-07-15 07:12:05 +00:00
|
|
|
|
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 ()
|
2012-02-13 20:59:00 +00:00
|
|
|
|
tryRun' errnum state cmd (a:as) = do
|
|
|
|
|
r <- run
|
|
|
|
|
handle $! r
|
2011-10-31 00:04:15 +00:00
|
|
|
|
where
|
2012-02-03 20:47:24 +00:00
|
|
|
|
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'
|
2012-02-15 18:35:49 +00:00
|
|
|
|
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
|
2011-01-16 20:05:05 +00:00
|
|
|
|
|
|
|
|
|
{- Actions to perform each time ran. -}
|
|
|
|
|
startup :: Annex Bool
|
2011-08-17 18:14:43 +00:00
|
|
|
|
startup = return True
|
2011-01-16 20:05:05 +00:00
|
|
|
|
|
|
|
|
|
{- Cleanup actions. -}
|
2012-01-28 19:41:52 +00:00
|
|
|
|
shutdown :: Bool -> Annex Bool
|
|
|
|
|
shutdown oneshot = do
|
|
|
|
|
saveState oneshot
|
2012-02-25 22:02:49 +00:00
|
|
|
|
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
|
2012-01-20 19:34:52 +00:00
|
|
|
|
sshCleanup -- ssh connection caching
|
2011-01-30 03:32:32 +00:00
|
|
|
|
return True
|