import Types.TransferrerPool
import Types.VectorClock
import Annex.VectorClock.Utility
+import Annex.Debug.Utility
import qualified Database.Keys.Handle as Keys
import Utility.InodeCache
import Utility.Url
, sshstalecleaned :: TMVar Bool
, signalactions :: TVar (M.Map SignalAction (Int -> IO ()))
, transferrerpool :: TransferrerPool
+ , debugselector :: DebugSelector
}
-newAnnexRead :: IO AnnexRead
-newAnnexRead = do
+newAnnexRead :: GitConfig -> IO AnnexRead
+newAnnexRead c = do
emptyactivekeys <- newTVarIO M.empty
emptyactiveremotes <- newMVar M.empty
kh <- Keys.newDbHandle
, sshstalecleaned = sc
, signalactions = si
, transferrerpool = tp
+ , debugselector = debugSelectorFromGitConfig c
}
-- Values that can change while running an Annex action.
r' <- Git.Config.read r
let c = extractGitConfig FromGitConfig r'
st <- newAnnexState c =<< fixupRepo r' c
- rd <- newAnnexRead
+ rd <- newAnnexRead c
return (st, rd)
{- Performs an action in the Annex monad from a starting state,
--- /dev/null
+{- git-annex debugging
+ -
+ - Copyright 2021 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Annex.Debug (
+ DebugSelector(..),
+ DebugSource(..),
+ debug,
+ fastDebug,
+ configureDebug,
+ debugSelectorFromGitConfig,
+ parseDebugSelector,
+) where
+
+import Common
+import qualified Annex
+import Utility.Debug hiding (fastDebug)
+import qualified Utility.Debug
+import Annex.Debug.Utility
+
+-- | This is faster than using debug, because the DebugSelector
+-- is read from the Annex monad, which avoids any IORef access overhead
+-- when debugging is not enabled.
+fastDebug :: DebugSource -> String -> Annex.Annex ()
+fastDebug src msg = do
+ selector <- Annex.getRead Annex.debugselector
+ liftIO $ Utility.Debug.fastDebug selector src msg
--- /dev/null
+{- git-annex debugging, utility functions
+ -
+ - Copyright 2021 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Annex.Debug.Utility (
+ debugSelectorFromGitConfig,
+ parseDebugSelector,
+ DebugSelector,
+) where
+
+import Types.GitConfig
+import Utility.Debug
+import Utility.Split
+import Utility.FileSystemEncoding
+
+import qualified Data.ByteString as S
+
+debugSelectorFromGitConfig :: GitConfig -> DebugSelector
+debugSelectorFromGitConfig =
+ maybe NoDebugSelector parseDebugSelector . annexDebugFilter
+
+parseDebugSelector :: String -> DebugSelector
+parseDebugSelector = DebugSelector . matchDebugSource . splitSelectorNames
+
+splitSelectorNames :: String -> [S.ByteString]
+splitSelectorNames = map encodeBS . splitc ','
+
+matchDebugSource :: [S.ByteString] -> DebugSource -> Bool
+matchDebugSource names (DebugSource s) = any (`S.isInfixOf` s) names
where
go (Right g) = do
g' <- Git.Config.read g
- (cmd, seek, globalconfig) <- parsewith False cmdparser
+ (cmd, seek, globalsetter) <- parsewith False cmdparser
(\a -> a (Just g'))
O.handleParseResult
- state <- Annex.new g'
+ state <- applyAnnexReadSetter globalsetter <$> Annex.new g'
Annex.eval state $ do
checkEnvironment
forM_ fields $ uncurry Annex.setField
- prepRunCommand cmd globalconfig
+ prepRunCommand cmd globalsetter
startup
performCommandAction cmd seek $
shutdown $ cmdnocommit cmd
| "-" `isPrefixOf` a = findname as (a:c)
| otherwise = (Just a, reverse c ++ as)
+-- | Note that the GlobalSetter must have already had its annexReadSetter
+-- applied before entering the Annex monad; that cannot be changed while
+-- running in the Annex monad.
prepRunCommand :: Command -> GlobalSetter -> Annex ()
-prepRunCommand cmd globalconfig = do
+prepRunCommand cmd globalsetter = do
when (cmdnomessages cmd) $
Annex.setOutput QuietOutput
- getParsed globalconfig
+ annexStateSetter globalsetter
whenM (annexDebug <$> Annex.getGitConfig) $
enableDebugOutput
-- although not always used.
gitAnnexGlobalOptions :: [GlobalOption]
gitAnnexGlobalOptions = commonGlobalOptions ++
- [ globalSetter setnumcopies $ option auto
+ [ globalOption (setAnnexState . setnumcopies) $ option auto
( long "numcopies" <> short 'N' <> metavar paramNumber
<> help "override desired number of copies"
<> hidden
)
- , globalSetter setmincopies $ option auto
+ , globalOption (setAnnexState . setmincopies) $ option auto
( long "mincopies" <> short 'N' <> metavar paramNumber
<> help "override minimum number of copies"
<> hidden
)
- , globalSetter (Remote.forceTrust Trusted) $ strOption
+ , globalOption (setAnnexState . Remote.forceTrust Trusted) $ strOption
( long "trust" <> metavar paramRemote
<> help "deprecated, does not override trust setting"
<> hidden
<> completeRemotes
)
- , globalSetter (Remote.forceTrust SemiTrusted) $ strOption
+ , globalOption (setAnnexState . Remote.forceTrust SemiTrusted) $ strOption
( long "semitrust" <> metavar paramRemote
<> help "override trust setting back to default"
<> hidden
<> completeRemotes
)
- , globalSetter (Remote.forceTrust UnTrusted) $ strOption
+ , globalOption (setAnnexState . Remote.forceTrust UnTrusted) $ strOption
( long "untrust" <> metavar paramRemote
<> help "override trust setting to untrusted"
<> hidden
<> completeRemotes
)
- , globalSetter setgitconfig $ strOption
+ , globalOption (setAnnexState . setgitconfig) $ strOption
( long "config" <> short 'c' <> metavar "NAME=VALUE"
<> help "override git configuration setting"
<> hidden
)
- , globalSetter setuseragent $ strOption
+ , globalOption (setAnnexState . setuseragent) $ strOption
( long "user-agent" <> metavar paramName
<> help "override default User-Agent"
<> hidden
)
- , globalFlag (toplevelWarning False "--trust-glacier no longer has any effect")
+ , globalFlag (setAnnexState $ toplevelWarning False "--trust-glacier no longer has any effect")
( long "trust-glacier"
<> help "deprecated, does not trust Amazon Glacier inventory"
<> hidden
)
- , globalFlag (setdesktopnotify mkNotifyFinish)
+ , globalFlag (setAnnexState $ setdesktopnotify mkNotifyFinish)
( long "notify-finish"
<> help "show desktop notification after transfer finishes"
<> hidden
)
- , globalFlag (setdesktopnotify mkNotifyStart)
+ , globalFlag (setAnnexState $ setdesktopnotify mkNotifyStart)
( long "notify-start"
<> help "show desktop notification after transfer starts"
<> hidden
keyMatchingOptions' :: [GlobalOption]
keyMatchingOptions' =
- [ globalSetter Limit.addIn $ strOption
+ [ globalOption (setAnnexState . Limit.addIn) $ strOption
( long "in" <> short 'i' <> metavar paramRemote
<> help "match files present in a remote"
<> hidden
<> completeRemotes
)
- , globalSetter Limit.addCopies $ strOption
+ , globalOption (setAnnexState . Limit.addCopies) $ strOption
( long "copies" <> short 'C' <> metavar paramRemote
<> help "skip files with fewer copies"
<> hidden
)
- , globalSetter (Limit.addLackingCopies False) $ strOption
+ , globalOption (setAnnexState . Limit.addLackingCopies False) $ strOption
( long "lackingcopies" <> metavar paramNumber
<> help "match files that need more copies"
<> hidden
)
- , globalSetter (Limit.addLackingCopies True) $ strOption
+ , globalOption (setAnnexState . Limit.addLackingCopies True) $ strOption
( long "approxlackingcopies" <> metavar paramNumber
<> help "match files that need more copies (faster)"
<> hidden
)
- , globalSetter Limit.addInBackend $ strOption
+ , globalOption (setAnnexState . Limit.addInBackend) $ strOption
( long "inbackend" <> short 'B' <> metavar paramName
<> help "match files using a key-value backend"
<> hidden
<> completeBackends
)
- , globalFlag Limit.addSecureHash
+ , globalFlag (setAnnexState Limit.addSecureHash)
( long "securehash"
<> help "match files using a cryptographically secure hash"
<> hidden
)
- , globalSetter Limit.addInAllGroup $ strOption
+ , globalOption (setAnnexState . Limit.addInAllGroup) $ strOption
( long "inallgroup" <> metavar paramGroup
<> help "match files present in all remotes in a group"
<> hidden
)
- , globalSetter Limit.addMetaData $ strOption
+ , globalOption (setAnnexState . Limit.addMetaData) $ strOption
( long "metadata" <> metavar "FIELD=VALUE"
<> help "match files with attached metadata"
<> hidden
)
- , globalFlag Limit.Wanted.addWantGet
+ , globalFlag (setAnnexState Limit.Wanted.addWantGet)
( long "want-get"
<> help "match files the repository wants to get"
<> hidden
)
- , globalFlag Limit.Wanted.addWantDrop
+ , globalFlag (setAnnexState Limit.Wanted.addWantDrop)
( long "want-drop"
<> help "match files the repository wants to drop"
<> hidden
)
- , globalSetter Limit.addAccessedWithin $ option (eitherReader parseDuration)
- ( long "accessedwithin"
- <> metavar paramTime
- <> help "match files accessed within a time interval"
- <> hidden
- )
- , globalSetter Limit.addMimeType $ strOption
+ , globalOption (setAnnexState . Limit.addAccessedWithin) $
+ option (eitherReader parseDuration)
+ ( long "accessedwithin"
+ <> metavar paramTime
+ <> help "match files accessed within a time interval"
+ <> hidden
+ )
+ , globalOption (setAnnexState . Limit.addMimeType) $ strOption
( long "mimetype" <> metavar paramGlob
<> help "match files by mime type"
<> hidden
)
- , globalSetter Limit.addMimeEncoding $ strOption
+ , globalOption (setAnnexState . Limit.addMimeEncoding) $ strOption
( long "mimeencoding" <> metavar paramGlob
<> help "match files by mime encoding"
<> hidden
)
- , globalFlag Limit.addUnlocked
+ , globalFlag (setAnnexState Limit.addUnlocked)
( long "unlocked"
<> help "match files that are unlocked"
<> hidden
)
- , globalFlag Limit.addLocked
+ , globalFlag (setAnnexState Limit.addLocked)
( long "locked"
<> help "match files that are locked"
<> hidden
fileMatchingOptions' :: Limit.LimitBy -> [GlobalOption]
fileMatchingOptions' lb =
- [ globalSetter Limit.addExclude $ strOption
+ [ globalOption (setAnnexState . Limit.addExclude) $ strOption
( long "exclude" <> short 'x' <> metavar paramGlob
<> help "skip files matching the glob pattern"
<> hidden
)
- , globalSetter Limit.addInclude $ strOption
+ , globalOption (setAnnexState . Limit.addInclude) $ strOption
( long "include" <> short 'I' <> metavar paramGlob
<> help "limit to files matching the glob pattern"
<> hidden
)
- , globalSetter (Limit.addLargerThan lb) $ strOption
+ , globalOption (setAnnexState . Limit.addLargerThan lb) $ strOption
( long "largerthan" <> metavar paramSize
<> help "match files larger than a size"
<> hidden
)
- , globalSetter (Limit.addSmallerThan lb) $ strOption
+ , globalOption (setAnnexState . Limit.addSmallerThan lb) $ strOption
( long "smallerthan" <> metavar paramSize
<> help "match files smaller than a size"
<> hidden
, shortopt ')' "close group of options"
]
where
- longopt o h = globalFlag (Limit.addSyntaxToken o) ( long o <> help h <> hidden )
- shortopt o h = globalFlag (Limit.addSyntaxToken [o]) ( short o <> help h <> hidden )
+ longopt o h = globalFlag (setAnnexState $ Limit.addSyntaxToken o)
+ ( long o <> help h <> hidden )
+ shortopt o h = globalFlag (setAnnexState $ Limit.addSyntaxToken [o])
+ ( short o <> help h <> hidden )
jsonOptions :: [GlobalOption]
jsonOptions =
- [ globalFlag (Annex.setOutput (JSONOutput stdjsonoptions))
+ [ globalFlag (setAnnexState $ Annex.setOutput (JSONOutput stdjsonoptions))
( long "json" <> short 'j'
<> help "enable JSON output"
<> hidden
)
- , globalFlag (Annex.setOutput (JSONOutput jsonerrormessagesoptions))
+ , globalFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonerrormessagesoptions))
( long "json-error-messages"
<> help "include error messages in JSON"
<> hidden
jsonProgressOption :: [GlobalOption]
jsonProgressOption =
- [ globalFlag (Annex.setOutput (JSONOutput jsonoptions))
+ [ globalFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonoptions))
( long "json-progress"
<> help "include progress in JSON output"
<> hidden
-- action in `allowConcurrentOutput`.
jobsOption :: [GlobalOption]
jobsOption =
- [ globalSetter (setConcurrency . ConcurrencyCmdLine) $
+ [ globalOption (setAnnexState . setConcurrency . ConcurrencyCmdLine) $
option (maybeReader parseConcurrency)
( long "jobs" <> short 'J'
<> metavar (paramNumber `paramOr` "cpus")
timeLimitOption :: [GlobalOption]
timeLimitOption =
- [ globalSetter settimelimit $ option (eitherReader parseDuration)
+ [ globalOption settimelimit $ option (eitherReader parseDuration)
( long "time-limit" <> short 'T' <> metavar paramTime
<> help "stop after the specified amount of time"
<> hidden
)
]
where
- settimelimit duration = do
+ settimelimit duration = setAnnexState $ do
start <- liftIO getPOSIXTime
let cutoff = start + durationToPOSIXTime duration
Annex.changeState $ \s -> s { Annex.timelimit = Just (duration, cutoff) }
globalOptions :: [GlobalOption]
globalOptions =
- globalSetter checkUUID (strOption
+ globalOption (setAnnexState . checkUUID) (strOption
( long "uuid" <> metavar paramUUID
<> help "local repository uuid"
))
module CmdLine.GlobalSetter where
-import Types.DeferredParse
import Common
import Annex
+import Types.DeferredParse
import Options.Applicative
-globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> GlobalOption
-globalFlag setter = flag' (DeferredParse setter)
+setAnnexState :: Annex () -> GlobalSetter
+setAnnexState a = GlobalSetter a id
+
+setAnnexRead :: (AnnexRead -> AnnexRead) -> GlobalSetter
+setAnnexRead f = GlobalSetter (return ()) f
-globalSetter :: (v -> Annex ()) -> Parser v -> GlobalOption
-globalSetter setter parser = DeferredParse . setter <$> parser
+globalFlag :: GlobalSetter -> Mod FlagFields GlobalSetter -> GlobalOption
+globalFlag = flag'
+globalOption :: (v -> GlobalSetter) -> Parser v -> GlobalOption
+globalOption mk parser = mk <$> parser
+
+-- | Combines a bunch of GlobalOptions together into a Parser
+-- that returns a GlobalSetter that can be used to set all the options that
+-- are enabled.
parserGlobalOptions :: [GlobalOption] -> Parser GlobalSetter
-parserGlobalOptions [] = DeferredParse <$> pure noop
-parserGlobalOptions l = DeferredParse . mapM_ getParsed
- <$> many (foldl1 (<|>) l)
+parserGlobalOptions [] = pure mempty
+parserGlobalOptions l = mconcat <$> many (foldl1 (<|>) l)
+
+applyAnnexReadSetter :: GlobalSetter -> (AnnexState, AnnexRead) -> (AnnexState, AnnexRead)
+applyAnnexReadSetter gs (st, rd) = (st, annexReadSetter gs rd)
import Git.Types (ConfigKey(..))
import Git.Config
import Utility.FileSystemEncoding
+import Annex.Debug
-- Global options accepted by both git-annex and git-annex-shell sub-commands.
commonGlobalOptions :: [GlobalOption]
commonGlobalOptions =
- [ globalFlag (setforce True)
+ [ globalFlag (setAnnexState $ setforce True)
( long "force"
<> help "allow actions that may lose annexed data"
<> hidden
)
- , globalFlag (setfast True)
+ , globalFlag (setAnnexState $ setfast True)
( long "fast" <> short 'F'
<> help "avoid slow operations"
<> hidden
)
- , globalFlag (Annex.setOutput QuietOutput)
+ , globalFlag (setAnnexState $ Annex.setOutput QuietOutput)
( long "quiet" <> short 'q'
<> help "avoid verbose output"
<> hidden
)
- , globalFlag (Annex.setOutput NormalOutput)
+ , globalFlag (setAnnexState $ Annex.setOutput NormalOutput)
( long "verbose" <> short 'v'
<> help "allow verbose output (default)"
<> hidden
)
- , globalFlag (setdebug True)
+ , globalFlag (setAnnexState $ setdebug True)
( long "debug" <> short 'd'
<> help "show debug messages"
<> hidden
)
- , globalFlag (setdebug False)
+ , globalFlag (setAnnexState $ setdebug False)
( long "no-debug"
<> help "don't show debug messages"
<> hidden
)
- , globalSetter setdebugfilter $ strOption
+ , globalOption setdebugfilter $ strOption
( long "debugfilter" <> metavar "NAME[,NAME..]"
<> help "show debug messages coming from a module"
<> hidden
)
- , globalSetter setforcebackend $ strOption
+ , globalOption setforcebackend $ strOption
( long "backend" <> short 'b' <> metavar paramName
<> help "specify key-value backend to use"
<> hidden
]
where
setforce v = Annex.changeState $ \s -> s { Annex.force = v }
+
setfast v = Annex.changeState $ \s -> s { Annex.fast = v }
- setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
+
+ setforcebackend v = setAnnexState $
+ Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
+
-- Overriding this way, rather than just setting annexDebug
-- makes the config be passed on to any git-annex child processes.
setdebug v = Annex.addGitConfigOverride $
decodeBS' $ debugconfig <> "=" <> boolConfig' v
- setdebugfilter v = Annex.addGitConfigOverride $
- decodeBS' (debugfilterconfig <> "=") ++ v
+
+ setdebugfilter v = mconcat
+ [ setAnnexRead $ \rd -> rd
+ { Annex.debugselector = parseDebugSelector v
+ }
+ -- Also set in git config so it will be passed on to any
+ -- git-annex child processes.
+ , setAnnexState $ Annex.addGitConfigOverride $
+ decodeBS' (debugfilterconfig <> "=") ++ v
+ ]
+
(ConfigKey debugconfig) = annexConfig "debug"
(ConfigKey debugfilterconfig) = annexConfig "debugfilter"
import Types.Transfer (transferKey)
import Messages.Internal
import Messages.Concurrent
-import Utility.Debug
+import Annex.Debug
import Annex.Concurrent.Utility
import qualified Messages.JSON as JSON
import qualified Annex
setupConsole :: IO ()
setupConsole = do
dd <- debugDisplayer
- configureDebug dd mempty
+ configureDebug dd (DebugSelector (const False))
{- Force output to be line buffered. This is normally the case when
- it's connected to a terminal, but may not be when redirected to
- a file or a pipe. -}
enableDebugOutput :: Annex ()
enableDebugOutput = do
- names <- map encodeBS . annexDebugFilter <$> Annex.getGitConfig
- let selector
- | null names = const True
- | otherwise = \(DebugSource s) -> any (`S.isInfixOf` s) names
+ selector <- Annex.getRead Annex.debugselector
dd <- liftIO debugDisplayer
- liftIO $ configureDebug dd (DebugSelector selector)
+ liftIO $ configureDebug dd selector
disableDebugOutput :: Annex ()
disableDebugOutput = liftIO $ do
dd <- debugDisplayer
- configureDebug dd mempty
+ configureDebug dd (DebugSelector (const False))
debugDisplayer :: IO (S.ByteString -> IO ())
debugDisplayer = do
{- git-annex deferred parse values
-
- - Copyright 2015 Joey Hess <id@joeyh.name>
+ - Copyright 2015-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
import Annex
import Options.Applicative
+import qualified Data.Semigroup as Sem
+import Prelude
-- Some values cannot be fully parsed without performing an action.
-- The action may be expensive, so it's best to call finishParse on such a
instance DeferredParseClass [DeferredParse a] where
finishParse v = mapM finishParse v
--- Use when the Annex action modifies Annex state.
-type GlobalSetter = DeferredParse ()
type GlobalOption = Parser GlobalSetter
+
+-- Used for global options that can modify Annex state by running
+-- an arbitrary action in it, and can also set up AnnexRead.
+data GlobalSetter = GlobalSetter
+ { annexStateSetter :: Annex ()
+ , annexReadSetter :: AnnexRead -> AnnexRead
+ }
+
+instance Sem.Semigroup GlobalSetter where
+ a <> b = GlobalSetter
+ { annexStateSetter = annexStateSetter a >> annexStateSetter b
+ , annexReadSetter = annexReadSetter b . annexReadSetter a
+ }
+
+instance Monoid GlobalSetter where
+ mempty = GlobalSetter (return ()) id
, annexSyncContent :: GlobalConfigurable Bool
, annexSyncOnlyAnnex :: GlobalConfigurable Bool
, annexDebug :: Bool
- , annexDebugFilter :: [String]
+ , annexDebugFilter :: Maybe String
, annexWebOptions :: [String]
, annexYoutubeDlOptions :: [String]
, annexAriaTorrentOptions :: [String]
, annexSyncOnlyAnnex = configurable False $
getmaybebool (annexConfig "synconlyannex")
, annexDebug = getbool (annexConfig "debug") False
- , annexDebugFilter = maybe [] (splitc ',') $
- getmaybe (annexConfig "debugfilter")
+ , annexDebugFilter = getmaybe (annexConfig "debugfilter")
, annexWebOptions = getwords (annexConfig "web-options")
, annexYoutubeDlOptions = getwords (annexConfig "youtube-dl-options")
, annexAriaTorrentOptions = getwords (annexConfig "aria-torrent-options")
Annex.Content.LowLevel
Annex.Content.PointerFile
Annex.CurrentBranch
+ Annex.Debug
+ Annex.Debug.Utility
Annex.Difference
Annex.DirHashes
Annex.Drop
projects / git-annex.git / commitdiff