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