git-annex/CmdLine.hs

{- git-annex command line parsing and dispatch
 -
 - Copyright 2010-2021 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

module CmdLine (
	dispatch,
	usage,
	parseCmd,
	prepRunCommand,
) where

import qualified Options.Applicative as O
import qualified Options.Applicative.Help as H
import Control.Exception (throw)
import Control.Monad.IO.Class (MonadIO)
import System.Exit

import Annex.Common
import qualified Annex
import qualified Git
import qualified Git.AutoCorrect
import qualified Git.Config
import Annex.Startup
import Annex.Action
import Annex.Environment
import Command
import Types.Messages

{- Parses input arguments, finds a matching Command, and runs it. -}
dispatch :: Bool -> Bool -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
dispatch addonok fuzzyok allargs allcmds fields getgitrepo progname progdesc =
	go addonok allcmds $
		findAddonCommand subcommandname >>= \case
			Just c -> go addonok (c:allcmds) noop
			Nothing -> go addonok allcmds $
				findAllAddonCommands >>= \cs ->
					go False (cs++allcmds) noop
  where
	go p allcmds' cont =
		let (fuzzy, cmds) = selectCmd fuzzyok allcmds' subcommandname
		in if not p || (not fuzzy && not (null cmds))
			then dispatch' subcommandname args fuzzy cmds allargs allcmds' fields getgitrepo progname progdesc
			else cont
	
	(subcommandname, args) = subCmdName allargs

dispatch' :: (Maybe String) -> CmdParams -> Bool -> [Command] -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
dispatch' subcommandname args fuzzy cmds allargs allcmds fields getgitrepo progname progdesc = do
	setupConsole
	go =<< tryNonAsync getgitrepo
  where
	go (Right g) = do
		g' <- Git.Config.read g
		(cmd, seek, annexsetter) <- parsewith False cmdparser
			(\a -> a (Just g'))
			O.handleParseResult
		state <- applyAnnexReadSetter annexsetter <$> Annex.new g'
		Annex.eval state $ do
			checkEnvironment
			forM_ fields $ uncurry Annex.setField
			prepRunCommand cmd annexsetter
			startup
			performCommandAction True cmd seek $
				quiesce $ cmdnocommit cmd
	go (Left norepo) = do
		let ingitrepo = \a -> a =<< Git.Config.global
		-- Parse command line with full cmdparser first,
		-- so that help can be displayed for bad parses
		-- even when not run in a repo.
		res <- parsewith False cmdparser ingitrepo return
		case res of
			Failure _ -> void (O.handleParseResult res)
			_ -> do
				-- Parse command line in norepo mode.
				(_, a, _globalconfig) <- parsewith True
					(fromMaybe (throw norepo) . cmdnorepo)
					ingitrepo
					O.handleParseResult
				a

	parsewith secondrun getparser ingitrepo handleresult =
		case parseCmd progname progdesc allargs allcmds getparser of
			O.Failure _ -> do
				-- parse failed, so fall back to
				-- fuzzy matching, or to showing usage
				when (fuzzy && not secondrun) $
					ingitrepo autocorrect
				handleresult (parseCmd progname progdesc correctedargs allcmds getparser)
			res -> handleresult res
	  where
		autocorrect = Git.AutoCorrect.prepare (fromJust subcommandname) cmdname cmds
		name
			| fuzzy = case cmds of
				(c:_) -> Just (cmdname c)
				_ -> subcommandname
			| otherwise = subcommandname
		correctedargs = case name of
			Nothing -> allargs
			Just n -> n:args

{- Parses command line, selecting one of the commands from the list. -}
parseCmd :: String -> String -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v, AnnexSetter)
parseCmd progname progdesc allargs allcmds getparser = 
	O.execParserPure (O.prefs O.idm) pinfo allargs
  where
	pinfo = O.info (O.helper <*> subcmds) (O.progDescDoc (Just intro))
	subcmds = O.hsubparser $ mconcat $ map mkcommand allcmds
	mkcommand c = O.command (cmdname c) $ O.info (mkparser c) $ O.fullDesc 
		<> O.header (synopsis (progname ++ " " ++ cmdname c) (cmddesc c))
		<> O.footer ("For details, run: " ++ progname ++ " help " ++ cmdname c)
		<> cmdinfomod c
	mkparser c = (,,) 
		<$> pure c
		<*> getparser c
		<*> parserAnnexOptions (cmdannexoptions c)
	synopsis n d = n ++ " - " ++ d
	intro = mconcat $ concatMap (\l -> [H.pretty l, H.line])
		(synopsis progname progdesc : commandList allcmds)

{- Selects the Command that matches the subcommand name.
 - Does fuzzy matching if necessary, which may result in multiple Commands. -}
selectCmd :: Bool -> [Command] -> Maybe String -> (Bool, [Command])
selectCmd fuzzyok cmds (Just n)
	| not (null exactcmds) = (False, exactcmds)
	| fuzzyok && not (null inexactcmds) = (True, inexactcmds)
	| otherwise = (False, [])
  where
	exactcmds = filter (\c -> cmdname c == n) cmds
	inexactcmds = Git.AutoCorrect.fuzzymatches n cmdname cmds
selectCmd _ _ Nothing = (False, [])

{- Parses command line params far enough to find the subcommand name. -}
subCmdName :: CmdParams -> (Maybe String, CmdParams)
subCmdName argv = (name, args)
  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)

-- | Note that the AnnexSetter must have already had its annexReadSetter
-- applied before entering the Annex monad to run this; that cannot be
-- changed while running in the Annex monad.
prepRunCommand :: Command -> AnnexSetter -> Annex ()
prepRunCommand cmd annexsetter = do
	when (cmdnomessages cmd) $
		Annex.setOutput QuietOutput
	annexStateSetter annexsetter
	whenM (Annex.getRead Annex.debugenabled) $
		enableDebugOutput

findAddonCommand :: Maybe String -> IO (Maybe Command)
findAddonCommand Nothing = return Nothing
findAddonCommand (Just subcommandname) =
	searchPath c >>= \case
		Nothing -> return Nothing
		Just p -> return (Just (mkAddonCommand p subcommandname))
  where
	c = "git-annex-" ++ subcommandname

findAllAddonCommands :: IO [Command]
findAllAddonCommands = 
	filter isaddoncommand
		. map (\p -> mkAddonCommand p (deprefix p))
		<$> searchPathContents ("git-annex-" `isPrefixOf`)
  where
	deprefix = replace "git-annex-" "" . takeFileName
	isaddoncommand c
		-- git-annex-shell
		| cmdname c == "shell" = False
		-- external special remotes
		| "remote-" `isPrefixOf` cmdname c = False
		-- external backends
		| "backend-" `isPrefixOf` cmdname c = False
		| otherwise = True

mkAddonCommand :: FilePath -> String -> Command
mkAddonCommand p subcommandname = Command
	{ cmdcheck = []
	, cmdnocommit = True
	, cmdnomessages = True
	, cmdname = subcommandname
	, cmdparamdesc = "[PARAMS]"
	, cmdsection = SectionAddOn
	, cmddesc = "addon command"
	, cmdannexoptions = []
	, cmdinfomod = O.forwardOptions
	, cmdparser = parse
	, cmdnorepo = Just parse
	}
  where
	parse :: (Monad m, MonadIO m) => Parser (m ())
	parse = (liftIO . run) <$> cmdParams "PARAMS"

	run ps = withCreateProcess (proc p ps) $ \_ _ _ pid ->
		exitWith =<< waitForProcess pid