1{- git repository configuration handling
2 -
3 - Copyright 2010-2020 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE OverloadedStrings #-}
9
10module Git.Config where
11
12import qualified Data.Map as M
13import qualified Data.ByteString as S
14import qualified Data.ByteString.Char8 as S8
15import Data.Char
16import qualified System.FilePath.ByteString as P
17import Control.Concurrent.Async
18
19import Common
20import Git
21import Git.Types
22import qualified Git.Command
23import qualified Git.Construct
24import Utility.UserInfo
25
26{- Returns a single git config setting, or a fallback value if not set. -}
27get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue
28get key fallback repo = M.findWithDefault fallback key (config repo)
29
30{- Returns a list of values. -}
31getList :: ConfigKey -> Repo -> [ConfigValue]
32getList key repo = M.findWithDefault [] key (fullconfig repo)
33
34{- Returns a single git config setting, if set. -}
35getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue
36getMaybe key repo = M.lookup key (config repo)
37
38{- Runs git config and populates a repo with its config.
39 - Avoids re-reading config when run repeatedly. -}
40read :: Repo -> IO Repo
41read repo@(Repo { config = c })
42	| c == M.empty = read' repo
43	| otherwise = return repo
44
45{- Reads config even if it was read before. -}
46reRead :: Repo -> IO Repo
47reRead r = read' $ r
48	{ config = M.empty
49	, fullconfig = M.empty
50	}
51
52{- Cannot use pipeRead because it relies on the config having been already
53 - read. Instead, chdir to the repo and run git config.
54 -}
55read' :: Repo -> IO Repo
56read' repo = go repo
57  where
58	go Repo { location = Local { gitdir = d } } = git_config d
59	go Repo { location = LocalUnknown d } = git_config d
60	go _ = assertLocal repo $ error "internal"
61	git_config d = withCreateProcess p (git_config' p)
62	  where
63		params = ["config", "--null", "--list"]
64		p = (proc "git" params)
65			{ cwd = Just (fromRawFilePath d)
66			, env = gitEnv repo
67			, std_out = CreatePipe
68			}
69	git_config' p _ (Just hout) _ pid =
70		forceSuccessProcess p pid
71			`after`
72		hRead repo ConfigNullList hout
73	git_config' _ _ _ _ _ = error "internal"
74
75{- Gets the global git config, returning a dummy Repo containing it. -}
76global :: IO (Maybe Repo)
77global = do
78	home <- myHomeDir
79	ifM (doesFileExist $ home </> ".gitconfig")
80		( Just <$> withCreateProcess p go
81		, return Nothing
82		)
83  where
84	params = ["config", "--null", "--list", "--global"]
85	p = (proc "git" params)
86		{ std_out = CreatePipe }
87	go _ (Just hout) _ pid =
88		forceSuccessProcess p pid
89			`after`
90		hRead (Git.Construct.fromUnknown) ConfigNullList hout
91	go _ _ _ _ = error "internal"
92
93{- Reads git config from a handle and populates a repo with it. -}
94hRead :: Repo -> ConfigStyle -> Handle -> IO Repo
95hRead repo st h = do
96	val <- S.hGetContents h
97	store val st repo
98
99{- Stores a git config into a Repo, returning the new version of the Repo.
100 - The git config may be multiple lines, or a single line.
101 - Config settings can be updated incrementally.
102 -}
103store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo
104store s st repo = do
105	let c = parse s st
106	updateLocation $ repo
107		{ config = (M.map Prelude.head c) `M.union` config repo
108		, fullconfig = M.unionWith (++) c (fullconfig repo)
109		}
110
111{- Stores a single config setting in a Repo, returning the new version of
112 - the Repo. Config settings can be updated incrementally. -}
113store' :: ConfigKey -> ConfigValue -> Repo -> Repo
114store' k v repo = repo
115	{ config = M.singleton k v `M.union` config repo
116	, fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo)
117	}
118
119{- Updates the location of a repo, based on its configuration.
120 -
121 - Git.Construct makes LocalUknown repos, of which only a directory is
122 - known. Once the config is read, this can be fixed up to a Local repo,
123 - based on the core.bare and core.worktree settings.
124 -}
125updateLocation :: Repo -> IO Repo
126updateLocation r@(Repo { location = LocalUnknown d })
127	| isBare r = ifM (doesDirectoryExist (fromRawFilePath dotgit))
128			( updateLocation' r $ Local dotgit Nothing
129			, updateLocation' r $ Local d Nothing
130			)
131	| otherwise = updateLocation' r $ Local dotgit (Just d)
132  where
133	dotgit = d P.</> ".git"
134updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
135updateLocation r = return r
136
137updateLocation' :: Repo -> RepoLocation -> IO Repo
138updateLocation' r l = do
139	l' <- case getMaybe "core.worktree" r of
140		Nothing -> return l
141		Just (ConfigValue d) -> do
142			{- core.worktree is relative to the gitdir -}
143			top <- absPath (gitdir l)
144			let p = absPathFrom top d
145			return $ l { worktree = Just p }
146		Just NoConfigValue -> return l
147	return $ r { location = l' }
148
149data ConfigStyle = ConfigList | ConfigNullList
150
151{- Parses git config --list or git config --null --list output into a
152 - config map. -}
153parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue]
154parse s st
155	| S.null s = M.empty
156	| otherwise = case st of
157		ConfigList -> sep eq $ S.split nl s
158		ConfigNullList -> sep nl $ S.split 0 s
159  where
160	nl = fromIntegral (ord '\n')
161	eq = fromIntegral (ord '=')
162
163	sep c = M.fromListWith (++)
164		. map (\(k,v) -> (ConfigKey k, [mkval v]))
165		. map (S.break (== c))
166
167	mkval v
168		| S.null v = NoConfigValue
169		| otherwise = ConfigValue (S.drop 1 v)
170
171{- Checks if a string from git config is a true/false value. -}
172isTrueFalse :: String -> Maybe Bool
173isTrueFalse = isTrueFalse' . ConfigValue . encodeBS
174
175isTrueFalse' :: ConfigValue -> Maybe Bool
176isTrueFalse' (ConfigValue s)
177	| s' == "yes" = Just True
178	| s' == "on" = Just True
179	| s' == "true" = Just True
180	| s' == "1" = Just True
181
182	| s' == "no" = Just False
183	| s' == "off" = Just False
184	| s' == "false" = Just False
185	| s' == "0" = Just False
186	| s' == "" = Just False
187
188	-- Git treats any number other than 0 as true,
189	-- including negative numbers.
190	| S8.all (\c -> isDigit c || c == '-') s' = Just True
191
192	| otherwise = Nothing
193  where
194	s' = S8.map toLower s
195isTrueFalse' NoConfigValue = Just True
196
197boolConfig :: Bool -> String
198boolConfig True = "true"
199boolConfig False = "false"
200
201boolConfig' :: Bool -> S.ByteString
202boolConfig' True = "true"
203boolConfig' False = "false"
204
205isBare :: Repo -> Bool
206isBare r = fromMaybe False $ isTrueFalse' =<< getMaybe coreBare r
207
208coreBare :: ConfigKey
209coreBare = "core.bare"
210
211{- Runs a command to get the configuration of a repo,
212 - and returns a repo populated with the configuration, as well as the raw
213 - output and the standard error of the command. -}
214fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, String))
215fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go
216  where
217	p = (proc cmd $ toCommand params)
218		{ std_out = CreatePipe
219		, std_err = CreatePipe
220		}
221	go _ (Just hout) (Just herr) pid =
222		withAsync (getstderr pid herr []) $ \errreader -> do
223			val <- S.hGetContents hout
224			err <- wait errreader
225			forceSuccessProcess p pid
226			r' <- store val st r
227			return (r', val, err)
228	go _ _ _ _ = error "internal"
229
230	getstderr pid herr c = hGetLineUntilExitOrEOF pid herr >>= \case
231		Just l -> getstderr pid herr (l:c)
232		Nothing -> return (unlines (reverse c))
233
234{- Reads git config from a specified file and returns the repo populated
235 - with the configuration. -}
236fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, String))
237fromFile r f = fromPipe r "git"
238	[ Param "config"
239	, Param "--file"
240	, File f
241	, Param "--list"
242	] ConfigList
243
244{- Changes a git config setting in the specified config file.
245 - (Creates the file if it does not already exist.) -}
246changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool
247changeFile f (ConfigKey k) v = boolSystem "git"
248	[ Param "config"
249	, Param "--file"
250	, File f
251	, Param (decodeBS k)
252	, Param (decodeBS v)
253	]
254
255{- Unsets a git config setting, in both the git repo,
256 - and the cached config in the Repo.
257 -
258 - If unsetting the config fails, including in a read-only repo, or
259 - when the config is not set, returns Nothing.
260 -}
261unset :: ConfigKey -> Repo -> IO (Maybe Repo)
262unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r)
263	( return $ Just $ r { config = M.delete ck (config r) }
264	, return Nothing
265	)
266  where
267	ps = [Param "config", Param "--unset-all", Param (decodeBS k)]
268