138 lines
4.3 KiB
Haskell
138 lines
4.3 KiB
Haskell
{- git-annex command line parsing and dispatch
|
||
-
|
||
- Copyright 2010-2012 Joey Hess <joey@kitenet.net>
|
||
-
|
||
- Licensed under the GNU GPL version 3 or higher.
|
||
-}
|
||
|
||
{-# LANGUAGE CPP #-}
|
||
|
||
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
|
||
#ifndef __WINDOWS__
|
||
import System.Posix.Signals
|
||
#endif
|
||
|
||
import Common.Annex
|
||
import qualified Annex
|
||
import qualified Annex.Queue
|
||
import qualified Git
|
||
import qualified Git.AutoCorrect
|
||
import Annex.Content
|
||
import Annex.Ssh
|
||
import Annex.Environment
|
||
import Command
|
||
import Types.Messages
|
||
|
||
type Params = [String]
|
||
type Flags = [Annex ()]
|
||
|
||
{- Runs the passed command line. -}
|
||
dispatch :: Bool -> Params -> [Command] -> [Option] -> [(String, String)] -> String -> IO Git.Repo -> IO ()
|
||
dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
|
||
setupConsole
|
||
r <- E.try getgitrepo :: IO (Either E.SomeException Git.Repo)
|
||
case r of
|
||
Left e -> fromMaybe (throw e) (cmdnorepo cmd)
|
||
Right g -> do
|
||
state <- Annex.new g
|
||
(actions, state') <- Annex.run state $ do
|
||
checkEnvironment
|
||
checkfuzzy
|
||
forM_ fields $ uncurry Annex.setField
|
||
when (cmdnomessages cmd) $
|
||
Annex.setOutput QuietOutput
|
||
sequence_ flags
|
||
whenM (annexDebug <$> Annex.getGitConfig) $
|
||
liftIO enableDebugOutput
|
||
prepCommand cmd params
|
||
tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdnocommit cmd]
|
||
where
|
||
err msg = msg ++ "\n\n" ++ usage header allcmds
|
||
cmd = Prelude.head cmds
|
||
(fuzzy, cmds, name, args) = findCmd fuzzyok allargs allcmds err
|
||
(flags, params) = getOptCmd args cmd commonoptions
|
||
checkfuzzy = when fuzzy $
|
||
inRepo $ Git.AutoCorrect.prepare name cmdname cmds
|
||
|
||
{- Parses command line params far enough to find the Command to run, and
|
||
- returns the remaining params.
|
||
- Does fuzzy matching if necessary, which may result in multiple Commands. -}
|
||
findCmd :: Bool -> Params -> [Command] -> (String -> String) -> (Bool, [Command], String, Params)
|
||
findCmd fuzzyok argv cmds err
|
||
| isNothing name = error $ err "missing command"
|
||
| not (null exactcmds) = (False, exactcmds, fromJust name, args)
|
||
| fuzzyok && not (null inexactcmds) = (True, inexactcmds, fromJust name, args)
|
||
| otherwise = error $ err $ "unknown command " ++ fromJust name
|
||
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)
|
||
exactcmds = filter (\c -> name == Just (cmdname c)) cmds
|
||
inexactcmds = case name of
|
||
Nothing -> []
|
||
Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds
|
||
|
||
{- Parses command line options, and returns actions to run to configure flags
|
||
- and the remaining parameters for the command. -}
|
||
getOptCmd :: Params -> Command -> [Option] -> (Flags, Params)
|
||
getOptCmd argv cmd commonoptions = check $
|
||
getOpt Permute (commonoptions ++ cmdoptions cmd) argv
|
||
where
|
||
check (flags, rest, []) = (flags, rest)
|
||
check (_, _, errs) = error $ unlines
|
||
[ concat errs
|
||
, commandUsage cmd
|
||
]
|
||
|
||
{- Runs a list of Annex actions. Catches IO errors and continues
|
||
- (but explicitly thrown errors terminate the whole command).
|
||
-}
|
||
tryRun :: Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
|
||
tryRun = tryRun' 0
|
||
tryRun' :: Integer -> Annex.AnnexState -> Command -> [CommandCleanup] -> IO ()
|
||
tryRun' errnum _ cmd []
|
||
| errnum > 0 = error $ cmdname cmd ++ ": " ++ show errnum ++ " failed"
|
||
| otherwise = noop
|
||
tryRun' errnum state cmd (a:as) = do
|
||
r <- run
|
||
handle $! r
|
||
where
|
||
run = tryIO $ Annex.run state $ do
|
||
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
|
||
showerr err = Annex.eval state $ do
|
||
showErr err
|
||
showEndFail
|
||
|
||
{- Actions to perform each time ran. -}
|
||
startup :: Annex Bool
|
||
startup = liftIO $ do
|
||
#ifndef __WINDOWS__
|
||
void $ installHandler sigINT Default Nothing
|
||
#endif
|
||
return True
|
||
|
||
{- Cleanup actions. -}
|
||
shutdown :: Bool -> Annex Bool
|
||
shutdown nocommit = do
|
||
saveState nocommit
|
||
sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
|
||
liftIO reapZombies -- zombies from long-running git processes
|
||
sshCleanup -- ssh connection caching
|
||
return True
|