Skip to content
Snippets Groups Projects
CmdLine.hs 6.06 KiB
Newer Older
Joey Hess's avatar
Joey Hess committed
{- git-annex command line parsing and dispatch
Joey Hess's avatar
Joey Hess committed
 - Copyright 2010-2021 Joey Hess <id@joeyh.name>
 - Licensed under the GNU AGPL version 3 or higher.
Joey Hess's avatar
Joey Hess committed
	dispatch,
import qualified Options.Applicative as O
import qualified Options.Applicative.Help as H
Joey Hess's avatar
Joey Hess committed
import Control.Monad.IO.Class (MonadIO)
import System.Exit
import qualified Annex
Joey Hess's avatar
Joey Hess committed
import qualified Git
Joey Hess's avatar
Joey Hess committed
import qualified Git.AutoCorrect
import Command
Joey Hess's avatar
Joey Hess committed
{- 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
			Nothing -> go False allcmds noop
			Just c -> go addonok (c: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
	go =<< tryNonAsync getgitrepo
  where
	go (Right g) = do
		state <- Annex.new g
		Annex.eval state $ do
			checkEnvironment
			forM_ fields $ uncurry Annex.setField
			(cmd, seek, globalconfig) <- parsewith False cmdparser
			performCommandAction cmd seek $
				shutdown $ cmdnocommit cmd
		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
				handleresult (parseCmd progname progdesc correctedargs allcmds getparser)
Joey Hess's avatar
Joey Hess committed
		autocorrect = Git.AutoCorrect.prepare (fromJust subcommandname) cmdname cmds
Joey Hess's avatar
Joey Hess committed
				_ -> 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, GlobalSetter)
parseCmd progname progdesc allargs allcmds getparser = 
Joey Hess's avatar
Joey Hess committed
	O.execParserPure (O.prefs O.idm) pinfo allargs
	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)
Joey Hess's avatar
Joey Hess committed
		<> cmdinfomod c
	mkparser c = (,,) 
Joey Hess's avatar
Joey Hess committed
		<*> parserGlobalOptions (cmdglobaloptions c)
	synopsis n d = n ++ " - " ++ d
	intro = mconcat $ concatMap (\l -> [H.text l, H.line])
		(synopsis progname progdesc : commandList allcmds)
Joey Hess's avatar
Joey Hess committed
{- Selects the Command that matches the subcommand name.
Joey Hess's avatar
Joey Hess committed
 - Does fuzzy matching if necessary, which may result in multiple Commands. -}
Joey Hess's avatar
Joey Hess committed
selectCmd :: Bool -> [Command] -> Maybe String -> (Bool, [Command])
selectCmd fuzzyok cmds (Just n)
Joey Hess's avatar
Joey Hess committed
	| 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
Joey Hess's avatar
Joey Hess committed
selectCmd _ _ Nothing = (False, [])
Joey Hess's avatar
Joey Hess committed

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

prepRunCommand :: Command -> GlobalSetter -> Annex ()
prepRunCommand cmd globalconfig = do
	when (cmdnomessages cmd) $
		Annex.setOutput QuietOutput
	getParsed globalconfig
	whenM (annexDebug <$> Annex.getGitConfig) $
		liftIO enableDebugOutput
Joey Hess's avatar
Joey Hess committed

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 = return [] -- TODO

mkAddonCommand :: FilePath -> String -> Command
mkAddonCommand p subcommandname = Command
	{ cmdcheck = []
	, cmdnocommit = True
	, cmdnomessages = True
	, cmdname = subcommandname
	, cmdparamdesc = "[PARAMS]"
	, cmdsection = SectionAddOn
	, cmddesc = "addon command"
	, cmdglobaloptions = []
	, 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