Skip to content
Snippets Groups Projects
CmdLine.hs 6.68 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
			Just c -> go addonok (c:allcmds) noop
			Nothing -> go addonok allcmds $
Joey Hess's avatar
Joey Hess committed
				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
Joey Hess's avatar
Joey Hess committed
		g' <- Git.Config.read g
		(cmd, seek, annexsetter) <- parsewith False cmdparser
Joey Hess's avatar
Joey Hess committed
			(\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
Joey Hess's avatar
Joey Hess committed
			performCommandAction True cmd seek $
				quiesce $ 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, AnnexSetter)
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 = (,,) 
		<*> parserAnnexOptions (cmdannexoptions c)
	intro = mconcat $ concatMap (\l -> [H.pretty 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)
-- | 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) $
	annexStateSetter annexsetter
	whenM (Annex.getRead Annex.debugenabled) $
		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 = 
	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
Joey Hess's avatar
Joey Hess committed

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