summaryrefslogtreecommitdiff
path: root/CmdLine.hs
blob: 1d93855ce87f8fe09a97cba3d50705a2903fc954 (plain)
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
106
107
108
109
110
111
112
113
{- 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 mingw32_HOST_OS
import System.Posix.Signals
#endif

import Common.Annex
import qualified Annex
import qualified Git
import qualified Git.AutoCorrect
import qualified Git.Config
import Annex.Content
import Annex.Environment
import Command
import Types.Messages

{- Runs the passed command line. -}
dispatch :: Bool -> CmdParams -> [Command] -> [Option] -> [(String, String)] -> String -> IO Git.Repo -> IO ()
dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
	setupConsole
	case getOptCmd args cmd commonoptions of
		Right (flags, params) -> go flags params
			=<< (E.try getgitrepo :: IO (Either E.SomeException Git.Repo))
		Left parseerr -> error parseerr
  where
	go flags params (Right g) = do
		state <- Annex.new g
		Annex.eval state $ do
			checkEnvironment
			when fuzzy $
				inRepo $ autocorrect . Just
			forM_ fields $ uncurry Annex.setField
			when (cmdnomessages cmd) $ 
				Annex.setOutput QuietOutput
			sequence_ flags
			whenM (annexDebug <$> Annex.getGitConfig) $
				liftIO enableDebugOutput
			startup
			performCommandAction cmd params $
				shutdown $ cmdnocommit cmd
	go _flags params (Left e) = do
		when fuzzy $
			autocorrect =<< Git.Config.global
		maybe (throw e) (\a -> a params) (cmdnorepo cmd)
	err msg = msg ++ "\n\n" ++ usage header allcmds
	cmd = Prelude.head cmds
	(fuzzy, cmds, name, args) = findCmd fuzzyok allargs allcmds err
	autocorrect = 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 -> CmdParams -> [Command] -> (String -> String) -> (Bool, [Command], String, CmdParams)
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 :: CmdParams -> Command -> [Option] -> Either String ([Annex ()], CmdParams)
getOptCmd argv cmd commonoptions = check $
	getOpt Permute (commonoptions ++ cmdoptions cmd) argv
  where
	check (flags, rest, []) = Right (flags, rest)
	check (_, _, errs) = Left $ unlines
		[ concat errs
		, commandUsage cmd
		]

{- Actions to perform each time ran. -}
startup :: Annex ()
startup =
#ifndef mingw32_HOST_OS
	liftIO $ void $ installHandler sigINT Default Nothing
#else
	return ()
#endif

{- Cleanup actions. -}
shutdown :: Bool -> Annex ()
shutdown nocommit = do
	saveState nocommit
	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
	liftIO reapZombies -- zombies from long-running git processes