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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
| -- Copyright (C) 2002,2003,2005 David Roundy
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING. If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.
{-# LANGUAGE OverloadedStrings #-}
-- | This is the actual heavy lifter code, which is responsible for parsing the
-- arguments and then running the command itself.
module Darcs.UI.RunCommand
( runTheCommand
, runWithHooks -- exported for darcsden
) where
import Darcs.Prelude
import Control.Monad ( unless, when )
import Data.List ( intercalate )
import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),
OptDescr( Option ),
getOpt )
import System.Exit ( ExitCode ( ExitSuccess ), exitWith )
import Darcs.UI.Options ( (^), odesc, oparse, parseFlags, optDescr, (?) )
import Darcs.UI.Options.All
( stdCmdActions, StdCmdAction(..)
, debugging, verbosity, Verbosity(..)
, HooksConfig(..), hooks )
import Darcs.UI.Defaults ( applyDefaults )
import Darcs.UI.External ( viewDoc )
import Darcs.UI.Flags ( DarcsFlag, matchAny, withNewRepo )
import Darcs.UI.Commands
( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub )
, CommandControl
, DarcsCommand
, commandName
, commandCommand
, commandPrereq
, commandExtraArgHelp
, commandExtraArgs
, commandArgdefaults
, commandCompleteArgs
, commandOptDescr
, commandName
, disambiguateCommands
, getSubcommands
, extractCommands
, superName
)
import Darcs.UI.Commands.GZCRCs ( doCRCWarnings )
import Darcs.UI.Commands.Clone ( makeRepoName, cloneToSSH )
import Darcs.UI.RunHook ( runPosthook, runPrehook )
import Darcs.UI.Usage
( getCommandHelp
, getCommandMiniHelp
, subusage
)
import Darcs.Patch.Match ( checkMatchSyntax )
import Darcs.Repository.Prefs ( Pref(Defaults), getGlobal, getPreflist )
import Darcs.Util.AtExit ( atexit )
import Darcs.Util.Exception ( die )
import Darcs.Util.Global ( setDebugMode, setTimingsMode )
import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute )
import Darcs.Util.Printer ( (<+>), ($+$), renderString, text, vcat )
import Darcs.Util.Printer.Color ( ePutDocLn )
import Darcs.Util.Progress ( setProgressMode )
runTheCommand :: [CommandControl] -> String -> [String] -> IO ()
runTheCommand commandControlList cmd args =
either die rtc $ disambiguateCommands commandControlList cmd args
where
rtc (CommandOnly c, as) = runCommand Nothing c as
rtc (SuperCommandOnly c, as) = runRawSupercommand c as
rtc (SuperCommandSub c s, as) = runCommand (Just c) s as
runCommand :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO ()
runCommand _ _ args -- Check for "dangerous" typoes...
| "-all" `elem` args = -- -all indicates --all --look-for-adds!
die "Are you sure you didn't mean --all rather than -all?"
runCommand msuper cmd args = do
old_wd <- getCurrentDirectory
let options = commandOptDescr old_wd cmd
case fixupMsgs $ getOpt Permute options args of
(cmdline_flags,orig_extra,getopt_errs) -> do
-- FIXME This code is highly order-dependent because of hidden state: the
-- current directory. Like almost all Repository functions, getGlobal and
-- getPreflist assume that the cwd is the base of our work repo (if any).
-- This is supposed to be ensured by commandPrereq. Which means we must
-- first call commandPrereq, then getGlobal and getPreflist, and then we
-- must use the (saved) original working directory to resolve possibly
-- relative paths to absolute paths.
prereq_errors <- commandPrereq cmd cmdline_flags
-- we must get the cwd again because commandPrereq has the side-effect of changing it.
new_wd <- getCurrentDirectory
user_defs <- getGlobal Defaults
repo_defs <- getPreflist Defaults
let (flags, (flag_warnings, flag_errors)) =
applyDefaults (fmap commandName msuper) cmd old_wd user_defs repo_defs cmdline_flags
case parseFlags stdCmdActions flags of
Just Help -> viewDoc $ getCommandHelp msuper cmd
Just ListOptions -> do
setProgressMode False
possible_args <- commandCompleteArgs cmd (new_wd, old_wd) flags orig_extra
mapM_ putStrLn $ optionList options ++ possible_args
Just Disable ->
die $ "Command "++commandName cmd++" disabled with --disable option!"
Nothing -> case prereq_errors of
Left complaint -> die $
"Unable to '" ++ "darcs " ++ superName msuper ++ commandName cmd ++
"' here:\n" ++ complaint
Right () -> do
ePutDocLn $ vcat $ map text $ flag_warnings
case getopt_errs ++ flag_errors of
[] -> do
extra <- commandArgdefaults cmd flags old_wd orig_extra
case extraArgumentsError extra cmd msuper of
Nothing -> runWithHooks cmd (new_wd, old_wd) flags extra
Just msg -> die msg
errors -> fail $ intercalate "\n" errors
fixupMsgs :: (a, b, [String]) -> (a, b, [String])
fixupMsgs (fs,as,es) = (fs,as,map (("command line: "++).chompTrailingNewline) es)
where
chompTrailingNewline "" = ""
chompTrailingNewline s = if last s == '\n' then init s else s
runWithHooks :: DarcsCommand
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO ()
runWithHooks cmd (new_wd, old_wd) flags extra = do
checkMatchSyntax $ matchAny ? flags
-- set any global variables
oparse (verbosity ^ debugging) setGlobalVariables flags
-- actually run the command and its hooks
let hooksCfg = parseFlags hooks flags
let verb = parseFlags verbosity flags
preHookExitCode <- runPrehook (pre hooksCfg) verb new_wd
if preHookExitCode /= ExitSuccess
then exitWith preHookExitCode
else do phDir <- getPosthookDir new_wd cmd flags extra
commandCommand cmd (new_wd, old_wd) flags extra
postHookExitCode <- runPosthook (post hooksCfg) verb phDir
exitWith postHookExitCode
setGlobalVariables :: Verbosity -> Bool -> Bool -> IO ()
setGlobalVariables verb debug timings = do
when timings setTimingsMode
when debug setDebugMode
when (verb == Quiet) $ setProgressMode False
unless (verb == Quiet) $ atexit $ doCRCWarnings (verb == Verbose)
-- | Returns the working directory for the posthook. For most commands, the
-- first parameter is returned. For the \'get\' command, the path of the newly
-- created repository is returned if it is not an ssh url.
getPosthookDir :: AbsolutePath -> DarcsCommand -> [DarcsFlag] -> [String] -> IO AbsolutePath
getPosthookDir new_wd cmd flags extra | commandName cmd `elem` ["get","clone"] = do
case extra of
[inrepodir, outname] -> getPosthookDir new_wd cmd (withNewRepo outname flags) [inrepodir]
[inrepodir] ->
case cloneToSSH flags of
Nothing -> do
repodir <- toPath <$> ioAbsoluteOrRemote inrepodir
newRepo <- makeRepoName False flags repodir
return $ makeAbsolute new_wd newRepo
_ -> return new_wd
_ -> die "You must provide 'clone' with either one or two arguments."
getPosthookDir new_wd _ _ _ = return new_wd
-- | Checks if the number of extra arguments matches the number of extra
-- arguments supported by the command as specified in `commandExtraArgs`.
-- Extra arguments are arguments that follow the command but aren't
-- considered a flag. In `darcs push xyz`, xyz would be an extra argument.
extraArgumentsError :: [String] -- extra commands provided by user
-> DarcsCommand
-> Maybe DarcsCommand
-> Maybe String
extraArgumentsError extra cmd msuper
| extraArgsCmd < 0 = Nothing
| extraArgsInput > extraArgsCmd = Just badArg
| extraArgsInput < extraArgsCmd = Just missingArg
| otherwise = Nothing
where
extraArgsInput = length extra
extraArgsCmd = commandExtraArgs cmd
badArg = "Bad argument: `" ++ unwords extra ++
"'\n" ++ getCommandMiniHelp msuper cmd
missingArg = "Missing argument: " ++ nthArg (length extra + 1) ++
"\n" ++ getCommandMiniHelp msuper cmd
nthArg n = nthOf n (commandExtraArgHelp cmd)
nthOf 1 (h:_) = h
nthOf n (_:hs) = nthOf (n-1) hs
nthOf _ [] = "UNDOCUMENTED"
optionList :: [OptDescr DarcsFlag] -> [String]
optionList = concatMap names
where
names (Option sos los _ desc) =
map (short desc) sos ++ map (long desc) los
short d o = '-' : o : ";" ++ d
long d o = "--" ++ o ++ ";" ++ d
runRawSupercommand :: DarcsCommand -> [String] -> IO ()
runRawSupercommand super [] =
die $ renderString $
"Command '" <> text (commandName super) <> "' requires a subcommand!"
$+$
subusage super
runRawSupercommand super args = do
cwd <- getCurrentDirectory
case fixupMsgs $ getOpt RequireOrder (map (optDescr cwd) (odesc stdCmdActions)) args of
-- note: we do not apply defaults here
(flags,_,getopt_errs) -> case parseFlags stdCmdActions flags of
Just Help ->
viewDoc $ getCommandHelp Nothing super
Just ListOptions -> do
putStrLn "--help"
mapM_ (putStrLn . commandName) (extractCommands $ getSubcommands super)
Just Disable -> do
die $ renderString $
"Command" <+> text (commandName super) <+> "disabled with --disable option!"
Nothing ->
die $ renderString $
case getopt_errs of
[] -> text "Invalid subcommand!" $+$ subusage super
_ -> vcat (map text getopt_errs)
|