git-annex-10.20250320: Git/Config.hs

{- git repository configuration handling
 -
 - Copyright 2010-2022 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE OverloadedStrings #-}

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 Control.Concurrent.Async

import Common
import Git
import Git.Types
import qualified Git.Command
import qualified Git.Construct
import Utility.UserInfo
import Utility.Process.Transcript
import Utility.Debug

{- Returns a single git config setting, or a fallback value if not set. -}
get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue
get key fallback repo = M.findWithDefault fallback key (config repo)

{- Returns a list of values. -}
getList :: ConfigKey -> Repo -> [ConfigValue]
getList key repo = maybe [] NE.toList $ M.lookup key (fullconfig repo)

{- Returns a single git config setting, if set. -}
getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue
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
	-- Passing --git-dir changes git's behavior when run in a
	-- repository belonging to another user. When the git directory
	-- was explicitly specified, pass that in order to get the local
	-- git config.
	go Repo { location = Local { gitdir = d } }
		| gitDirSpecifiedExplicitly repo = git_config ["--git-dir=."] d
	-- Run in worktree when there is one, since running in the .git
	-- directory will trigger safe.bareRepository=explicit, even
	-- when not in a bare repository.
	go Repo { location = Local { worktree = Just d } } = git_config [] d
	go Repo { location = Local { gitdir = d } } = git_config [] d
	go Repo { location = LocalUnknown d } = git_config [] d
	go _ = assertLocal repo $ error "internal"
	git_config addparams d = withCreateProcess p (git_config' p)
	  where
		params = addparams ++ explicitrepoparams
			++ ["config", "--null", "--list"]
		p = (proc "git" params)
			{ cwd = Just (fromOsPath d)
			, env = gitEnv repo
			, std_out = CreatePipe 
			}
		explicitrepoparams = if repoPathSpecifiedExplicitly repo 
			then 
				-- Use * rather than d, because git treats
				-- "dir/" differently than "dir" when comparing
				-- for safe.directory purposes.
				[ "-c", "safe.directory=*"
				, "-c", "safe.bareRepository=all" 
				]
			else []
	git_config' p _ (Just hout) _ pid = 
		forceSuccessProcess p pid
			`after`
		hRead repo ConfigNullList hout
	git_config' _ _ _ _ _ = error "internal"

{- Gets the global git config, returning a dummy Repo containing it. -}
global :: IO (Maybe Repo)
global = do
	home <- myHomeDir
	ifM (doesFileExist $ toOsPath home </> literalOsPath ".gitconfig")
		( Just <$> withCreateProcess p go
		, return Nothing
		)
  where
	params = ["config", "--null", "--list", "--global"]
	p = (proc "git" params)
		{ std_out = CreatePipe }
	go _ (Just hout) _ pid = 
		forceSuccessProcess p pid
			`after`
		hRead (Git.Construct.fromUnknown) ConfigNullList hout
	go _ _ _ _ = error "internal"

{- Reads git config from a handle and populates a repo with it. -}
hRead :: Repo -> ConfigStyle -> Handle -> IO Repo
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 (NE.toList v))) 
			(M.toList c))
	storeParsed c 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 :: S.ByteString -> ConfigStyle -> Repo -> IO Repo
store s st = storeParsed (parse s st)

storeParsed :: M.Map ConfigKey (NE.NonEmpty ConfigValue) -> Repo -> IO Repo
storeParsed c repo = updateLocation $ 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
 - the Repo. Config settings can be updated incrementally. -}
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 NE.:| []))
		(fullconfig repo)
	}

{- 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 }) = case isBare r of
	Just True -> ifM (doesDirectoryExist dotgit)
		( updateLocation' r $ Local dotgit Nothing
		, updateLocation' r $ Local d Nothing
		)
	Just False -> mknonbare
	{- core.bare not in config, probably because safe.directory
	 - did not allow reading the config -}
	Nothing -> ifM (Git.Construct.isBareRepo d)
		( mkbare
		, mknonbare
		)
  where
	dotgit = d </> literalOsPath ".git"
	-- git treats eg ~/foo as a bare git repository located in
	-- ~/foo/.git if ~/foo/.git/config has core.bare=true
	mkbare = ifM (doesDirectoryExist dotgit)
		( updateLocation' r $ Local dotgit Nothing
		, updateLocation' r $ Local d Nothing
		)
	mknonbare = updateLocation' r $ Local dotgit (Just d)

updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l
updateLocation r = return r

updateLocation' :: Repo -> RepoLocation -> IO Repo
updateLocation' r l@(Local {}) = do
	l' <- case getMaybe "core.worktree" r of
		Nothing -> return l
		Just (ConfigValue d) -> do
			{- core.worktree is relative to the gitdir -}
			top <- absPath (gitdir l)
			let p = absPathFrom top (toOsPath d)
			return $ l { worktree = Just p }
		Just NoConfigValue -> return l
	return $ r { location = l' }
updateLocation' r l = return r { location = l }

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 (NE.NonEmpty ConfigValue)
parse s st
	| S.null s = M.empty
	| otherwise = case st of
		ConfigList -> sep eq $ S.split nl s
		ConfigNullList -> sep nl $ S.split 0 s
  where
	nl = fromIntegral (ord '\n')
	eq = fromIntegral (ord '=')

	sep c = M.fromListWith (<>)
		. map (\(k,v) -> (ConfigKey k, mkval v NE.:| []))
		. map (S.break (== c))
	
	mkval v 
		| S.null v = NoConfigValue
		| otherwise = ConfigValue (S.drop 1 v)

{- Checks if a string from git config is a true/false value. -}
isTrueFalse :: String -> Maybe Bool
isTrueFalse = isTrueFalse' . ConfigValue . encodeBS

isTrueFalse' :: ConfigValue -> Maybe Bool
isTrueFalse' (ConfigValue s)
	| s' == "yes" = Just True
	| s' == "on" = Just True
	| s' == "true" = Just True
	| s' == "1" = Just True

	| s' == "no" = Just False
	| s' == "off" = Just False
	| s' == "false" = Just False
	| s' == "0" = Just False
	| s' == "" = Just False

	-- Git treats any number other than 0 as true,
	-- including negative numbers.
	| S8.all (\c -> isDigit c || c == '-') s' = Just True

	| otherwise = Nothing
  where
	s' = S8.map toLower s
isTrueFalse' NoConfigValue = Just True

boolConfig :: Bool -> String
boolConfig True = "true"
boolConfig False = "false"

boolConfig' :: Bool -> S.ByteString
boolConfig' True = "true"
boolConfig' False = "false"

{- Note that repoIsLocalBare is often better to use than this. -}
isBare :: Repo -> Maybe Bool
isBare r = isTrueFalse' =<< getMaybe coreBare r

coreBare :: ConfigKey
coreBare = "core.bare"

{- Runs a command to get the configuration of a repo,
 - and returns a repo populated with the configuration, as well as the raw
 - output and the exit status and standard error of the command. -}
fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Repo, S.ByteString, ExitCode, String)
fromPipe r cmd params st = withCreateProcess p go
  where
	p = (proc cmd $ toCommand params)
		{ std_out = CreatePipe
		, std_err = CreatePipe
		}
	go _ (Just hout) (Just herr) pid =
		withAsync (getstderr pid herr []) $ \errreader -> do
			val <- S.hGetContents hout
			err <- wait errreader
			exitcode <- waitForProcess pid
			case exitcode of
				ExitSuccess -> do
					r' <- store val st r
					return (r', val, exitcode, err)
				ExitFailure _ ->
					return (r, val, exitcode, err)
	go _ _ _ _ = error "internal"

	getstderr pid herr c = hGetLineUntilExitOrEOF pid herr >>= \case
		Just l -> getstderr pid herr (l:c)
		Nothing -> return (unlines (reverse c))

{- Reads git config from a specified file and returns the repo populated
 - with the configuration. -}
fromFile :: Repo -> FilePath -> IO (Repo, S.ByteString, ExitCode, String)
fromFile r f = fromPipe r "git"
	[ Param "config"
	, Param "--file"
	, File f
	, Param "--list"
	] ConfigList

{- Changes a git config setting in .git/config. -}
change :: ConfigKey -> S.ByteString -> Repo -> IO Bool
change (ConfigKey k) v = Git.Command.runBool
	[ Param "config"
	, Param (decodeBS k)
	, Param (decodeBS v)
	]

{- Changes a git config setting in the specified config file.
 - (Creates the file if it does not already exist.) -}
changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool
changeFile f (ConfigKey k) v = boolSystem "git"
	[ Param "config"
	, Param "--file"
	, File f
	, Param (decodeBS k)
	, Param (decodeBS v)
	]

{- Unsets a git config setting, in both the git repo,
 - and the cached config in the Repo.
 -
 - If unsetting the config fails, including in a read-only repo, or
 - when the config is not set, returns Nothing.
 -}
unset :: ConfigKey -> Repo -> IO (Maybe Repo)
unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r)
	( return $ Just $ r { config = M.delete ck (config r) }
	, return Nothing
	)
  where
	ps = [Param "config", Param "--unset-all", Param (decodeBS k)]

{- git "fixed" CVE-2022-24765 by preventing git-config from
 - listing per-repo configs when the repo is not owned by
 - the current user. Detect if this fix is in effect for the
 - repo.
 -}
checkRepoConfigInaccessible :: Repo -> IO Bool
checkRepoConfigInaccessible r
	-- When --git-dir or GIT_DIR is used to specify the git
	-- directory, git does not check for CVE-2022-24765.
	| gitDirSpecifiedExplicitly r = return False
	| otherwise = do
		-- Cannot use gitCommandLine here because specifying --git-dir
		-- will bypass the git security check.
		let p = (proc "git" ["config", "--local", "--list"])
			{ cwd = Just (fromOsPath (repoPath r))
			, env = gitEnv r
			}
		(out, ok) <- processTranscript' p Nothing
		if not ok
			then do
				debug (DebugSource "Git.Config") ("config output: " ++ out)
				return True
			else return False