addon commands

Seems only fair, that, like git runs git-annex, git-annex runs
git-annex-foo.

Implementation relies on O.forwardOptions, so that any options are passed
through to the addon program. Note that this includes options before the
subcommand, eg: git-annex -cx=y foo

Unfortunately, git-annex eats the --help/-h options.
This is because it uses O.hsubparser, which injects that option into each
subcommand. Seems like this should be possible to avoid somehow, to let
commands display their own --help, instead of the dummy one git-annex
displays.

The two step searching mirrors how git works, it makes finding
git-annex-foo fast when "git annex foo" is run, but will also support fuzzy
matching, once findAllAddonCommands gets implemented.

This commit was sponsored by Dr. Land Raider on Patreon.

CHANGELOG

@@ -1,5 +1,7 @@
 git-annex (8.20210128) UNRELEASED; urgency=medium
 
+  * Commands can be added to git-annex, by installing a program in PATH
+    with a name starting with "git-annex-"
   * Fix a reversion that made import of a tree from a special remote
     result in a merge that deleted files that were not preferred content
     of that special remote.

CmdLine.hs

@@ -1,6 +1,6 @@
 {- git-annex command line parsing and dispatch
  -
- - Copyright 2010-2015 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -15,6 +15,8 @@ module CmdLine (
 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
@@ -26,9 +28,26 @@ import Annex.Environment
 import Command
 import Types.Messages
 
-{- Runs the passed command line. -}
+{- Parses input arguments, finds a matching Command, and runs it. -}
-dispatch :: Bool -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
+dispatch :: Bool -> Bool -> CmdParams -> [Command] -> [(String, String)] -> IO Git.Repo -> String -> String -> IO ()
-dispatch fuzzyok allargs allcmds fields getgitrepo progname progdesc = do
+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
 	setupConsole
 	go =<< tryNonAsync getgitrepo
   where
@@ -70,19 +89,16 @@ dispatch fuzzyok allargs allcmds fields getgitrepo progname progdesc = do
 				handleresult (parseCmd progname progdesc correctedargs allcmds getparser)
 			res -> handleresult res
 	  where
-		autocorrect = Git.AutoCorrect.prepare (fromJust inputcmdname) cmdname cmds
+		autocorrect = Git.AutoCorrect.prepare (fromJust subcommandname) cmdname cmds
 		name
 			| fuzzy = case cmds of
 				(c:_) -> Just (cmdname c)
-				_ -> inputcmdname
+				_ -> subcommandname
-			| otherwise = inputcmdname
+			| otherwise = subcommandname
 		correctedargs = case name of
 			Nothing -> allargs
 			Just n -> n:args
 
-	(inputcmdname, args) = findCmdName allargs
-	(fuzzy, cmds) = findCmd fuzzyok allcmds inputcmdname
-
 {- 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 = 
@@ -93,29 +109,30 @@ parseCmd progname progdesc allargs allcmds getparser =
 	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
-		<*> combineGlobalOptions (cmdglobaloptions c)
+		<*> parserGlobalOptions (cmdglobaloptions c)
 	synopsis n d = n ++ " - " ++ d
 	intro = mconcat $ concatMap (\l -> [H.text l, H.line])
 		(synopsis progname progdesc : commandList allcmds)
 
-{- Finds the Command that matches the subcommand name.
+{- Selects the Command that matches the subcommand name.
  - Does fuzzy matching if necessary, which may result in multiple Commands. -}
-findCmd :: Bool -> [Command] -> Maybe String -> (Bool, [Command])
+selectCmd :: Bool -> [Command] -> Maybe String -> (Bool, [Command])
-findCmd fuzzyok cmds (Just n)
+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
-findCmd _ _ Nothing = (False, [])
+selectCmd _ _ Nothing = (False, [])
 
 {- Parses command line params far enough to find the subcommand name. -}
-findCmdName :: CmdParams -> (Maybe String, CmdParams)
+subCmdName :: CmdParams -> (Maybe String, CmdParams)
-findCmdName argv = (name, args)
+subCmdName argv = (name, args)
   where
 	(name, args) = findname argv []
 	findname [] c = (Nothing, reverse c)
@@ -130,3 +147,36 @@ prepRunCommand cmd globalconfig = do
 	getParsed globalconfig
 	whenM (annexDebug <$> Annex.getGitConfig) $
 		liftIO 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 = 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

CmdLine/GitAnnex.hs

@@ -243,7 +243,7 @@ addGitAnnexGlobalOptions c = c { cmdglobaloptions = gitAnnexGlobalOptions ++ cmd
 run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO ()
 run testoptparser testrunner mkbenchmarkgenerator args = go envmodes
   where
-	go [] = dispatch True args 
+	go [] = dispatch True True args 
 		(cmds testoptparser testrunner mkbenchmarkgenerator)
 		[] Git.CurrentRepo.get
 		"git-annex"

CmdLine/GitAnnexShell.hs

@@ -122,7 +122,7 @@ builtin cmd dir params = do
 	let (params', fieldparams, opts) = partitionParams params
 	    rsyncopts = ("RsyncOptions", unwords opts)
 	    fields = rsyncopts : filter checkField (parseFields fieldparams)
-	dispatch False (cmd : params') cmdsList fields mkrepo
+	dispatch False False (cmd : params') cmdsList fields mkrepo
 		"git-annex-shell"
 		"Restricted login shell for git-annex only SSH access"
   where

CmdLine/GlobalSetter.hs

@@ -1,6 +1,6 @@
 {- git-annex global options
  -
- - Copyright 2015 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
   -}
@@ -19,6 +19,7 @@ globalFlag setter = flag' (DeferredParse setter)
 globalSetter :: (v -> Annex ()) -> Parser v -> GlobalOption
 globalSetter setter parser = DeferredParse . setter <$> parser
 
-combineGlobalOptions :: [GlobalOption] -> Parser GlobalSetter
+parserGlobalOptions :: [GlobalOption] -> Parser GlobalSetter
-combineGlobalOptions l = DeferredParse . mapM_ getParsed
+parserGlobalOptions [] = DeferredParse <$> pure noop
+parserGlobalOptions l = DeferredParse . mapM_ getParsed
 	<$> many (foldl1 (<|>) l)

Command.hs

@@ -33,7 +33,7 @@ import Types.WorkerPool as ReExported
 command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command
 command name section desc paramdesc mkparser =
 	Command commonChecks False False name paramdesc 
-		section desc (mkparser paramdesc) [] Nothing
+		section desc (mkparser paramdesc) mempty [] Nothing
 
 {- Simple option parser that takes all non-option params as-is. -}
 withParams :: (CmdParams -> v) -> CmdParamsDesc -> Parser v

Types/Command.hs

@@ -1,14 +1,17 @@
 {- git-annex command data types
  -
- - Copyright 2010-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE RankNTypes #-}
+
 module Types.Command where
 
 import Data.Ord
 import Options.Applicative.Types (Parser)
+import Options.Applicative.Builder (InfoMod)
 
 import Types
 import Types.DeferredParse
@@ -82,6 +85,8 @@ data Command = Command
 	-- ^ description of command for usage
 	, cmdparser :: CommandParser
 	-- ^ command line parser
+	, cmdinfomod :: forall a. InfoMod a
+	-- ^ command-specific modifier for ParserInfo
 	, cmdglobaloptions :: [GlobalOption]
 	-- ^ additional global options
 	, cmdnorepo :: Maybe (Parser (IO ()))
@@ -115,6 +120,7 @@ data CommandSection
 	| SectionUtility
 	| SectionPlumbing
 	| SectionTesting
+	| SectionAddOn
 	deriving (Eq, Ord, Enum, Bounded)
 
 descSection :: CommandSection -> String
@@ -126,3 +132,4 @@ descSection SectionMetaData = "Metadata commands"
 descSection SectionUtility = "Utility commands"
 descSection SectionPlumbing = "Plumbing commands"
 descSection SectionTesting = "Testing commands"
+descSection SectionAddOn = "Addon commands"

doc/git-annex.mdwn

@@ -741,6 +741,12 @@ content from the key-value store.
   
   See [[git-annex-benchmark]](1) for details.
 
+# ADDON COMMANDS
+
+In addition to all the commands listed above, more commands can be added to
+git-annex by dropping commands named like "git-annex-foo" into a directory
+in the PATH.
+
 # COMMON OPTIONS
 
 These common options are accepted by all git-annex commands, and

doc/todo/allow_git-annex_addon_commands.mdwn

@@ -10,3 +10,5 @@ search the path for all "git-annex-" commands and then
 either dispatch the one matching the inputcmdname,
 or do autocorrect with the list of those commands 
 included along with the builtins. --[[Joey]] 
+
+> [[done]] --[[Joey]]