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
|
{- git-annex command infrastructure
-
- Copyright 2010-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Command (
module Command,
module ReExported
) where
import Annex.Common as ReExported
import Types.Command as ReExported
import Types.DeferredParse as ReExported
import CmdLine.Seek as ReExported
import CmdLine.Usage as ReExported
import CmdLine.Action as ReExported
import CmdLine.Option as ReExported
import CmdLine.AnnexSetter as ReExported
import CmdLine.GitAnnex.Options as ReExported
import CmdLine.Batch as ReExported
import Options.Applicative as ReExported hiding (command)
import qualified Git
import Annex.Init
import Utility.Daemon
import Types.Transfer
import Types.ActionItem
import Types.WorkerPool as ReExported
import Remote.List
{- Generates a normal Command -}
command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command
command name section desc paramdesc mkparser =
Command commonChecks False False name paramdesc
section desc (mkparser paramdesc) mempty [] Nothing
{- Simple option parser that takes all non-option params as-is. -}
withParams :: (CmdParams -> v) -> CmdParamsDesc -> Parser v
withParams mkseek paramdesc = mkseek <$> cmdParams paramdesc
{- Uses the supplied option parser, which yields a deferred parse,
- and calls finishParse on the result before passing it to the
- CommandSeek constructor. -}
(<--<) :: DeferredParseClass a
=> (a -> CommandSeek)
-> (CmdParamsDesc -> Parser a)
-> CmdParamsDesc
-> Parser CommandSeek
(<--<) mkseek optparser paramsdesc =
(mkseek <=< finishParse) <$> optparser paramsdesc
{- Indicates that a command doesn't need to commit any changes to
- the git-annex branch. -}
noCommit :: Command -> Command
noCommit c = c { cmdnocommit = True }
{- Indicates that a command should not output the usual messages when
- starting or stopping processing a file or other item. Unless --json mode
- is enabled, this also enables quiet output mode, so only things
- explicitly output by the command are shown and not progress messages
- etc.
-}
noMessages :: Command -> Command
noMessages c = c { cmdnomessages = True }
{- Adds a fallback action to a command, that will be run if it's used
- outside a git repository. -}
noRepo :: (String -> Parser (IO ())) -> Command -> Command
noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) }
{- Adds Annex options to a command. -}
withAnnexOptions :: [[AnnexOption]] -> Command -> Command
withAnnexOptions os c = c { cmdannexoptions = cmdannexoptions c ++ concat os }
{- For start stage to indicate what will be done. -}
starting:: MkActionItem actionitem => String -> actionitem -> SeekInput -> CommandPerform -> CommandStart
starting msg ai si a = next
(StartMessage msg (mkActionItem ai) si, a)
{- Use when noMessages was used but the command is going to output
- usual messages after all. -}
startingUsualMessages :: MkActionItem t => String -> t -> SeekInput -> CommandPerform -> CommandStart
startingUsualMessages msg t si a = next
(StartUsualMessages msg (mkActionItem t) si, a)
{- When no message should be displayed at start/end, but messages can still
- be displayed when using eg includeCommandAction. -}
startingNoMessage :: MkActionItem t => t -> CommandPerform -> CommandStart
startingNoMessage t a = next (StartNoMessage (mkActionItem t), a)
{- For commands that do not display usual start or end messages,
- but have some other custom output. -}
startingCustomOutput :: MkActionItem t => t -> CommandPerform -> CommandStart
startingCustomOutput t a = next (CustomOutput (mkActionItem t), a)
{- For perform stage to indicate what step to run next. -}
next :: a -> Annex (Maybe a)
next a = return $ Just a
{- For start and perform stage to indicate nothing needs to be done. -}
stop :: Annex (Maybe a)
stop = return Nothing
{- Stops unless a condition is met. -}
stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
stopUnless c a = ifM c ( a , stop )
{- When doing a dry run, avoid actually performing the action, but pretend
- that it succeeded. -}
skipWhenDryRun :: DryRun -> CommandPerform -> CommandPerform
skipWhenDryRun (DryRun False) a = a
skipWhenDryRun (DryRun True) _ = next $ return True
{- When acting on a failed transfer, stops unless it was in the specified
- direction. -}
checkFailedTransferDirection :: ActionItem -> Direction -> Annex (Maybe a) -> Annex (Maybe a)
checkFailedTransferDirection ai d = stopUnless (pure check)
where
check = case actionItemTransferDirection ai of
Nothing -> True
Just d' -> d' == d
commonChecks :: [CommandCheck]
commonChecks = [repoExists]
repoExists :: CommandCheck
repoExists = CommandCheck 0 (ensureInitialized remoteList)
notBareRepo :: Command -> Command
notBareRepo = addCheck checkNotBareRepo
checkNotBareRepo :: Annex ()
checkNotBareRepo = whenM (fromRepo Git.repoIsLocalBare) $
giveup "You cannot run this command in a bare repository."
noDaemonRunning :: Command -> Command
noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $
giveup "You cannot run this command while git-annex watch or git-annex assistant is running."
where
daemonpid = liftIO . checkDaemon . fromRawFilePath
=<< fromRepo gitAnnexPidFile
dontCheck :: CommandCheck -> Command -> Command
dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
addCheck :: Annex () -> Command -> Command
addCheck check cmd = mutateCheck cmd $ \c ->
CommandCheck (length c + 100) check : c
mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command
mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c }
|
