1{- git-annex command infrastructure
2 -
3 - Copyright 2010-2019 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8module Command (
9	module Command,
10	module ReExported
11) where
12
13import Annex.Common as ReExported
14import Annex.WorkTree as ReExported (whenAnnexed, ifAnnexed)
15import Types.Command as ReExported
16import Types.DeferredParse as ReExported
17import CmdLine.Seek as ReExported
18import CmdLine.Usage as ReExported
19import CmdLine.Action as ReExported
20import CmdLine.Option as ReExported
21import CmdLine.GlobalSetter as ReExported
22import CmdLine.GitAnnex.Options as ReExported
23import CmdLine.Batch as ReExported
24import Options.Applicative as ReExported hiding (command)
25import qualified Git
26import Annex.Init
27import Utility.Daemon
28import Types.Transfer
29import Types.ActionItem
30import Types.WorkerPool as ReExported
31
32{- Generates a normal Command -}
33command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command
34command name section desc paramdesc mkparser =
35	Command commonChecks False False name paramdesc
36		section desc (mkparser paramdesc) mempty [] Nothing
37
38{- Simple option parser that takes all non-option params as-is. -}
39withParams :: (CmdParams -> v) -> CmdParamsDesc -> Parser v
40withParams mkseek paramdesc = mkseek <$> cmdParams paramdesc
41
42{- Uses the supplied option parser, which yields a deferred parse,
43 - and calls finishParse on the result before passing it to the
44 - CommandSeek constructor. -}
45(<--<) :: DeferredParseClass a
46	=> (a -> CommandSeek)
47	-> (CmdParamsDesc -> Parser a)
48	-> CmdParamsDesc
49	-> Parser CommandSeek
50(<--<) mkseek optparser paramsdesc =
51	(mkseek <=< finishParse) <$> optparser paramsdesc
52
53{- Indicates that a command doesn't need to commit any changes to
54 - the git-annex branch. -}
55noCommit :: Command -> Command
56noCommit c = c { cmdnocommit = True }
57
58{- Indicates that a command should not output the usual messages when
59 - starting or stopping processing a file or other item. Unless --json mode
60 - is enabled, this also enables quiet output mode, so only things
61 - explicitly output by the command are shown and not progress messages
62 - etc.
63 -}
64noMessages :: Command -> Command
65noMessages c = c { cmdnomessages = True }
66
67{- Adds a fallback action to a command, that will be run if it's used
68 - outside a git repository. -}
69noRepo :: (String -> Parser (IO ())) -> Command -> Command
70noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) }
71
72{- Adds global options to a command. -}
73withGlobalOptions :: [[GlobalOption]] -> Command -> Command
74withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ concat os }
75
76{- For start stage to indicate what will be done. -}
77starting:: MkActionItem actionitem => String -> actionitem -> SeekInput -> CommandPerform -> CommandStart
78starting msg ai si a = next
79	(StartMessage msg (mkActionItem ai) si, a)
80
81{- Use when noMessages was used but the command is going to output
82 - usual messages after all. -}
83startingUsualMessages :: MkActionItem t => String -> t -> SeekInput -> CommandPerform -> CommandStart
84startingUsualMessages msg t si a = next
85	(StartUsualMessages msg (mkActionItem t) si, a)
86
87{- When no message should be displayed at start/end, but messages can still
88 - be displayed when using eg includeCommandAction. -}
89startingNoMessage :: MkActionItem t => t -> CommandPerform -> CommandStart
90startingNoMessage t a = next (StartNoMessage (mkActionItem t), a)
91
92{- For commands that do not display usual start or end messages,
93 - but have some other custom output. -}
94startingCustomOutput :: MkActionItem t => t -> CommandPerform -> CommandStart
95startingCustomOutput t a = next (CustomOutput (mkActionItem t), a)
96
97{- For perform stage to indicate what step to run next. -}
98next :: a -> Annex (Maybe a)
99next a = return $ Just a
100
101{- For start and perform stage to indicate nothing needs to be done. -}
102stop :: Annex (Maybe a)
103stop = return Nothing
104
105{- Stops unless a condition is met. -}
106stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a)
107stopUnless c a = ifM c ( a , stop )
108
109{- When acting on a failed transfer, stops unless it was in the specified
110 - direction. -}
111checkFailedTransferDirection :: ActionItem -> Direction -> Annex (Maybe a) -> Annex (Maybe a)
112checkFailedTransferDirection ai d = stopUnless (pure check)
113  where
114	check = case actionItemTransferDirection ai of
115		Nothing -> True
116		Just d' -> d' == d
117
118commonChecks :: [CommandCheck]
119commonChecks = [repoExists]
120
121repoExists :: CommandCheck
122repoExists = CommandCheck 0 ensureInitialized
123
124notBareRepo :: Command -> Command
125notBareRepo = addCheck $ whenM (fromRepo Git.repoIsLocalBare) $
126	giveup "You cannot run this command in a bare repository."
127
128noDaemonRunning :: Command -> Command
129noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $
130	giveup "You cannot run this command while git-annex watch or git-annex assistant is running."
131  where
132	daemonpid = liftIO . checkDaemon . fromRawFilePath
133		=<< fromRepo gitAnnexPidFile
134
135dontCheck :: CommandCheck -> Command -> Command
136dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
137
138addCheck :: Annex () -> Command -> Command
139addCheck check cmd = mutateCheck cmd $ \c ->
140	CommandCheck (length c + 100) check : c
141
142mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command
143mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c }
144