summaryrefslogtreecommitdiff
path: root/CmdLine.hs
blob: 8cf4d0544d45ec6c4995609c19b2f003daaf37a8 (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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
{- 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