From 7c12f0ac9224246dac308e837bccb5b2157062ee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 15 Dec 2015 17:47:59 -0700 Subject: Import git-repair_1.20151215.orig.tar.xz [dgit import orig git-repair_1.20151215.orig.tar.xz] --- Git/Config.hs | 210 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 210 insertions(+) create mode 100644 Git/Config.hs (limited to 'Git/Config.hs') diff --git a/Git/Config.hs b/Git/Config.hs new file mode 100644 index 0000000..3d62395 --- /dev/null +++ b/Git/Config.hs @@ -0,0 +1,210 @@ +{- git repository configuration handling + - + - Copyright 2010-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Config where + +import qualified Data.Map as M +import Data.Char + +import Common +import Git +import Git.Types +import qualified Git.Construct +import qualified Git.Command +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 <- withHandle StdoutHandle createProcessSuccess p $ + hRead (Git.Construct.fromUnknown) + 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 = ifM (doesDirectoryExist dotgit) + ( updateLocation' r $ Local dotgit Nothing + , updateLocation' r $ Local d Nothing + ) + | otherwise = updateLocation' r $ Local dotgit (Just d) + where + dotgit = (d ".git") +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 + +boolConfig :: Bool -> String +boolConfig True = "true" +boolConfig False = "false" + +isBare :: Repo -> Bool +isBare r = fromMaybe False $ isTrue =<< getMaybe coreBare r + +coreBare :: String +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 of the command. -} +fromPipe :: Repo -> String -> [CommandParam] -> IO (Either SomeException (Repo, String)) +fromPipe r cmd params = try $ + withHandle StdoutHandle createProcessSuccess p $ \h -> do + fileEncoding h + val <- hGetContentsStrict h + r' <- store val r + return (r', val) + where + p = proc cmd $ toCommand params + +{- Reads git config from a specified file and returns the repo populated + - with the configuration. -} +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, String)) +fromFile r f = fromPipe r "git" + [ Param "config" + , Param "--file" + , File f + , Param "--list" + ] + +{- Changes a git config setting in the specified config file. + - (Creates the file if it does not already exist.) -} +changeFile :: FilePath -> String -> String -> IO Bool +changeFile f k v = boolSystem "git" + [ Param "config" + , Param "--file" + , File f + , Param k + , Param 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 :: String -> Repo -> IO (Maybe Repo) +unset k r = ifM (Git.Command.runBool ps r) + ( return $ Just $ r { config = M.delete k (config r) } + , return Nothing + ) + where + ps = [Param "config", Param "--unset-all", Param k] -- cgit v1.2.3