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