1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
{- git repository configuration handling
-
- Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git.Config where
import qualified Data.Map as M
import Data.Char
import System.Process (cwd, env)
import Common
import Git
import Git.Types
import qualified Git.Construct
import Utility.UserInfo
{- Returns a single git config setting, or a default value if not set. -}
get :: String -> String -> Repo -> String
get key defaultValue repo = M.findWithDefault defaultValue key (config repo)
{- Returns a list with each line of a multiline config setting. -}
getList :: String -> Repo -> [String]
getList key repo = M.findWithDefault [] key (fullconfig repo)
{- Returns a single git config setting, if set. -}
getMaybe :: String -> Repo -> Maybe String
getMaybe key repo = M.lookup key (config repo)
{- Runs git config and populates a repo with its config.
- Avoids re-reading config when run repeatedly. -}
read :: Repo -> IO Repo
read repo@(Repo { config = c })
| c == M.empty = read' repo
| otherwise = return repo
{- Reads config even if it was read before. -}
reRead :: Repo -> IO Repo
reRead r = read' $ r
{ config = M.empty
, fullconfig = M.empty
}
{- Cannot use pipeRead because it relies on the config having been already
- read. Instead, chdir to the repo and run git config.
-}
read' :: Repo -> IO Repo
read' repo = go repo
where
go Repo { location = Local { gitdir = d } } = git_config d
go Repo { location = LocalUnknown d } = git_config d
go _ = assertLocal repo $ error "internal"
git_config d = withHandle StdoutHandle createProcessSuccess p $
hRead repo
where
params = ["config", "--null", "--list"]
p = (proc "git" params)
{ cwd = Just d
, env = gitEnv repo
}
{- Gets the global git config, returning a dummy Repo containing it. -}
global :: IO (Maybe Repo)
global = do
home <- myHomeDir
ifM (doesFileExist $ home </> ".gitconfig")
( do
repo <- Git.Construct.fromUnknown
repo' <- withHandle StdoutHandle createProcessSuccess p $
hRead repo
return $ Just repo'
, return Nothing
)
where
params = ["config", "--null", "--list", "--global"]
p = (proc "git" params)
{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> Handle -> IO Repo
hRead repo h = do
-- We use the FileSystemEncoding when reading from git-config,
-- because it can contain arbitrary filepaths (and other strings)
-- in any encoding.
fileEncoding h
val <- hGetContentsStrict h
store val repo
{- Stores a git config into a Repo, returning the new version of the Repo.
- The git config may be multiple lines, or a single line.
- Config settings can be updated incrementally.
-}
store :: String -> Repo -> IO Repo
store s repo = do
let c = parse s
repo' <- updateLocation $ repo
{ config = (M.map Prelude.head c) `M.union` config repo
, fullconfig = M.unionWith (++) c (fullconfig repo)
}
rs <- Git.Construct.fromRemotes repo'
return $ repo' { remotes = rs }
{- Updates the location of a repo, based on its configuration.
-
- Git.Construct makes LocalUknown repos, of which only a directory is
- known. Once the config is read, this can be fixed up to a Local repo,
- based on the core.bare and core.worktree settings.
-}
updateLocation :: Repo -> IO Repo
updateLocation r@(Repo { location = LocalUnknown d })
| isBare r = updateLocation' r $ Local d Nothing
| otherwise = updateLocation' r $ Local (d </> ".git") (Just d)
updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
updateLocation r = return r
updateLocation' :: Repo -> RepoLocation -> IO Repo
updateLocation' r l = do
l' <- case getMaybe "core.worktree" r of
Nothing -> return l
Just d -> do
{- core.worktree is relative to the gitdir -}
top <- absPath $ gitdir l
return $ l { worktree = Just $ absPathFrom top d }
return $ r { location = l' }
{- Parses git config --list or git config --null --list output into a
- config map. -}
parse :: String -> M.Map String [String]
parse [] = M.empty
parse s
-- --list output will have an = in the first line
| all ('=' `elem`) (take 1 ls) = sep '=' ls
-- --null --list output separates keys from values with newlines
| otherwise = sep '\n' $ split "\0" s
where
ls = lines s
sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) .
map (separate (== c))
{- Checks if a string from git config is a true value. -}
isTrue :: String -> Maybe Bool
isTrue s
| s' == "true" = Just True
| s' == "false" = Just False
| otherwise = Nothing
where
s' = map toLower s
isBare :: Repo -> Bool
isBare r = fromMaybe False $ isTrue =<< getMaybe "core.bare" r
|
