From 43f31121a57d99cd9c774762c8417df6e2b16fab Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 26 Sep 2024 17:54:36 -0400 Subject: [PATCH] Git: use NonEmpty in fullconfig This is a nice win. Avoids partial functions, by encoding at the type level the fact that fullconfig is never an empty list. --- Git/Config.hs | 21 ++++++++++++--------- Git/Remote.hs | 3 ++- Git/Types.hs | 3 ++- Remote/Git.hs | 22 ++++++++++++---------- 4 files changed, 28 insertions(+), 21 deletions(-) diff --git a/Git/Config.hs b/Git/Config.hs index 4423ea6d48..6c24c04dc3 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -12,6 +12,7 @@ module Git.Config where import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 +import qualified Data.List.NonEmpty as NE import Data.Char import qualified System.FilePath.ByteString as P import Control.Concurrent.Async @@ -31,7 +32,7 @@ get key fallback repo = M.findWithDefault fallback key (config repo) {- Returns a list of values. -} getList :: ConfigKey -> Repo -> [ConfigValue] -getList key repo = M.findWithDefault [] key (fullconfig repo) +getList key repo = maybe [] NE.toList $ M.lookup key (fullconfig repo) {- Returns a single git config setting, if set. -} getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue @@ -118,7 +119,8 @@ hRead repo st h = do val <- S.hGetContents h let c = parse val st debug (DebugSource "Git.Config") $ "git config read: " ++ - show (map (\(k, v) -> (show k, map show v)) (M.toList c)) + show (map (\(k, v) -> (show k, map show (NE.toList v))) + (M.toList c)) storeParsed c repo {- Stores a git config into a Repo, returning the new version of the Repo. @@ -128,10 +130,10 @@ hRead repo st h = do store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo store s st = storeParsed (parse s st) -storeParsed :: M.Map ConfigKey [ConfigValue] -> Repo -> IO Repo +storeParsed :: M.Map ConfigKey (NE.NonEmpty ConfigValue) -> Repo -> IO Repo storeParsed c repo = updateLocation $ repo - { config = (M.map Prelude.head c) `M.union` config repo - , fullconfig = M.unionWith (++) c (fullconfig repo) + { config = (M.map NE.head c) `M.union` config repo + , fullconfig = M.unionWith (<>) c (fullconfig repo) } {- Stores a single config setting in a Repo, returning the new version of @@ -139,7 +141,8 @@ storeParsed c repo = updateLocation $ repo store' :: ConfigKey -> ConfigValue -> Repo -> Repo store' k v repo = repo { config = M.singleton k v `M.union` config repo - , fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo) + , fullconfig = M.unionWith (<>) (M.singleton k (NE.singleton v)) + (fullconfig repo) } {- Updates the location of a repo, based on its configuration. @@ -191,7 +194,7 @@ data ConfigStyle = ConfigList | ConfigNullList {- Parses git config --list or git config --null --list output into a - config map. -} -parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue] +parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey (NE.NonEmpty ConfigValue) parse s st | S.null s = M.empty | otherwise = case st of @@ -201,8 +204,8 @@ parse s st nl = fromIntegral (ord '\n') eq = fromIntegral (ord '=') - sep c = M.fromListWith (++) - . map (\(k,v) -> (ConfigKey k, [mkval v])) + sep c = M.fromListWith (<>) + . map (\(k,v) -> (ConfigKey k, (NE.singleton (mkval v))) ) . map (S.break (== c)) mkval v diff --git a/Git/Remote.hs b/Git/Remote.hs index 3a8945c146..2cc0e2601d 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -19,6 +19,7 @@ import Data.Char import qualified Data.Map as M import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 +import qualified Data.List.NonEmpty as NE import Network.URI #ifdef mingw32_HOST_OS import Git.FilePath @@ -117,7 +118,7 @@ parseRemoteLocation s knownurl repo = go (_, NoConfigValue) -> False filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo - splitconfigs (k, vs) = map (\v -> (k, v)) vs + splitconfigs (k, vs) = map (\v -> (k, v)) (NE.toList vs) (prefix, suffix) = ("url." , ".insteadof") -- git supports URIs that contain unescaped characters such as -- spaces. So to test if it's a (git) URI, escape those. diff --git a/Git/Types.hs b/Git/Types.hs index 3f4410fc0d..18398a040e 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -14,6 +14,7 @@ import Data.String import Data.Default import qualified Data.Map as M import qualified Data.ByteString as S +import qualified Data.List.NonEmpty as NE import System.Posix.Types import Utility.SafeCommand import Utility.FileSystemEncoding @@ -42,7 +43,7 @@ data Repo = Repo { location :: RepoLocation , config :: M.Map ConfigKey ConfigValue -- a given git config key can actually have multiple values - , fullconfig :: M.Map ConfigKey [ConfigValue] + , fullconfig :: M.Map ConfigKey (NE.NonEmpty ConfigValue) -- remoteName holds the name used for this repo in some other -- repo's list of remotes, when this repo is such a remote , remoteName :: Maybe RemoteName diff --git a/Remote/Git.hs b/Remote/Git.hs index 4a79cfed40..25e2d62c4c 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -72,6 +72,7 @@ import Messages.Progress import Control.Concurrent import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.List.NonEmpty as NE import qualified Data.ByteString as B import qualified Utility.RawFilePath as R import Network.URI @@ -937,7 +938,7 @@ listProxied proxies rs = concat <$> mapM go rs Git.fullconfig r in r { Git.remoteName = Just proxyname - , Git.config = M.map Prelude.head c + , Git.config = M.map NE.head c , Git.fullconfig = c } @@ -948,19 +949,19 @@ listProxied proxies rs = concat <$> mapM go rs adjustclusternode clusters $ inheritconfigs $ Git.fullconfig r' in r' - { Git.config = M.map Prelude.head c + { Git.config = M.map NE.head c , Git.fullconfig = c } - adduuid ck = M.insert ck - [Git.ConfigValue $ fromUUID $ proxyRemoteUUID p] + adduuid ck = M.insert ck $ NE.singleton $ + Git.ConfigValue $ fromUUID $ proxyRemoteUUID p - addurl = M.insert (mkRemoteConfigKey renamedr (remoteGitConfigKey UrlField)) - [Git.ConfigValue $ encodeBS $ Git.repoLocation r] + addurl = M.insert (mkRemoteConfigKey renamedr (remoteGitConfigKey UrlField)) $ + NE.singleton $ Git.ConfigValue $ encodeBS $ Git.repoLocation r addproxiedby = case remoteAnnexUUID gc of Just u -> addremoteannexfield ProxiedByField - [Git.ConfigValue $ fromUUID u] + (Git.ConfigValue $ fromUUID u) Nothing -> id -- A node of a cluster that is being proxied along with @@ -975,15 +976,16 @@ listProxied proxies rs = concat <$> mapM go rs Just cs | any (\c -> S.member (fromClusterUUID c) proxieduuids) (S.toList cs) -> addremoteannexfield SyncField - [Git.ConfigValue $ Git.Config.boolConfig' False] + (Git.ConfigValue $ Git.Config.boolConfig' False) . addremoteannexfield CostField - [Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1] + (Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1) _ -> id proxieduuids = S.map proxyRemoteUUID proxied addremoteannexfield f = M.insert - (mkRemoteConfigKey renamedr (remoteGitConfigKey f)) + (mkRemoteConfigKey renamedr (remoteGitConfigKey f)) + . NE.singleton inheritconfigs c = foldl' inheritconfig c proxyInheritedFields -- 2.30.2