git-annex/CmdLine.hs

201 lines
6.7 KiB
Haskell
Raw Normal View History

{- 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
remove dead nodes when loading the cluster log This is to avoid inserting a cluster uuid into the location log when only dead nodes in the cluster contain the content of a key. One reason why this is necessary is Remote.keyLocations, which excludes dead repositories from the list. But there are probably many more. Implementing this was challenging, because Logs.Location importing Logs.Cluster which imports Logs.Trust which imports Remote.List resulted in an import cycle through several other modules. Resorted to making Logs.Location not import Logs.Cluster, and instead it assumes that Annex.clusters gets populated when necessary before it's called. That's done in Annex.Startup, which is run by the git-annex command (but not other commands) at early startup in initialized repos. Or, is run after initialization. Note that is Remote.Git, it is unable to import Annex.Startup, because Remote.Git importing Logs.Cluster leads the the same import cycle. So ensureInitialized is not passed annexStartup in there. Other commands, like git-annex-shell currently don't run annexStartup either. So there are cases where Logs.Location will not see clusters. So it won't add any cluster UUIDs when loading the log. That's ok, the only reason to do that is to make display of where objects are located include clusters, and to make commands like git-annex get --from treat keys as being located in a cluster. git-annex-shell certainly does not do anything like that, and I'm pretty sure Remote.Git (and callers to Remote.Git.onLocalRepo) don't either.
2024-06-16 18:35:07 +00:00
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 = do
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 $
avoid flushing keys db queue after each Annex action The flush was only done Annex.run' to make sure that the queue was flushed before git-annex exits. But, doing it there means that as soon as one change gets queued, it gets flushed soon after, which contributes to excessive writes to the database, slowing git-annex down. (This does not yet speed git-annex up, but it is a stepping stone to doing so.) Database queues do not autoflush when garbage collected, so have to be flushed explicitly. I don't think it's possible to make them autoflush (except perhaps if git-annex sqitched to using ResourceT..). The comment in Database.Keys.closeDb used to be accurate, since the automatic flushing did mean that all writes reached the database even when closeDb was not called. But now, closeDb or flushDb needs to be called before stopping using an Annex state. So, removed that comment. In Remote.Git, change to using quiesce everywhere that it used to use stopCoProcesses. This means that uses on onLocal in there are just as slow as before. I considered only calling closeDb on the local git remotes when git-annex exits. But, the reason that Remote.Git calls stopCoProcesses in each onLocal is so as not to leave git processes running that have files open on the remote repo, when it's on removable media. So, it seemed to make sense to also closeDb after each one, since sqlite may also keep files open. Although that has not seemed to cause problems with removable media so far. It was also just easier to quiesce in each onLocal than once at the end. This does likely leave performance on the floor, so could be revisited. In Annex.Content.saveState, there was no reason to close the db, flushing it is enough. The rest of the changes are from auditing for Annex.new, and making sure that quiesce is called, after any action that might possibly need it. After that audit, I'm pretty sure that the change to Annex.run' is safe. The only concern might be that this does let more changes get queued for write to the db, and if git-annex is interrupted, those will be lost. But interrupting git-annex can obviously already prevent it from writing the most recent change to the db, so it must recover from such lost data... right? Sponsored-by: Dartmouth College's Datalad project
2022-10-12 17:50:46 +00:00
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)
2010-12-30 19:44:15 +00:00
{- 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)
2021-02-02 18:27:42 +00:00
| 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, [])
2021-02-02 18:27:42 +00:00
{- Parses command line params far enough to find the subcommand name. -}
subCmdName :: CmdParams -> (Maybe String, CmdParams)
subCmdName argv = (name, args)
2012-11-11 04:51:07 +00:00
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