git-annex config: guard against non-repo-global configs

git-annex config: Only allow configs be set that are ones git-annex
actually supports reading from repo-global config, to avoid confused users
trying to set other configs with this.

Annex/SpecialRemote/Config.hs

@@ -16,7 +16,7 @@ import Types
 import Types.UUID
 import Types.ProposedAccepted
 import Types.RemoteConfig
-import Config
+import Types.GitConfig
 import qualified Git.Config
 
 import qualified Data.Map as M
@@ -234,8 +234,12 @@ optionalStringParser f fielddesc = RemoteConfigFieldParser
 	p Nothing _c = Right Nothing
 
 yesNoParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser
-yesNoParser f v fd = genParser yesNo f v fd
+yesNoParser f v fd = genParser yesno f v fd
 	(Just (ValueDesc "yes or no"))
+  where
+	yesno "yes" = Just True
+	yesno "no" = Just False
+	yesno _ = Nothing
 
 trueFalseParser :: RemoteConfigField -> Bool -> FieldDesc -> RemoteConfigFieldParser
 trueFalseParser f v fd = genParser Git.Config.isTrueFalse f v fd

CHANGELOG

@@ -10,6 +10,9 @@ git-annex (8.20200227) UNRELEASED; urgency=medium
   * Fix build with ghc 8.8 (MonadFail)
     Thanks, Peter Simons
   * stack.yaml: Updated to lts-14.27.
+  * git-annex config: Only allow configs be set that are ones git-annex actually
+    supports reading from repo-global config, to avoid confused users trying
+    to set other configs with this.
 
  -- Joey Hess <id@joeyh.name>  Thu, 27 Feb 2020 00:44:11 -0400
 

Command/Config.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2017 Joey Hess <id@joeyh.name>
+ - Copyright 2017-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -12,6 +12,7 @@ module Command.Config where
 import Command
 import Logs.Config
 import Config
+import Types.GitConfig (globalConfigs)
 import Git.Types (ConfigKey(..), fromConfigValue)
 
 import qualified Data.ByteString.Char8 as S8
@@ -53,25 +54,30 @@ optParser _ = setconfig <|> getconfig <|> unsetconfig
 		)
 
 seek :: Action -> CommandSeek
-seek (SetConfig ck@(ConfigKey name) val) = commandAction $
+seek (SetConfig ck@(ConfigKey name) val) = checkIsGlobalConfig ck $ commandAction $
 	startingUsualMessages (decodeBS' name) (ActionItemOther (Just (fromConfigValue val))) $ do
 		setGlobalConfig ck val
 		when (needLocalUpdate ck) $
 			setConfig ck (fromConfigValue val)
 		next $ return True
-seek (UnsetConfig ck@(ConfigKey name)) = commandAction $
+seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $
 	startingUsualMessages (decodeBS' name) (ActionItemOther (Just "unset")) $do
 		unsetGlobalConfig ck
 		when (needLocalUpdate ck) $
 			unsetConfig ck
 		next $ return True
-seek (GetConfig ck) = commandAction $
+seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $
 	startingCustomOutput (ActionItemOther Nothing) $ do
 		getGlobalConfig ck >>= \case
 			Nothing -> return ()
 			Just (ConfigValue v) -> liftIO $ S8.putStrLn v
 		next $ return True
 
+checkIsGlobalConfig :: ConfigKey -> Annex a -> Annex a
+checkIsGlobalConfig ck@(ConfigKey name) a
+	| elem ck globalConfigs = a
+	| otherwise = giveup $ decodeBS name ++ " is not a configuration setting that can be stored in the git-annex branch"
+
 needLocalUpdate :: ConfigKey -> Bool
 needLocalUpdate (ConfigKey "annex.securehashesonly") = True
 needLocalUpdate _ = False

Config.hs

@@ -5,10 +5,14 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Config where
+module Config (
+	module Config,
+	annexConfig,
+	remoteAnnexConfig,
+	remoteConfig,
+) where
 
 import Annex.Common
 import qualified Git
@@ -18,12 +22,8 @@ import qualified Annex
 import Config.Cost
 import Config.DynamicConfig
 import Types.Availability
+import Types.GitConfig
 import Git.Types
-import qualified Types.Remote as Remote
-
-import qualified Data.ByteString as S
-
-type UnqualifiedConfigKey = S.ByteString
 
 {- Looks up a setting in git config. This is not as efficient as using the
  - GitConfig type. -}
@@ -50,31 +50,6 @@ reloadConfig = Annex.changeGitRepo =<< inRepo Git.Config.reRead
 unsetConfig :: ConfigKey -> Annex ()
 unsetConfig key = void $ inRepo $ Git.Config.unset 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
-
-instance RemoteNameable Remote where
-	getRemoteName = Remote.name
-
-{- A per-remote config setting in git config. -}
-remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
-remoteConfig r key = ConfigKey $
-	"remote." <> encodeBS' (getRemoteName r) <> "." <> key
-
-{- A per-remote config annex setting in git config. -}
-remoteAnnexConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
-remoteAnnexConfig r key = remoteConfig r ("annex-" <> key)
-
-{- A global annex setting in git config. -}
-annexConfig :: UnqualifiedConfigKey -> ConfigKey
-annexConfig key = ConfigKey ("annex." <> key)
-
 {- Calculates cost for a remote. Either the specific default, or as configured 
  - by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
  - is set and prints a number, that is used. -}
@@ -108,8 +83,3 @@ crippledFileSystem = annexCrippledFileSystem <$> Annex.getGitConfig
 setCrippledFileSystem :: Bool -> Annex ()
 setCrippledFileSystem b =
 	setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
-
-yesNo :: String -> Maybe Bool
-yesNo "yes" = Just True
-yesNo "no" = Just False
-yesNo _ = Nothing

Config/GitConfig.hs

@@ -17,7 +17,8 @@ import Logs.Config
  - repository-global defaults when the GitConfig does not yet 
  - have a value.
  -
- - Note: Be sure to add the config value to mergeGitConfig.
+ - Note: Be sure to add the config to mergeGitConfig and to
+ - globalConfigs.
  -}
 getGitConfigVal :: (GitConfig -> Configurable a) -> Annex a
 getGitConfigVal f = getGitConfigVal' f >>= \case

Remote/GitLFS.hs

@@ -167,7 +167,7 @@ mySetup _ mu _ c gc = do
 	-- (so it's also usable by git as a non-special remote),
 	-- and set remote.name.annex-git-lfs = true
 	gitConfigSpecialRemote u c' [("git-lfs", "true")]
-	setConfig (remoteConfig (getRemoteName c) "url") url
+	setConfig (remoteConfig c "url") url
 	return (c', u)
   where
 	url = maybe (giveup "Specify url=") fromProposedAccepted 

Types/GitConfig.hs

@@ -1,10 +1,11 @@
 {- git-annex configuration
  -
- - Copyright 2012-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Types.GitConfig ( 
@@ -13,9 +14,14 @@ module Types.GitConfig (
 	GitConfig(..),
 	extractGitConfig,
 	mergeGitConfig,
+	globalConfigs,
 	RemoteGitConfig(..),
 	extractRemoteGitConfig,
 	dummyRemoteGitConfig,
+	annexConfig,
+	RemoteNameable(..),
+	remoteAnnexConfig,
+	remoteConfig,
 ) where
 
 import Common
@@ -43,6 +49,7 @@ import Utility.Url (Scheme, mkScheme)
 
 import Control.Concurrent.STM
 import qualified Data.Set as S
+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.
@@ -125,84 +132,86 @@ data GitConfig = GitConfig
 
 extractGitConfig :: ConfigSource -> Git.Repo -> GitConfig
 extractGitConfig configsource r = GitConfig
-	{ annexVersion = RepoVersion <$> getmayberead (annex "version")
+	{ annexVersion = RepoVersion <$> getmayberead (annexConfig "version")
-	, annexUUID = maybe NoUUID toUUID $ getmaybe (annex "uuid")
+	, annexUUID = maybe NoUUID toUUID $ getmaybe (annexConfig "uuid")
-	, annexNumCopies = NumCopies <$> getmayberead (annex "numcopies")
+	, annexNumCopies = NumCopies <$> getmayberead (annexConfig "numcopies")
 	, annexDiskReserve = fromMaybe onemegabyte $
-		readSize dataUnits =<< getmaybe (annex "diskreserve")
+		readSize dataUnits =<< getmaybe (annexConfig "diskreserve")
-	, annexDirect = getbool (annex "direct") False
+	, 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 (annex "backends"))
+		(headMaybe $ getwords (annexConfig "backends"))
 		Just
-		(getmaybe (annex "backend"))
+		(getmaybe (annexConfig "backend"))
-	, annexQueueSize = getmayberead (annex "queuesize")
+	, annexQueueSize = getmayberead (annexConfig "queuesize")
-	, annexBloomCapacity = getmayberead (annex "bloomcapacity")
+	, annexBloomCapacity = getmayberead (annexConfig "bloomcapacity")
-	, annexBloomAccuracy = getmayberead (annex "bloomaccuracy")
+	, annexBloomAccuracy = getmayberead (annexConfig "bloomaccuracy")
-	, annexSshCaching = getmaybebool (annex "sshcaching")
+	, annexSshCaching = getmaybebool (annexConfig "sshcaching")
-	, annexAlwaysCommit = getbool (annex "alwayscommit") True
+	, annexAlwaysCommit = getbool (annexConfig "alwayscommit") True
-	, annexCommitMessage = getmaybe (annex "commitmessage")
+	, annexCommitMessage = getmaybe (annexConfig "commitmessage")
-	, annexMergeAnnexBranches = getbool (annex "merge-annex-branches") True
+	, annexMergeAnnexBranches = getbool (annexConfig "merge-annex-branches") True
-	, annexDelayAdd = getmayberead (annex "delayadd")
+	, annexDelayAdd = getmayberead (annexConfig "delayadd")
-	, annexHttpHeaders = getlist (annex "http-headers")
+	, annexHttpHeaders = getlist (annexConfig "http-headers")
-	, annexHttpHeadersCommand = getmaybe (annex "http-headers-command")
+	, annexHttpHeadersCommand = getmaybe (annexConfig "http-headers-command")
 	, annexAutoCommit = configurable True $ 
-		getmaybebool (annex "autocommit")
+		getmaybebool (annexConfig "autocommit")
 	, annexResolveMerge = configurable True $ 
-		getmaybebool (annex "resolvemerge")
+		getmaybebool (annexConfig "resolvemerge")
 	, annexSyncContent = configurable False $ 
-		getmaybebool (annex "synccontent")
+		getmaybebool (annexConfig "synccontent")
 	, annexSyncOnlyAnnex = configurable False $ 
-		getmaybebool (annex "synconlyannex")
+		getmaybebool (annexConfig "synconlyannex")
-	, annexDebug = getbool (annex "debug") False
+	, annexDebug = getbool (annexConfig "debug") False
-	, annexWebOptions = getwords (annex "web-options")
+	, annexWebOptions = getwords (annexConfig "web-options")
-	, annexYoutubeDlOptions = getwords (annex "youtube-dl-options")
+	, annexYoutubeDlOptions = getwords (annexConfig "youtube-dl-options")
-	, annexAriaTorrentOptions = getwords (annex "aria-torrent-options")
+	, annexAriaTorrentOptions = getwords (annexConfig "aria-torrent-options")
-	, annexCrippledFileSystem = getbool (annex "crippledfilesystem") False
+	, annexCrippledFileSystem = getbool (annexConfig "crippledfilesystem") False
 	, annexLargeFiles = configurable Nothing $
-		fmap Just $ getmaybe (annex "largefiles")
+		fmap Just $ getmaybe (annexConfig "largefiles")
-	, annexDotFiles = configurable False $ getmaybebool (annex "dotfiles")
+	, annexDotFiles = configurable False $
-	, annexGitAddToAnnex = getbool (annex "gitaddtoannex") True
+		getmaybebool (annexConfig "dotfiles")
-	, annexAddSmallFiles = getbool (annex "addsmallfiles") True
+	, annexGitAddToAnnex = getbool (annexConfig "gitaddtoannex") True
-	, annexFsckNudge = getbool (annex "fscknudge") True
+	, annexAddSmallFiles = getbool (annexConfig "addsmallfiles") True
-	, annexAutoUpgrade = toAutoUpgrade $ getmaybe (annex "autoupgrade")
+	, annexFsckNudge = getbool (annexConfig "fscknudge") True
+	, annexAutoUpgrade = toAutoUpgrade $
+		getmaybe (annexConfig "autoupgrade")
 	, annexExpireUnused = maybe Nothing Just . parseDuration
-		<$> getmaybe (annex "expireunused")
+		<$> getmaybe (annexConfig "expireunused")
-	, annexSecureEraseCommand = getmaybe (annex "secure-erase-command")
+	, annexSecureEraseCommand = getmaybe (annexConfig "secure-erase-command")
-	, annexGenMetaData = getbool (annex "genmetadata") False
+	, annexGenMetaData = getbool (annexConfig "genmetadata") False
-	, annexListen = getmaybe (annex "listen")
+	, annexListen = getmaybe (annexConfig "listen")
-	, annexStartupScan = getbool (annex "startupscan") True
+	, annexStartupScan = getbool (annexConfig "startupscan") True
-	, annexHardLink = getbool (annex "hardlink") False
+	, annexHardLink = getbool (annexConfig "hardlink") False
-	, annexThin = getbool (annex "thin") False
+	, annexThin = getbool (annexConfig "thin") False
 	, annexDifferences = getDifferences r
 	, annexUsedRefSpec = either (const Nothing) Just . parseRefSpec 
-		=<< getmaybe (annex "used-refspec")
+		=<< getmaybe (annexConfig "used-refspec")
-	, annexVerify = getbool (annex "verify") True
+	, annexVerify = getbool (annexConfig "verify") True
-	, annexPidLock = getbool (annex "pidlock") False
+	, annexPidLock = getbool (annexConfig "pidlock") False
 	, annexPidLockTimeout = Seconds $ fromMaybe 300 $
-		getmayberead (annex "pidlocktimeout")
+		getmayberead (annexConfig "pidlocktimeout")
 	, annexAddUnlocked = configurable Nothing $
-		fmap Just $ getmaybe (annex "addunlocked")
+		fmap Just $ getmaybe (annexConfig "addunlocked")
-	, annexSecureHashesOnly = getbool (annex "securehashesonly") False
+	, annexSecureHashesOnly = getbool (annexConfig "securehashesonly") False
-	, annexRetry = getmayberead (annex "retry")
+	, annexRetry = getmayberead (annexConfig "retry")
 	, annexRetryDelay = Seconds
-		<$> getmayberead (annex "retrydelay")
+		<$> getmayberead (annexConfig "retrydelay")
 	, annexAllowedUrlSchemes = S.fromList $ map mkScheme $
 		maybe ["http", "https", "ftp"] words $
-			getmaybe (annex "security.allowed-url-schemes")
+			getmaybe (annexConfig "security.allowed-url-schemes")
 	, annexAllowedIPAddresses = fromMaybe "" $
-		getmaybe (annex "security.allowed-ip-addresses")
+		getmaybe (annexConfig "security.allowed-ip-addresses")
 			<|>
-		getmaybe (annex "security.allowed-http-addresses") -- old name
+		getmaybe (annexConfig "security.allowed-http-addresses") -- old name
 	, annexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $
-		getmaybe (annex "security.allow-unverified-downloads")
+		getmaybe (annexConfig "security.allow-unverified-downloads")
-	, annexMaxExtensionLength = getmayberead (annex "maxextensionlength")
+	, annexMaxExtensionLength = getmayberead (annexConfig "maxextensionlength")
 	, annexJobs = fromMaybe NonConcurrent $ 
-		parseConcurrency =<< getmaybe (annex "jobs")
+		parseConcurrency =<< getmaybe (annexConfig "jobs")
-	, annexCacheCreds = getbool (annex "cachecreds") True
+	, annexCacheCreds = getbool (annexConfig "cachecreds") True
-	, annexAutoUpgradeRepository = getbool (annex "autoupgraderepository") True
+	, annexAutoUpgradeRepository = getbool (annexConfig "autoupgraderepository") True
-	, annexCommitMode = if getbool (annex "allowsign") False
+	, annexCommitMode = if getbool (annexConfig "allowsign") False
 		then ManualCommit
 		else AutomaticCommit
 	, coreSymlinks = getbool "core.symlinks" True
@@ -225,8 +234,6 @@ extractGitConfig configsource r = GitConfig
 		FromGitConfig -> HasGitConfig v
 		FromGlobalConfig -> HasGlobalConfig v
 
-	annex k = ConfigKey $ "annex." <> k
-			
 	onemegabyte = 1000000
 
 {- Merge a GitConfig that comes from git-config with one containing
@@ -249,6 +256,18 @@ mergeGitConfig gitconfig repoglobals = gitconfig
 			_ -> HasGitConfig d
 		HasGlobalConfig v -> HasGlobalConfig v
 
+{- Configs that can be set repository-global. -}
+globalConfigs :: [ConfigKey]
+globalConfigs =
+	[ annexConfig "autocommit"
+	, annexConfig "synccontent"
+	, annexConfig "synconlyannex"
+	, annexConfig "resolvemerge"
+	, annexConfig "largefiles"
+	, annexConfig "dotfiles"
+	, annexConfig "addunlocked"
+	]
+
 {- 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.
@@ -366,14 +385,10 @@ extractRemoteGitConfig r remotename = do
 	getmaybebool k = Git.Config.isTrueFalse' =<< getmaybe' k
 	getmayberead k = readish =<< getmaybe k
 	getmaybe = fmap fromConfigValue . getmaybe'
-	getmaybe' k = mplus (Git.Config.getMaybe (key k) r)
+	getmaybe' k = mplus (Git.Config.getMaybe (annexConfig k) r)
-		(Git.Config.getMaybe (remotekey k) r)
+		(Git.Config.getMaybe (remoteAnnexConfig remotename k) r)
 	getoptions k = fromMaybe [] $ words <$> getmaybe k
 
-	key k = ConfigKey $ "annex." <> k
-	remotekey k = ConfigKey $
-		"remote." <> encodeBS' remotename <> ".annex-" <> k
-
 notempty :: Maybe String -> Maybe String	
 notempty Nothing = Nothing
 notempty (Just "") = Nothing
@@ -382,3 +397,27 @@ 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 key = remoteConfig r ("annex-" <> key)
+
+{- A per-remote setting in git config. -}
+remoteConfig :: RemoteNameable r => r -> UnqualifiedConfigKey -> ConfigKey
+remoteConfig r key = ConfigKey $
+	"remote." <> encodeBS' (getRemoteName r) <> "." <> key

Types/Remote.hs

@@ -153,6 +153,9 @@ data RemoteA a = Remote
 	, remoteStateHandle :: RemoteStateHandle
 	}
 
+instance RemoteNameable (RemoteA a) where
+	getRemoteName = name
+
 instance Show (RemoteA a) where
 	show remote = "Remote { name =\"" ++ name remote ++ "\" }"