git-annex/Types/GitConfig.hs

474 lines
18 KiB
Haskell
Raw Normal View History

{- git-annex configuration
-
- Copyright 2012-2021 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Types.GitConfig (
2020-09-16 15:16:48 +00:00
GlobalConfigurable(..),
ConfigSource(..),
GitConfig(..),
extractGitConfig,
mergeGitConfig,
globalConfigs,
RemoteGitConfig(..),
extractRemoteGitConfig,
dummyRemoteGitConfig,
annexConfig,
RemoteNameable(..),
remoteAnnexConfig,
remoteConfig,
) where
import Common
import qualified Git
import qualified Git.Config
import qualified Git.Construct
import Git.Types
import Git.ConfigTypes
import Git.Remote (isRemoteKey, remoteKeyToRemoteName)
import Git.Branch (CommitMode(..))
import Utility.DataUnits
import Config.Cost
import Types.UUID
2013-11-22 20:04:20 +00:00
import Types.Distribution
import Types.Availability
import Types.Concurrency
import Types.NumCopies
import Types.Difference
2015-05-14 19:44:08 +00:00
import Types.RefSpec
import Types.RepoVersion
import Types.StallDetection
import Config.DynamicConfig
import Utility.HumanTime
import Utility.Gpg (GpgCmd, mkGpgCmd)
import Utility.ThreadScheduler (Seconds(..))
limit url downloads to whitelisted schemes Security fix! Allowing any schemes, particularly file: and possibly others like scp: allowed file exfiltration by anyone who had write access to the git repository, since they could add an annexed file using such an url, or using an url that redirected to such an url, and wait for the victim to get it into their repository and send them a copy. * Added annex.security.allowed-url-schemes setting, which defaults to only allowing http and https URLs. Note especially that file:/ is no longer enabled by default. * Removed annex.web-download-command, since its interface does not allow supporting annex.security.allowed-url-schemes across redirects. If you used this setting, you may want to instead use annex.web-options to pass options to curl. With annex.web-download-command removed, nearly all url accesses in git-annex are made via Utility.Url via http-client or curl. http-client only supports http and https, so no problem there. (Disabling one and not the other is not implemented.) Used curl --proto to limit the allowed url schemes. Note that this will cause git annex fsck --from web to mark files using a disallowed url scheme as not being present in the web. That seems acceptable; fsck --from web also does that when a web server is not available. youtube-dl already disabled file: itself (probably for similar reasons). The scheme check was also added to youtube-dl urls for completeness, although that check won't catch any redirects it might follow. But youtube-dl goes off and does its own thing with other protocols anyway, so that's fine. Special remotes that support other domain-specific url schemes are not affected by this change. In the bittorrent remote, aria2c can still download magnet: links. The download of the .torrent file is otherwise now limited by annex.security.allowed-url-schemes. This does not address any external special remotes that might download an url themselves. Current thinking is all external special remotes will need to be audited for this problem, although many of them will use http libraries that only support http and not curl's menagarie. The related problem of accessing private localhost and LAN urls is not addressed by this commit. This commit was sponsored by Brett Eisenberg on Patreon.
2018-06-15 20:52:24 +00:00
import Utility.Url (Scheme, mkScheme)
import Control.Concurrent.STM
limit url downloads to whitelisted schemes Security fix! Allowing any schemes, particularly file: and possibly others like scp: allowed file exfiltration by anyone who had write access to the git repository, since they could add an annexed file using such an url, or using an url that redirected to such an url, and wait for the victim to get it into their repository and send them a copy. * Added annex.security.allowed-url-schemes setting, which defaults to only allowing http and https URLs. Note especially that file:/ is no longer enabled by default. * Removed annex.web-download-command, since its interface does not allow supporting annex.security.allowed-url-schemes across redirects. If you used this setting, you may want to instead use annex.web-options to pass options to curl. With annex.web-download-command removed, nearly all url accesses in git-annex are made via Utility.Url via http-client or curl. http-client only supports http and https, so no problem there. (Disabling one and not the other is not implemented.) Used curl --proto to limit the allowed url schemes. Note that this will cause git annex fsck --from web to mark files using a disallowed url scheme as not being present in the web. That seems acceptable; fsck --from web also does that when a web server is not available. youtube-dl already disabled file: itself (probably for similar reasons). The scheme check was also added to youtube-dl urls for completeness, although that check won't catch any redirects it might follow. But youtube-dl goes off and does its own thing with other protocols anyway, so that's fine. Special remotes that support other domain-specific url schemes are not affected by this change. In the bittorrent remote, aria2c can still download magnet: links. The download of the .torrent file is otherwise now limited by annex.security.allowed-url-schemes. This does not address any external special remotes that might download an url themselves. Current thinking is all external special remotes will need to be audited for this problem, although many of them will use http libraries that only support http and not curl's menagarie. The related problem of accessing private localhost and LAN urls is not addressed by this commit. This commit was sponsored by Brett Eisenberg on Patreon.
2018-06-15 20:52:24 +00:00
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.ByteString as B
-- | A configurable value, that may not be fully determined yet because
-- the global git config has not yet been loaded.
2020-09-16 15:16:48 +00:00
data GlobalConfigurable a
= HasGitConfig a
-- ^ The git config has a value.
| HasGlobalConfig a
-- ^ The global config has a value (and the git config does not).
| DefaultConfig a
-- ^ A default value is known, but not all config sources
-- have been read yet.
deriving (Show)
data ConfigSource = FromGitConfig | FromGlobalConfig
{- Main git-annex settings. Each setting corresponds to a git-config key
- such as annex.foo -}
data GitConfig = GitConfig
{ annexVersion :: Maybe RepoVersion
, annexUUID :: UUID
, annexNumCopies :: Maybe NumCopies
, annexDiskReserve :: Integer
, annexDirect :: Bool
, annexBackend :: Maybe String
, annexQueueSize :: Maybe Int
, annexBloomCapacity :: Maybe Int
, annexBloomAccuracy :: Maybe Int
, annexSshCaching :: Maybe Bool
, annexAlwaysCommit :: Bool
, annexCommitMessage :: Maybe String
, annexMergeAnnexBranches :: Bool
, annexDelayAdd :: Maybe Int
, annexHttpHeaders :: [String]
, annexHttpHeadersCommand :: Maybe String
2020-09-16 15:16:48 +00:00
, annexAutoCommit :: GlobalConfigurable Bool
, annexResolveMerge :: GlobalConfigurable Bool
, annexSyncContent :: GlobalConfigurable Bool
, annexSyncOnlyAnnex :: GlobalConfigurable Bool
, annexDebug :: Bool
, annexDebugFilter :: Maybe String
2013-01-27 13:33:19 +00:00
, annexWebOptions :: [String]
, annexYoutubeDlOptions :: [String]
, annexAriaTorrentOptions :: [String]
, annexCrippledFileSystem :: Bool
2020-09-16 15:16:48 +00:00
, annexLargeFiles :: GlobalConfigurable (Maybe String)
, annexDotFiles :: GlobalConfigurable Bool
, annexGitAddToAnnex :: Bool
, annexAddSmallFiles :: Bool
, annexFsckNudge :: Bool
2013-11-22 20:04:20 +00:00
, annexAutoUpgrade :: AutoUpgrade
, annexExpireUnused :: Maybe (Maybe Duration)
, annexSecureEraseCommand :: Maybe String
, annexGenMetaData :: Bool
, annexListen :: Maybe String
, annexStartupScan :: Bool
, annexHardLink :: Bool
, annexThin :: Bool
, annexDifferences :: Differences
, annexUsedRefSpec :: Maybe RefSpec
, annexVerify :: Bool
, annexPidLock :: Bool
, annexPidLockTimeout :: Seconds
2020-09-16 15:16:48 +00:00
, annexAddUnlocked :: GlobalConfigurable (Maybe String)
annex.securehashesonly Cryptographically secure hashes can be forced to be used in a repository, by setting annex.securehashesonly. This does not prevent the git repository from containing files with insecure hashes, but it does prevent the content of such files from being pulled into .git/annex/objects from another repository. We want to make sure that at no point does git-annex accept content into .git/annex/objects that is hashed with an insecure key. Here's how it was done: * .git/annex/objects/xx/yy/KEY/ is kept frozen, so nothing can be written to it normally * So every place that writes content must call, thawContent or modifyContent. We can audit for these, and be sure we've considered all cases. * The main functions are moveAnnex, and linkToAnnex; these were made to check annex.securehashesonly, and are the main security boundary for annex.securehashesonly. * Most other calls to modifyContent deal with other files in the KEY directory (inode cache etc). The other ones that mess with the content are: - Annex.Direct.toDirectGen, in which content already in the annex directory is moved to the direct mode file, so not relevant. - fix and lock, which don't add new content - Command.ReKey.linkKey, which manually unlocks it to make a copy. * All other calls to thawContent appear safe. Made moveAnnex return a Bool, so checked all callsites and made them deal with a failure in appropriate ways. linkToAnnex simply returns LinkAnnexFailed; all callsites already deal with it failing in appropriate ways. This commit was sponsored by Riku Voipio.
2017-02-27 17:01:32 +00:00
, annexSecureHashesOnly :: Bool
2018-03-24 14:37:25 +00:00
, annexRetry :: Maybe Integer
, annexForwardRetry :: Maybe Integer
2018-03-24 14:37:25 +00:00
, annexRetryDelay :: Maybe Seconds
, annexStallDetection :: Maybe StallDetection
limit url downloads to whitelisted schemes Security fix! Allowing any schemes, particularly file: and possibly others like scp: allowed file exfiltration by anyone who had write access to the git repository, since they could add an annexed file using such an url, or using an url that redirected to such an url, and wait for the victim to get it into their repository and send them a copy. * Added annex.security.allowed-url-schemes setting, which defaults to only allowing http and https URLs. Note especially that file:/ is no longer enabled by default. * Removed annex.web-download-command, since its interface does not allow supporting annex.security.allowed-url-schemes across redirects. If you used this setting, you may want to instead use annex.web-options to pass options to curl. With annex.web-download-command removed, nearly all url accesses in git-annex are made via Utility.Url via http-client or curl. http-client only supports http and https, so no problem there. (Disabling one and not the other is not implemented.) Used curl --proto to limit the allowed url schemes. Note that this will cause git annex fsck --from web to mark files using a disallowed url scheme as not being present in the web. That seems acceptable; fsck --from web also does that when a web server is not available. youtube-dl already disabled file: itself (probably for similar reasons). The scheme check was also added to youtube-dl urls for completeness, although that check won't catch any redirects it might follow. But youtube-dl goes off and does its own thing with other protocols anyway, so that's fine. Special remotes that support other domain-specific url schemes are not affected by this change. In the bittorrent remote, aria2c can still download magnet: links. The download of the .torrent file is otherwise now limited by annex.security.allowed-url-schemes. This does not address any external special remotes that might download an url themselves. Current thinking is all external special remotes will need to be audited for this problem, although many of them will use http libraries that only support http and not curl's menagarie. The related problem of accessing private localhost and LAN urls is not addressed by this commit. This commit was sponsored by Brett Eisenberg on Patreon.
2018-06-15 20:52:24 +00:00
, annexAllowedUrlSchemes :: S.Set Scheme
, annexAllowedIPAddresses :: String
, annexAllowUnverifiedDownloads :: Bool
, annexMaxExtensionLength :: Maybe Int
, annexJobs :: Concurrency
, annexCacheCreds :: Bool
, annexAutoUpgradeRepository :: Bool
, annexCommitMode :: CommitMode
, annexSkipUnknown :: Bool
, annexAdjustedBranchRefresh :: Integer
, annexSupportUnlocked :: Bool
, coreSymlinks :: Bool
, coreSharedRepository :: SharedRepository
, receiveDenyCurrentBranch :: DenyCurrentBranch
, gcryptId :: Maybe String
, gpgCmd :: GpgCmd
, mergeDirectoryRenames :: Maybe String
, annexPrivateRepos :: S.Set UUID
}
extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig
extractGitConfig configsource r = GitConfig
{ annexVersion = RepoVersion <$> getmayberead (annexConfig "version")
, annexUUID = hereuuid
, annexNumCopies = NumCopies <$> getmayberead (annexConfig "numcopies")
, annexDiskReserve = fromMaybe onemegabyte $
readSize dataUnits =<< getmaybe (annexConfig "diskreserve")
, annexDirect = getbool (annexConfig "direct") False
, annexBackend = maybe
-- annex.backends is the old name of the option, still used
-- when annex.backend is not set.
(headMaybe $ getwords (annexConfig "backends"))
Just
(getmaybe (annexConfig "backend"))
, annexQueueSize = getmayberead (annexConfig "queuesize")
, annexBloomCapacity = getmayberead (annexConfig "bloomcapacity")
, annexBloomAccuracy = getmayberead (annexConfig "bloomaccuracy")
, annexSshCaching = getmaybebool (annexConfig "sshcaching")
, annexAlwaysCommit = getbool (annexConfig "alwayscommit") True
, annexCommitMessage = getmaybe (annexConfig "commitmessage")
, annexMergeAnnexBranches = getbool (annexConfig "merge-annex-branches") True
, annexDelayAdd = getmayberead (annexConfig "delayadd")
, annexHttpHeaders = getlist (annexConfig "http-headers")
, annexHttpHeadersCommand = getmaybe (annexConfig "http-headers-command")
, annexAutoCommit = configurable True $
getmaybebool (annexConfig "autocommit")
, annexResolveMerge = configurable True $
getmaybebool (annexConfig "resolvemerge")
, annexSyncContent = configurable False $
getmaybebool (annexConfig "synccontent")
sync --only-annex and annex.synconlyannex * Added sync --only-annex, which syncs the git-annex branch and annexed content but leaves managing the other git branches up to you. * Added annex.synconlyannex git config setting, which can also be set with git-annex config to configure sync in all clones of the repo. Use case is then the user has their own git workflow, and wants to use git-annex without disrupting that, so they sync --only-annex to get the git-annex stuff in sync in addition to their usual git workflow. When annex.synconlyannex is set, --not-only-annex can be used to override it. It's not entirely clear what --only-annex --commit or --only-annex --push should do, and I left that combination not documented because I don't know if I might want to change the current behavior, which is that such options do not override the --only-annex. My gut feeling is that there is no good reasons to use such combinations; if you want to use your own git workflow, you'll be doing your own committing and pulling and pushing. A subtle question is, how should import/export special remotes be handled? Importing updates their remote tracking branch and merges it into master. If --only-annex prevented that git branch stuff, then it would prevent exporting to the special remote, in the case where it has changes that were not imported yet, because there would be a unresolved conflict. I decided that it's best to treat the fact that there's a remote tracking branch for import/export as an implementation detail in this case. The more important thing is that an import/export special remote is entirely annexed content, and so it makes a lot of sense that --only-annex will still sync with it.
2020-02-17 19:19:58 +00:00
, annexSyncOnlyAnnex = configurable False $
getmaybebool (annexConfig "synconlyannex")
, annexDebug = getbool (annexConfig "debug") False
, annexDebugFilter = getmaybe (annexConfig "debugfilter")
, annexWebOptions = getwords (annexConfig "web-options")
, annexYoutubeDlOptions = getwords (annexConfig "youtube-dl-options")
, annexAriaTorrentOptions = getwords (annexConfig "aria-torrent-options")
, annexCrippledFileSystem = getbool (annexConfig "crippledfilesystem") False
, annexLargeFiles = configurable Nothing $
fmap Just $ getmaybe (annexConfig "largefiles")
, annexDotFiles = configurable False $
getmaybebool (annexConfig "dotfiles")
, annexGitAddToAnnex = getbool (annexConfig "gitaddtoannex") True
, annexAddSmallFiles = getbool (annexConfig "addsmallfiles") True
, annexFsckNudge = getbool (annexConfig "fscknudge") True
, annexAutoUpgrade = toAutoUpgrade $
getmaybe (annexConfig "autoupgrade")
, annexExpireUnused = either (const Nothing) Just . parseDuration
<$> getmaybe (annexConfig "expireunused")
, annexSecureEraseCommand = getmaybe (annexConfig "secure-erase-command")
, annexGenMetaData = getbool (annexConfig "genmetadata") False
, annexListen = getmaybe (annexConfig "listen")
, annexStartupScan = getbool (annexConfig "startupscan") True
, annexHardLink = getbool (annexConfig "hardlink") False
, annexThin = getbool (annexConfig "thin") False
, annexDifferences = getDifferences r
2015-05-14 19:44:08 +00:00
, annexUsedRefSpec = either (const Nothing) Just . parseRefSpec
=<< getmaybe (annexConfig "used-refspec")
, annexVerify = getbool (annexConfig "verify") True
, annexPidLock = getbool (annexConfig "pidlock") False
, annexPidLockTimeout = Seconds $ fromMaybe 300 $
getmayberead (annexConfig "pidlocktimeout")
, annexAddUnlocked = configurable Nothing $
fmap Just $ getmaybe (annexConfig "addunlocked")
, annexSecureHashesOnly = getbool (annexConfig "securehashesonly") False
, annexRetry = getmayberead (annexConfig "retry")
, annexForwardRetry = getmayberead (annexConfig "forward-retry")
2018-03-24 14:37:25 +00:00
, annexRetryDelay = Seconds
<$> getmayberead (annexConfig "retrydelay")
, annexStallDetection =
either (const Nothing) id . parseStallDetection
=<< getmaybe (annexConfig "stalldetection")
limit url downloads to whitelisted schemes Security fix! Allowing any schemes, particularly file: and possibly others like scp: allowed file exfiltration by anyone who had write access to the git repository, since they could add an annexed file using such an url, or using an url that redirected to such an url, and wait for the victim to get it into their repository and send them a copy. * Added annex.security.allowed-url-schemes setting, which defaults to only allowing http and https URLs. Note especially that file:/ is no longer enabled by default. * Removed annex.web-download-command, since its interface does not allow supporting annex.security.allowed-url-schemes across redirects. If you used this setting, you may want to instead use annex.web-options to pass options to curl. With annex.web-download-command removed, nearly all url accesses in git-annex are made via Utility.Url via http-client or curl. http-client only supports http and https, so no problem there. (Disabling one and not the other is not implemented.) Used curl --proto to limit the allowed url schemes. Note that this will cause git annex fsck --from web to mark files using a disallowed url scheme as not being present in the web. That seems acceptable; fsck --from web also does that when a web server is not available. youtube-dl already disabled file: itself (probably for similar reasons). The scheme check was also added to youtube-dl urls for completeness, although that check won't catch any redirects it might follow. But youtube-dl goes off and does its own thing with other protocols anyway, so that's fine. Special remotes that support other domain-specific url schemes are not affected by this change. In the bittorrent remote, aria2c can still download magnet: links. The download of the .torrent file is otherwise now limited by annex.security.allowed-url-schemes. This does not address any external special remotes that might download an url themselves. Current thinking is all external special remotes will need to be audited for this problem, although many of them will use http libraries that only support http and not curl's menagarie. The related problem of accessing private localhost and LAN urls is not addressed by this commit. This commit was sponsored by Brett Eisenberg on Patreon.
2018-06-15 20:52:24 +00:00
, annexAllowedUrlSchemes = S.fromList $ map mkScheme $
maybe ["http", "https", "ftp"] words $
getmaybe (annexConfig "security.allowed-url-schemes")
, annexAllowedIPAddresses = fromMaybe "" $
getmaybe (annexConfig "security.allowed-ip-addresses")
<|>
getmaybe (annexConfig "security.allowed-http-addresses") -- old name
, annexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $
getmaybe (annexConfig "security.allow-unverified-downloads")
, annexMaxExtensionLength = getmayberead (annexConfig "maxextensionlength")
, annexJobs = fromMaybe NonConcurrent $
parseConcurrency =<< getmaybe (annexConfig "jobs")
, annexCacheCreds = getbool (annexConfig "cachecreds") True
, annexAutoUpgradeRepository = getbool (annexConfig "autoupgraderepository") True
, annexCommitMode = if getbool (annexConfig "allowsign") False
then ManualCommit
else AutomaticCommit
, annexSkipUnknown = getbool (annexConfig "skipunknown") True
, annexAdjustedBranchRefresh = fromMaybe
-- parse as bool if it's not a number
(if getbool "adjustedbranchrefresh" False then 1 else 0)
(getmayberead (annexConfig "adjustedbranchrefresh"))
, annexSupportUnlocked = getbool (annexConfig "supportunlocked") True
, coreSymlinks = getbool "core.symlinks" True
, coreSharedRepository = getSharedRepository r
, receiveDenyCurrentBranch = getDenyCurrentBranch r
, gcryptId = getmaybe "core.gcrypt-id"
, gpgCmd = mkGpgCmd (getmaybe "gpg.program")
, mergeDirectoryRenames = getmaybe "directoryrenames"
, annexPrivateRepos = S.fromList $ concat
[ if getbool (annexConfig "private") False
then [hereuuid]
else []
, let get (k, v)
| Git.Config.isTrueFalse' v /= Just True = Nothing
| isRemoteKey (remoteAnnexConfigEnd "private") k = do
remotename <- remoteKeyToRemoteName k
toUUID <$> Git.Config.getMaybe
(remoteAnnexConfig remotename "uuid") r
| otherwise = Nothing
in mapMaybe get (M.toList (Git.config r))
]
}
where
2015-01-28 20:11:28 +00:00
getbool k d = fromMaybe d $ getmaybebool k
getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k
getmayberead k = readish =<< getmaybe k
getmaybe = fmap fromConfigValue . getmaybe'
getmaybe' k = Git.Config.getMaybe k r
getlist k = map fromConfigValue $ Git.Config.getList k r
2013-01-27 13:33:19 +00:00
getwords k = fromMaybe [] $ words <$> getmaybe k
configurable d Nothing = DefaultConfig d
configurable _ (Just v) = case configsource of
FromGitConfig -> HasGitConfig v
FromGlobalConfig -> HasGlobalConfig v
onemegabyte = 1000000
hereuuid = maybe NoUUID toUUID $ getmaybe (annexConfig "uuid")
{- Merge a GitConfig that comes from git-config with one containing
- repository-global defaults. -}
mergeGitConfig :: GitConfig -> GitConfig -> GitConfig
mergeGitConfig gitconfig repoglobals = gitconfig
{ annexAutoCommit = merge annexAutoCommit
, annexSyncContent = merge annexSyncContent
sync --only-annex and annex.synconlyannex * Added sync --only-annex, which syncs the git-annex branch and annexed content but leaves managing the other git branches up to you. * Added annex.synconlyannex git config setting, which can also be set with git-annex config to configure sync in all clones of the repo. Use case is then the user has their own git workflow, and wants to use git-annex without disrupting that, so they sync --only-annex to get the git-annex stuff in sync in addition to their usual git workflow. When annex.synconlyannex is set, --not-only-annex can be used to override it. It's not entirely clear what --only-annex --commit or --only-annex --push should do, and I left that combination not documented because I don't know if I might want to change the current behavior, which is that such options do not override the --only-annex. My gut feeling is that there is no good reasons to use such combinations; if you want to use your own git workflow, you'll be doing your own committing and pulling and pushing. A subtle question is, how should import/export special remotes be handled? Importing updates their remote tracking branch and merges it into master. If --only-annex prevented that git branch stuff, then it would prevent exporting to the special remote, in the case where it has changes that were not imported yet, because there would be a unresolved conflict. I decided that it's best to treat the fact that there's a remote tracking branch for import/export as an implementation detail in this case. The more important thing is that an import/export special remote is entirely annexed content, and so it makes a lot of sense that --only-annex will still sync with it.
2020-02-17 19:19:58 +00:00
, annexSyncOnlyAnnex = merge annexSyncOnlyAnnex
, annexResolveMerge = merge annexResolveMerge
, annexLargeFiles = merge annexLargeFiles
, annexDotFiles = merge annexDotFiles
, annexAddUnlocked = merge annexAddUnlocked
}
where
merge f = case f gitconfig of
HasGitConfig v -> HasGitConfig v
DefaultConfig d -> case f repoglobals of
HasGlobalConfig v -> HasGlobalConfig v
_ -> HasGitConfig d
HasGlobalConfig v -> HasGlobalConfig v
{- Configs that can be set repository-global. -}
globalConfigs :: [ConfigKey]
globalConfigs =
[ annexConfig "largefiles"
, annexConfig "dotfiles"
, annexConfig "addunlocked"
, annexConfig "autocommit"
, annexConfig "resolvemerge"
, annexConfig "synccontent"
, annexConfig "synconlyannex"
, annexConfig "securehashesonly"
]
{- Per-remote git-annex settings. Each setting corresponds to a git-config
- key such as <remote>.annex-foo, or if that is not set, a default from
- annex.foo.
-
- Note that this is from the perspective of the local repository,
- it is not influenced in any way by the contents of the remote
- repository's git config.
-}
data RemoteGitConfig = RemoteGitConfig
{ remoteAnnexCost :: DynamicConfig (Maybe Cost)
, remoteAnnexIgnore :: DynamicConfig Bool
, remoteAnnexSync :: DynamicConfig Bool
, remoteAnnexPull :: Bool
, remoteAnnexPush :: Bool
, remoteAnnexReadOnly :: Bool
, remoteAnnexVerify :: Bool
, remoteAnnexCheckUUID :: Bool
, remoteAnnexTrackingBranch :: Maybe Git.Ref
, remoteAnnexTrustLevel :: Maybe String
, remoteAnnexStartCommand :: Maybe String
, remoteAnnexStopCommand :: Maybe String
, remoteAnnexAvailability :: Maybe Availability
, remoteAnnexSpeculatePresent :: Bool
, remoteAnnexBare :: Maybe Bool
2018-03-24 14:37:25 +00:00
, remoteAnnexRetry :: Maybe Integer
, remoteAnnexForwardRetry :: Maybe Integer
2018-03-24 14:37:25 +00:00
, remoteAnnexRetryDelay :: Maybe Seconds
, remoteAnnexStallDetection :: Maybe StallDetection
, remoteAnnexAllowUnverifiedDownloads :: Bool
, remoteAnnexConfigUUID :: Maybe UUID
{- These settings are specific to particular types of remotes
- including special remotes. -}
, remoteAnnexShell :: Maybe String
, remoteAnnexSshOptions :: [String]
, remoteAnnexRsyncOptions :: [String]
, remoteAnnexRsyncUploadOptions :: [String]
, remoteAnnexRsyncDownloadOptions :: [String]
, remoteAnnexRsyncTransport :: [String]
, remoteAnnexGnupgOptions :: [String]
, remoteAnnexGnupgDecryptOptions :: [String]
, remoteAnnexRsyncUrl :: Maybe String
, remoteAnnexBupRepo :: Maybe String
, remoteAnnexBorgRepo :: Maybe String
, remoteAnnexTahoe :: Maybe FilePath
, remoteAnnexBupSplitOptions :: [String]
, remoteAnnexDirectory :: Maybe FilePath
, remoteAnnexAndroidDirectory :: Maybe FilePath
, remoteAnnexAndroidSerial :: Maybe String
, remoteAnnexGCrypt :: Maybe String
, remoteAnnexGitLFS :: Bool
2014-05-15 18:44:00 +00:00
, remoteAnnexDdarRepo :: Maybe String
, remoteAnnexHookType :: Maybe String
, remoteAnnexExternalType :: Maybe String
}
{- The Git.Repo is the local repository, which has the remote with the
- given RemoteName. -}
extractRemoteGitConfig :: Git.Repo -> RemoteName -> STM RemoteGitConfig
extractRemoteGitConfig r remotename = do
annexcost <- mkDynamicConfig readCommandRunner
(notempty $ getmaybe "cost-command")
(getmayberead "cost")
annexignore <- mkDynamicConfig unsuccessfullCommandRunner
(notempty $ getmaybe "ignore-command")
(getbool "ignore" False)
annexsync <- mkDynamicConfig successfullCommandRunner
(notempty $ getmaybe "sync-command")
(getbool "sync" True)
return $ RemoteGitConfig
{ remoteAnnexCost = annexcost
, remoteAnnexIgnore = annexignore
, remoteAnnexSync = annexsync
, remoteAnnexPull = getbool "pull" True
, remoteAnnexPush = getbool "push" True
, remoteAnnexReadOnly = getbool "readonly" False
, remoteAnnexCheckUUID = getbool "checkuuid" True
, remoteAnnexVerify = getbool "verify" True
, remoteAnnexTrackingBranch = Git.Ref . encodeBS <$>
( notempty (getmaybe "tracking-branch")
<|> notempty (getmaybe "export-tracking") -- old name
)
, remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel"
, remoteAnnexStartCommand = notempty $ getmaybe "start-command"
, remoteAnnexStopCommand = notempty $ getmaybe "stop-command"
, remoteAnnexAvailability = getmayberead "availability"
, remoteAnnexSpeculatePresent = getbool "speculate-present" False
, remoteAnnexBare = getmaybebool "bare"
2018-03-24 14:37:25 +00:00
, remoteAnnexRetry = getmayberead "retry"
, remoteAnnexForwardRetry = getmayberead "forward-retry"
2018-03-24 14:37:25 +00:00
, remoteAnnexRetryDelay = Seconds
<$> getmayberead "retrydelay"
, remoteAnnexStallDetection =
either (const Nothing) id . parseStallDetection
=<< getmaybe "stalldetection"
, remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $
getmaybe ("security-allow-unverified-downloads")
, remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid"
, remoteAnnexShell = getmaybe "shell"
, remoteAnnexSshOptions = getoptions "ssh-options"
, remoteAnnexRsyncOptions = getoptions "rsync-options"
, remoteAnnexRsyncDownloadOptions = getoptions "rsync-download-options"
, remoteAnnexRsyncUploadOptions = getoptions "rsync-upload-options"
, remoteAnnexRsyncTransport = getoptions "rsync-transport"
, remoteAnnexGnupgOptions = getoptions "gnupg-options"
, remoteAnnexGnupgDecryptOptions = getoptions "gnupg-decrypt-options"
, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl"
, remoteAnnexBupRepo = getmaybe "buprepo"
, remoteAnnexBorgRepo = getmaybe "borgrepo"
, remoteAnnexTahoe = getmaybe "tahoe"
, remoteAnnexBupSplitOptions = getoptions "bup-split-options"
, remoteAnnexDirectory = notempty $ getmaybe "directory"
, remoteAnnexAndroidDirectory = notempty $ getmaybe "androiddirectory"
, remoteAnnexAndroidSerial = notempty $ getmaybe "androidserial"
, remoteAnnexGCrypt = notempty $ getmaybe "gcrypt"
, remoteAnnexGitLFS = getbool "git-lfs" False
, remoteAnnexDdarRepo = getmaybe "ddarrepo"
, remoteAnnexHookType = notempty $ getmaybe "hooktype"
, remoteAnnexExternalType = notempty $ getmaybe "externaltype"
}
where
2015-01-28 20:11:28 +00:00
getbool k d = fromMaybe d $ getmaybebool k
getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k
getmayberead k = readish =<< getmaybe k
getmaybe = fmap fromConfigValue . getmaybe'
getmaybe' k = mplus (Git.Config.getMaybe (annexConfig k) r)
(Git.Config.getMaybe (remoteAnnexConfig remotename k) r)
getoptions k = fromMaybe [] $ words <$> getmaybe k
notempty :: Maybe String -> Maybe String
notempty Nothing = Nothing
notempty (Just "") = Nothing
notempty (Just s) = Just s
dummyRemoteGitConfig :: IO RemoteGitConfig
dummyRemoteGitConfig = atomically $
extractRemoteGitConfig Git.Construct.fromUnknown "dummy"
type UnqualifiedConfigKey = B.ByteString
{- A global annex setting in git config. -}
annexConfig :: UnqualifiedConfigKey -> ConfigKey
annexConfig key = ConfigKey ("annex." <> key)
class RemoteNameable r where
getRemoteName :: r -> RemoteName
instance RemoteNameable Git.Repo where
getRemoteName r = fromMaybe "" (Git.remoteName r)
instance RemoteNameable RemoteName where
getRemoteName = id
{- A per-remote annex setting in git config. -}
remoteAnnexConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
remoteAnnexConfig r = remoteConfig r . remoteAnnexConfigEnd
remoteAnnexConfigEnd :: UnqualifiedConfigKey -> UnqualifiedConfigKey
remoteAnnexConfigEnd key = "annex-" <> key
{- A per-remote setting in git config. -}
remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
remoteConfig r key = ConfigKey $
"remote." <> encodeBS' (getRemoteName r) <> "." <> key