mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Git: use NonEmpty in fullconfig

Browse source 
This is a nice win. Avoids partial functions, by encoding at the type
level the fact that fullconfig is never an empty list.
This commit is contained in:
Joey Hess 2024-09-26 17:54:36 -04:00
parent 936f22273e
commit 43f31121a5
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 28 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
Git/Config.hs
View file

@ -12,6 +12,7 @@ module Git.Config where
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.List.NonEmpty as NE
import Data.Char import Data.Char
import qualified System.FilePath.ByteString as P import qualified System.FilePath.ByteString as P
import Control.Concurrent.Async import Control.Concurrent.Async
@ -31,7 +32,7 @@ get key fallback repo = M.findWithDefault fallback key (config repo)
{- Returns a list of values. -} {- Returns a list of values. -}
getList :: ConfigKey -> Repo -> [ConfigValue] 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. -} {- Returns a single git config setting, if set. -}
getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue
@ -118,7 +119,8 @@ hRead repo st h = do
val <- S.hGetContents h val <- S.hGetContents h
let c = parse val st let c = parse val st
debug (DebugSource "Git.Config") $ "git config read: " ++ 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 storeParsed c repo
{- Stores a git config into a Repo, returning the new version of the 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.ByteString -> ConfigStyle -> Repo -> IO Repo
store s st = storeParsed (parse s st) 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 storeParsed c repo = updateLocation $ repo
{ config = (M.map Prelude.head c) `M.union` config repo { config = (M.map NE.head c) `M.union` config repo
, fullconfig = M.unionWith (++) c (fullconfig repo) , fullconfig = M.unionWith (<>) c (fullconfig repo)
} }
{- Stores a single config setting in a Repo, returning the new version of {- 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' :: ConfigKey -> ConfigValue -> Repo -> Repo
store' k v repo = repo store' k v repo = repo
{ config = M.singleton k v `M.union` config 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. {- 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 {- Parses git config --list or git config --null --list output into a
- config map. -} - config map. -}
parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue] parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey (NE.NonEmpty ConfigValue)
parse s st parse s st
| S.null s = M.empty | S.null s = M.empty
| otherwise = case st of | otherwise = case st of
@ -201,8 +204,8 @@ parse s st
nl = fromIntegral (ord '\n') nl = fromIntegral (ord '\n')
eq = fromIntegral (ord '=') eq = fromIntegral (ord '=')
sep c = M.fromListWith (++) sep c = M.fromListWith (<>)
. map (\(k,v) -> (ConfigKey k, [mkval v])) . map (\(k,v) -> (ConfigKey k, (NE.singleton (mkval v))) )
. map (S.break (== c)) . map (S.break (== c))
mkval v mkval v

3
Git/Remote.hs
View file

@ -19,6 +19,7 @@ import Data.Char
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.List.NonEmpty as NE
import Network.URI import Network.URI
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
import Git.FilePath import Git.FilePath
@ -117,7 +118,7 @@ parseRemoteLocation s knownurl repo = go
(_, NoConfigValue) -> False (_, NoConfigValue) -> False
filterconfig f = filter f $ filterconfig f = filter f $
concatMap splitconfigs $ M.toList $ fullconfig repo 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") (prefix, suffix) = ("url." , ".insteadof")
-- git supports URIs that contain unescaped characters such as -- git supports URIs that contain unescaped characters such as
-- spaces. So to test if it's a (git) URI, escape those. -- spaces. So to test if it's a (git) URI, escape those.

3
Git/Types.hs
View file

@ -14,6 +14,7 @@ import Data.String
import Data.Default import Data.Default
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.List.NonEmpty as NE
import System.Posix.Types import System.Posix.Types
import Utility.SafeCommand import Utility.SafeCommand
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
@ -42,7 +43,7 @@ data Repo = Repo
{ location :: RepoLocation { location :: RepoLocation
, config :: M.Map ConfigKey ConfigValue , config :: M.Map ConfigKey ConfigValue
-- a given git config key can actually have multiple values -- 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 -- remoteName holds the name used for this repo in some other
-- repo's list of remotes, when this repo is such a remote -- repo's list of remotes, when this repo is such a remote
, remoteName :: Maybe RemoteName , remoteName :: Maybe RemoteName

22
Remote/Git.hs
View file

@ -72,6 +72,7 @@ import Messages.Progress
import Control.Concurrent import Control.Concurrent
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.List.NonEmpty as NE
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import Network.URI import Network.URI
@ -937,7 +938,7 @@ listProxied proxies rs = concat <$> mapM go rs
Git.fullconfig r Git.fullconfig r
in r in r
{ Git.remoteName = Just proxyname { Git.remoteName = Just proxyname
, Git.config = M.map Prelude.head c , Git.config = M.map NE.head c
, Git.fullconfig = c , Git.fullconfig = c
} }
@ -948,19 +949,19 @@ listProxied proxies rs = concat <$> mapM go rs
adjustclusternode clusters $ adjustclusternode clusters $
inheritconfigs $ Git.fullconfig r' inheritconfigs $ Git.fullconfig r'
in r' in r'
{ Git.config = M.map Prelude.head c { Git.config = M.map NE.head c
, Git.fullconfig = c , Git.fullconfig = c
} }
adduuid ck = M.insert ck adduuid ck = M.insert ck $ NE.singleton $
[Git.ConfigValue $ fromUUID $ proxyRemoteUUID p] Git.ConfigValue $ fromUUID $ proxyRemoteUUID p
addurl = M.insert (mkRemoteConfigKey renamedr (remoteGitConfigKey UrlField)) addurl = M.insert (mkRemoteConfigKey renamedr (remoteGitConfigKey UrlField)) $
[Git.ConfigValue $ encodeBS $ Git.repoLocation r] NE.singleton $ Git.ConfigValue $ encodeBS $ Git.repoLocation r
addproxiedby = case remoteAnnexUUID gc of addproxiedby = case remoteAnnexUUID gc of
Just u -> addremoteannexfield ProxiedByField Just u -> addremoteannexfield ProxiedByField
[Git.ConfigValue $ fromUUID u] (Git.ConfigValue $ fromUUID u)
Nothing -> id Nothing -> id
-- A node of a cluster that is being proxied along with -- A node of a cluster that is being proxied along with
@ -975,15 +976,16 @@ listProxied proxies rs = concat <$> mapM go rs
Just cs Just cs
| any (\c -> S.member (fromClusterUUID c) proxieduuids) (S.toList cs) -> | any (\c -> S.member (fromClusterUUID c) proxieduuids) (S.toList cs) ->
addremoteannexfield SyncField addremoteannexfield SyncField
[Git.ConfigValue $ Git.Config.boolConfig' False] (Git.ConfigValue $ Git.Config.boolConfig' False)
. addremoteannexfield CostField . addremoteannexfield CostField
[Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1] (Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1)
_ -> id _ -> id
proxieduuids = S.map proxyRemoteUUID proxied proxieduuids = S.map proxyRemoteUUID proxied
addremoteannexfield f = M.insert addremoteannexfield f = M.insert
(mkRemoteConfigKey renamedr (remoteGitConfigKey f)) (mkRemoteConfigKey renamedr (remoteGitConfigKey f))
. NE.singleton
inheritconfigs c = foldl' inheritconfig c proxyInheritedFields inheritconfigs c = foldl' inheritconfig c proxyInheritedFields