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.

diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs
index 2db6a0d03320be46df700f6e7501def581113f86..5e0e85f2f4f8dd381d415dbf17295ea2200115d8 100644 (file)
--- a/Annex/SpecialRemote/Config.hs
+++ b/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

diff --git a/CHANGELOG b/CHANGELOG
index 6db433a60eeced671e1177d6be2d6fc2283aa4d5..954a8d7dd7856b1958f3cfe80492217faba06571 100644 (file)
--- a/CHANGELOG
+++ b/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
 

diff --git a/Command/Config.hs b/Command/Config.hs
index 79c78a1685ba162f9dbd4dff33b704da8e0bb182..f9593082a5146cc9502e85280f6c44c7bd4fd8ce 100644 (file)
--- a/Command/Config.hs
+++ b/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

diff --git a/Config.hs b/Config.hs
index 0196c1614511308073660224fab0d2db96313c7a..c87c665224a5ee42b08b1e6acd8b3d6d48a5dd8d 100644 (file)
--- a/Config.hs
+++ b/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

diff --git a/Config/GitConfig.hs b/Config/GitConfig.hs
index 1a63f7b7bbec6e98e647b4edb9bf4716ff1348af..d01ca64083cceb81e92a994a36f3364707a4ab71 100644 (file)
--- a/Config/GitConfig.hs
+++ b/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

diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs
index 13c8a2956527501896d81d2362d950620f7d2dd4..f80cc5974781cdc8dc7a32fb241a3b5f03dc1f00 100644 (file)
--- a/Remote/GitLFS.hs
+++ b/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 

diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs
index f7d0da2d349fac8a9a103f3625734b5f81f138a2..91c87018116ddbe53f4243e71815bbbaf4d78834 100644 (file)
--- a/Types/GitConfig.hs
+++ b/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")
-       , annexUUID = maybe NoUUID toUUID $ getmaybe (annex "uuid")
-       , annexNumCopies = NumCopies <$> getmayberead (annex "numcopies")
+       { annexVersion = RepoVersion <$> getmayberead (annexConfig "version")
+       , annexUUID = maybe NoUUID toUUID $ getmaybe (annexConfig "uuid")
+       , annexNumCopies = NumCopies <$> getmayberead (annexConfig "numcopies")
        , annexDiskReserve = fromMaybe onemegabyte $
-               readSize dataUnits =<< getmaybe (annex "diskreserve")
-       , annexDirect = getbool (annex "direct") False
+               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 (annex "backends"))
+               (headMaybe $ getwords (annexConfig "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
-       , annexCommitMessage = getmaybe (annex "commitmessage")
-       , annexMergeAnnexBranches = getbool (annex "merge-annex-branches") True
-       , annexDelayAdd = getmayberead (annex "delayadd")
-       , annexHttpHeaders = getlist (annex "http-headers")
-       , annexHttpHeadersCommand = getmaybe (annex "http-headers-command")
+               (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 (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")
-       , annexDebug = getbool (annex "debug") False
-       , annexWebOptions = getwords (annex "web-options")
-       , annexYoutubeDlOptions = getwords (annex "youtube-dl-options")
-       , annexAriaTorrentOptions = getwords (annex "aria-torrent-options")
-       , annexCrippledFileSystem = getbool (annex "crippledfilesystem") False
+               getmaybebool (annexConfig "synconlyannex")
+       , annexDebug = getbool (annexConfig "debug") False
+       , 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 (annex "largefiles")
-       , annexDotFiles = configurable False $ getmaybebool (annex "dotfiles")
-       , annexGitAddToAnnex = getbool (annex "gitaddtoannex") True
-       , annexAddSmallFiles = getbool (annex "addsmallfiles") True
-       , annexFsckNudge = getbool (annex "fscknudge") True
-       , annexAutoUpgrade = toAutoUpgrade $ getmaybe (annex "autoupgrade")
+               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 = 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
+               <$> 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
        , annexUsedRefSpec = either (const Nothing) Just . parseRefSpec 
-               =<< getmaybe (annex "used-refspec")
-       , annexVerify = getbool (annex "verify") True
-       , annexPidLock = getbool (annex "pidlock") False
+               =<< getmaybe (annexConfig "used-refspec")
+       , annexVerify = getbool (annexConfig "verify") True
+       , annexPidLock = getbool (annexConfig "pidlock") False
        , annexPidLockTimeout = Seconds $ fromMaybe 300 $
-               getmayberead (annex "pidlocktimeout")
+               getmayberead (annexConfig "pidlocktimeout")
        , annexAddUnlocked = configurable Nothing $
-               fmap Just $ getmaybe (annex "addunlocked")
-       , annexSecureHashesOnly = getbool (annex "securehashesonly") False
-       , annexRetry = getmayberead (annex "retry")
+               fmap Just $ getmaybe (annexConfig "addunlocked")
+       , annexSecureHashesOnly = getbool (annexConfig "securehashesonly") False
+       , 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")
-       , annexMaxExtensionLength = getmayberead (annex "maxextensionlength")
+               getmaybe (annexConfig "security.allow-unverified-downloads")
+       , annexMaxExtensionLength = getmayberead (annexConfig "maxextensionlength")
        , annexJobs = fromMaybe NonConcurrent $ 
-               parseConcurrency =<< getmaybe (annex "jobs")
-       , annexCacheCreds = getbool (annex "cachecreds") True
-       , annexAutoUpgradeRepository = getbool (annex "autoupgraderepository") True
-       , annexCommitMode = if getbool (annex "allowsign") False
+               parseConcurrency =<< getmaybe (annexConfig "jobs")
+       , annexCacheCreds = getbool (annexConfig "cachecreds") True
+       , annexAutoUpgradeRepository = getbool (annexConfig "autoupgraderepository") True
+       , 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)
-               (Git.Config.getMaybe (remotekey k) r)
+       getmaybe' k = mplus (Git.Config.getMaybe (annexConfig 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

diff --git a/Types/Remote.hs b/Types/Remote.hs
index 2a0a4deef67b412f6167c7c8d7cb42874b660315..7e09f0beb4526d03c5105626201728adf274bf26 100644 (file)
--- a/Types/Remote.hs
+++ b/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 ++ "\" }"