git-annex/Types/GitConfig.hs

310 lines
11 KiB
Haskell
Raw Normal View History

{- git-annex configuration
-
- Copyright 2012-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Types.GitConfig (
Configurable(..),
GitConfig(..),
extractGitConfig,
mergeGitConfig,
RemoteGitConfig(..),
extractRemoteGitConfig,
dummyRemoteGitConfig,
) where
import Common
import qualified Git
import qualified Git.Config
import qualified Git.Construct
import Git.ConfigTypes
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.NumCopies
import Types.Difference
2015-05-14 19:44:08 +00:00
import Types.RefSpec
import Config.DynamicConfig
import Utility.HumanTime
import Utility.Gpg (GpgCmd, mkGpgCmd)
import Utility.ThreadScheduler (Seconds(..))
import Control.Concurrent.STM
-- | A configurable value, that may not be fully determined yet because
-- the global git config has not yet been loaded.
data Configurable a
= HasConfig a
-- ^ Value is fully determined.
| DefaultConfig a
-- ^ A default value is known, but not all config sources
-- have been read yet.
deriving (Show)
{- Main git-annex settings. Each setting corresponds to a git-config key
- such as annex.foo -}
data GitConfig = GitConfig
{ annexVersion :: Maybe String
, 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
, annexMergeAnnexBranches :: Bool
, annexDelayAdd :: Maybe Int
, annexHttpHeaders :: [String]
, annexHttpHeadersCommand :: Maybe String
, annexAutoCommit :: Configurable Bool
, annexResolveMerge :: Configurable Bool
, annexSyncContent :: Configurable Bool
, annexDebug :: Bool
2013-01-27 13:33:19 +00:00
, annexWebOptions :: [String]
, annexYoutubeDlOptions :: [String]
, annexAriaTorrentOptions :: [String]
, annexWebDownloadCommand :: Maybe String
, annexCrippledFileSystem :: Bool
, annexLargeFiles :: Maybe String
, 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
, annexAddUnlocked :: Bool
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
, annexRetryDelay :: Maybe Seconds
, coreSymlinks :: Bool
, coreSharedRepository :: SharedRepository
, receiveDenyCurrentBranch :: DenyCurrentBranch
, gcryptId :: Maybe String
, gpgCmd :: GpgCmd
, gitConfigRepo :: Git.Repo
}
extractGitConfig :: Git.Repo -> GitConfig
extractGitConfig r = GitConfig
{ annexVersion = notempty $ getmaybe (annex "version")
, annexUUID = maybe NoUUID toUUID $ getmaybe (annex "uuid")
, annexNumCopies = NumCopies <$> getmayberead (annex "numcopies")
, annexDiskReserve = fromMaybe onemegabyte $
readSize dataUnits =<< getmaybe (annex "diskreserve")
, annexDirect = getbool (annex "direct") False
, annexBackend = maybe
-- annex.backends is the old name of the option, still used
-- when annex.backend is not set.
(headMaybe $ getwords (annex "backends"))
Just
(getmaybe (annex "backend"))
, annexQueueSize = getmayberead (annex "queuesize")
, annexBloomCapacity = getmayberead (annex "bloomcapacity")
, annexBloomAccuracy = getmayberead (annex "bloomaccuracy")
, annexSshCaching = getmaybebool (annex "sshcaching")
, annexAlwaysCommit = getbool (annex "alwayscommit") True
, annexMergeAnnexBranches = getbool (annex "merge-annex-branches") True
, annexDelayAdd = getmayberead (annex "delayadd")
, annexHttpHeaders = getlist (annex "http-headers")
, annexHttpHeadersCommand = getmaybe (annex "http-headers-command")
, annexAutoCommit = configurable True $
getmaybebool (annex "autocommit")
, annexResolveMerge = configurable True $
getmaybebool (annex "resolvemerge")
, annexSyncContent = configurable False $
getmaybebool (annex "synccontent")
, annexDebug = getbool (annex "debug") False
, annexWebOptions = getwords (annex "web-options")
, annexYoutubeDlOptions = getwords (annex "youtube-dl-options")
, annexAriaTorrentOptions = getwords (annex "aria-torrent-options")
, annexWebDownloadCommand = getmaybe (annex "web-download-command")
, annexCrippledFileSystem = getbool (annex "crippledfilesystem") False
, annexLargeFiles = getmaybe (annex "largefiles")
, annexAddSmallFiles = getbool (annex "addsmallfiles") True
, annexFsckNudge = getbool (annex "fscknudge") True
2013-11-22 20:04:20 +00:00
, annexAutoUpgrade = toAutoUpgrade $ getmaybe (annex "autoupgrade")
, annexExpireUnused = maybe Nothing Just . parseDuration
<$> getmaybe (annex "expireunused")
, annexSecureEraseCommand = getmaybe (annex "secure-erase-command")
, annexGenMetaData = getbool (annex "genmetadata") False
, annexListen = getmaybe (annex "listen")
, annexStartupScan = getbool (annex "startupscan") True
, annexHardLink = getbool (annex "hardlink") False
, annexThin = getbool (annex "thin") False
, annexDifferences = getDifferences r
2015-05-14 19:44:08 +00:00
, annexUsedRefSpec = either (const Nothing) Just . parseRefSpec
=<< getmaybe (annex "used-refspec")
, annexVerify = getbool (annex "verify") True
, annexPidLock = getbool (annex "pidlock") False
, annexPidLockTimeout = Seconds $ fromMaybe 300 $
getmayberead (annex "pidlocktimeout")
, annexAddUnlocked = getbool (annex "addunlocked") False
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 = getbool (annex "securehashesonly") False
2018-03-24 14:37:25 +00:00
, annexRetry = getmayberead (annex "retry")
, annexRetryDelay = Seconds
<$> getmayberead (annex "retrydelay")
, coreSymlinks = getbool "core.symlinks" True
, coreSharedRepository = getSharedRepository r
, receiveDenyCurrentBranch = getDenyCurrentBranch r
, gcryptId = getmaybe "core.gcrypt-id"
, gpgCmd = mkGpgCmd (getmaybe "gpg.program")
, gitConfigRepo = r
}
where
2015-01-28 20:11:28 +00:00
getbool k d = fromMaybe d $ getmaybebool k
getmaybebool k = Git.Config.isTrue =<< getmaybe k
getmayberead k = readish =<< getmaybe k
getmaybe k = Git.Config.getMaybe k r
getlist k = 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) = HasConfig v
annex k = "annex." ++ k
onemegabyte = 1000000
{- 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
}
where
merge f = case f gitconfig of
HasConfig v -> HasConfig v
DefaultConfig d -> case f repoglobals of
HasConfig v -> HasConfig v
DefaultConfig _ -> HasConfig d
{- 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 -}
data RemoteGitConfig = RemoteGitConfig
{ remoteAnnexCost :: DynamicConfig (Maybe Cost)
, remoteAnnexIgnore :: DynamicConfig Bool
, remoteAnnexSync :: DynamicConfig Bool
, remoteAnnexPull :: Bool
, remoteAnnexPush :: Bool
, remoteAnnexReadOnly :: Bool
, remoteAnnexVerify :: Bool
, remoteAnnexCheckUUID :: Bool
, remoteAnnexExportTracking :: Maybe Git.Ref
, remoteAnnexTrustLevel :: Maybe String
, remoteAnnexStartCommand :: Maybe String
, remoteAnnexStopCommand :: Maybe String
, remoteAnnexAvailability :: Maybe Availability
, remoteAnnexBare :: Maybe Bool
2018-03-24 14:37:25 +00:00
, remoteAnnexRetry :: Maybe Integer
, remoteAnnexRetryDelay :: Maybe Seconds
{- 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
, remoteAnnexTahoe :: Maybe FilePath
, remoteAnnexBupSplitOptions :: [String]
, remoteAnnexDirectory :: Maybe FilePath
, remoteAnnexGCrypt :: Maybe String
2014-05-15 18:44:00 +00:00
, remoteAnnexDdarRepo :: Maybe String
, remoteAnnexHookType :: Maybe String
, remoteAnnexExternalType :: Maybe String
{- A regular git remote's git repository config. -}
, remoteGitConfig :: GitConfig
}
extractRemoteGitConfig :: Git.Repo -> String -> 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
, remoteAnnexExportTracking = Git.Ref
<$> notempty (getmaybe "export-tracking")
, remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel"
, remoteAnnexStartCommand = notempty $ getmaybe "start-command"
, remoteAnnexStopCommand = notempty $ getmaybe "stop-command"
, remoteAnnexAvailability = getmayberead "availability"
, remoteAnnexBare = getmaybebool "bare"
2018-03-24 14:37:25 +00:00
, remoteAnnexRetry = getmayberead "retry"
, remoteAnnexRetryDelay = Seconds
<$> getmayberead "retrydelay"
, 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"
, remoteAnnexTahoe = getmaybe "tahoe"
, remoteAnnexBupSplitOptions = getoptions "bup-split-options"
, remoteAnnexDirectory = notempty $ getmaybe "directory"
, remoteAnnexGCrypt = notempty $ getmaybe "gcrypt"
, remoteAnnexDdarRepo = getmaybe "ddarrepo"
, remoteAnnexHookType = notempty $ getmaybe "hooktype"
, remoteAnnexExternalType = notempty $ getmaybe "externaltype"
, remoteGitConfig = extractGitConfig r
}
where
2015-01-28 20:11:28 +00:00
getbool k d = fromMaybe d $ getmaybebool k
getmaybebool k = Git.Config.isTrue =<< getmaybe k
getmayberead k = readish =<< getmaybe k
2013-04-03 07:52:41 +00:00
getmaybe k = mplus (Git.Config.getMaybe (key k) r)
(Git.Config.getMaybe (remotekey k) r)
getoptions k = fromMaybe [] $ words <$> getmaybe k
key k = "annex." ++ k
remotekey k = "remote." ++ remotename ++ ".annex-" ++ 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"