From 13fff71f2019ae098c3f8532ac2734cb1ab11498 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 13 Dec 2011 15:05:07 -0400 Subject: split out three modules from Git Constructors and configuration make sense in separate modules. A separate Git.Types is needed to avoid cycles. --- Git/Config.hs | 58 ++++++++++++++++ Git/Construct.hs | 198 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ Git/Types.hs | 36 ++++++++++ 3 files changed, 292 insertions(+) create mode 100644 Git/Config.hs create mode 100644 Git/Construct.hs create mode 100644 Git/Types.hs (limited to 'Git') diff --git a/Git/Config.hs b/Git/Config.hs new file mode 100644 index 000000000..5f0e3fdc2 --- /dev/null +++ b/Git/Config.hs @@ -0,0 +1,58 @@ +{- git repository configuration handling + - + - Copyright 2010,2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Config ( + get, + read, + hRead, + store +) where + +import Prelude hiding (read) +import System.Posix.Directory +import Control.Exception (bracket_) +import qualified Data.Map as M + +import Common +import Git +import Git.Types +import qualified Git.Construct + +{- 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) + +{- Runs git config and populates a repo with its config. -} +read :: Repo -> IO Repo +read repo@(Repo { location = Dir d }) = do + {- Cannot use pipeRead because it relies on the config having + been already read. Instead, chdir to the repo. -} + cwd <- getCurrentDirectory + bracket_ (changeWorkingDirectory d) (changeWorkingDirectory cwd) $ + pOpen ReadFromPipe "git" ["config", "--list"] $ hRead repo +read r = assertLocal r $ error "internal" + +{- Reads git config from a handle and populates a repo with it. -} +hRead :: Repo -> Handle -> IO Repo +hRead repo h = do + 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 inrementally. -} +store :: String -> Repo -> IO Repo +store s repo = do + let repo' = repo { config = parse s `M.union` config repo } + rs <- Git.Construct.fromRemotes repo' + return $ repo' { remotes = rs } + +{- Parses git config --list output into a config map. -} +parse :: String -> M.Map String String +parse s = M.fromList $ map pair $ lines s + where + pair = separate (== '=') diff --git a/Git/Construct.hs b/Git/Construct.hs new file mode 100644 index 000000000..9149ab9ec --- /dev/null +++ b/Git/Construct.hs @@ -0,0 +1,198 @@ +{- Construction of Git Repo objects + - + - Copyright 2010,2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Construct ( + fromCwd, + fromAbsPath, + fromUrl, + fromUnknown, + localToUrl, + fromRemotes, + fromRemoteLocation, + repoAbsPath, +) where + +import System.Posix.User +import qualified Data.Map as M hiding (map, split) +import Network.URI + +import Common +import Git.Types +import Git + +{- Finds the current git repository, which may be in a parent directory. -} +fromCwd :: IO Repo +fromCwd = getCurrentDirectory >>= seekUp isRepoTop >>= maybe norepo makerepo + where + makerepo = return . newFrom . Dir + norepo = error "Not in a git repository." + +{- Local Repo constructor, requires an absolute path to the repo be + - specified. -} +fromAbsPath :: FilePath -> IO Repo +fromAbsPath dir + | "/" `isPrefixOf` dir = do + -- Git always looks for "dir.git" in preference to + -- to "dir", even if dir ends in a "/". + let canondir = dropTrailingPathSeparator dir + let dir' = canondir ++ ".git" + e <- doesDirectoryExist dir' + if e + then ret dir' + else if "/.git" `isSuffixOf` canondir + then do + -- When dir == "foo/.git", git looks + -- for "foo/.git/.git", and failing + -- that, uses "foo" as the repository. + e' <- doesDirectoryExist $ dir ".git" + if e' + then ret dir + else ret $ takeDirectory canondir + else ret dir + | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" + where + ret = return . newFrom . Dir + +{- Remote Repo constructor. Throws exception on invalid url. -} +fromUrl :: String -> IO Repo +fromUrl url + | startswith "file://" url = fromAbsPath $ uriPath u + | otherwise = return $ newFrom $ Url u + where + u = fromMaybe bad $ parseURI url + bad = error $ "bad url " ++ url + +{- Creates a repo that has an unknown location. -} +fromUnknown :: Repo +fromUnknown = newFrom Unknown + +{- Converts a local Repo into a remote repo, using the reference repo + - which is assumed to be on the same host. -} +localToUrl :: Repo -> Repo -> Repo +localToUrl reference r + | not $ repoIsUrl reference = error "internal error; reference repo not url" + | repoIsUrl r = r + | otherwise = r { location = Url $ fromJust $ parseURI absurl } + where + absurl = + urlScheme reference ++ "//" ++ + urlAuthority reference ++ + workTree r + +{- Calculates a list of a repo's configured remotes, by parsing its config. -} +fromRemotes :: Repo -> IO [Repo] +fromRemotes repo = mapM construct remotepairs + where + filterconfig f = filter f $ M.toList $ config repo + filterkeys f = filterconfig (\(k,_) -> f k) + remotepairs = filterkeys isremote + isremote k = startswith "remote." k && endswith ".url" k + construct (k,v) = repoRemoteNameFromKey k <$> fromRemoteLocation v repo + +{- Constructs a new Repo for one of a Repo's remotes using a given + - location (ie, an url). -} +fromRemoteLocation :: String -> Repo -> IO Repo +fromRemoteLocation s repo = gen $ calcloc s + where + filterconfig f = filter f $ M.toList $ config repo + gen v + | scpstyle v = fromUrl $ scptourl v + | isURI v = fromUrl v + | otherwise = fromRemotePath v repo + -- insteadof config can rewrite remote location + calcloc l + | null insteadofs = l + | otherwise = replacement ++ drop (length bestvalue) l + where + replacement = drop (length prefix) $ + take (length bestkey - length suffix) bestkey + (bestkey, bestvalue) = maximumBy longestvalue insteadofs + longestvalue (_, a) (_, b) = compare b a + insteadofs = filterconfig $ \(k, v) -> + startswith prefix k && + endswith suffix k && + startswith v l + (prefix, suffix) = ("url." , ".insteadof") + -- git remotes can be written scp style -- [user@]host:dir + scpstyle v = ":" `isInfixOf` v && not ("//" `isInfixOf` v) + scptourl v = "ssh://" ++ host ++ slash dir + where + (host, dir) = separate (== ':') v + slash d | d == "" = "/~/" ++ d + | "/" `isPrefixOf` d = d + | "~" `isPrefixOf` d = '/':d + | otherwise = "/~/" ++ d + +{- Constructs a Repo from the path specified in the git remotes of + - another Repo. -} +fromRemotePath :: FilePath -> Repo -> IO Repo +fromRemotePath dir repo = do + dir' <- expandTilde dir + fromAbsPath $ workTree repo dir' + +{- Git remotes can have a directory that is specified relative + - to the user's home directory, or that contains tilde expansions. + - This converts such a directory to an absolute path. + - Note that it has to run on the system where the remote is. + -} +repoAbsPath :: FilePath -> IO FilePath +repoAbsPath d = do + d' <- expandTilde d + h <- myHomeDir + return $ h d' + +expandTilde :: FilePath -> IO FilePath +expandTilde = expandt True + where + expandt _ [] = return "" + expandt _ ('/':cs) = do + v <- expandt True cs + return ('/':v) + expandt True ('~':'/':cs) = do + h <- myHomeDir + return $ h cs + expandt True ('~':cs) = do + let (name, rest) = findname "" cs + u <- getUserEntryForName name + return $ homeDirectory u rest + expandt _ (c:cs) = do + v <- expandt False cs + return (c:v) + findname n [] = (n, "") + findname n (c:cs) + | c == '/' = (n, cs) + | otherwise = findname (n++[c]) cs + +seekUp :: (FilePath -> IO Bool) -> FilePath -> IO (Maybe FilePath) +seekUp want dir = do + ok <- want dir + if ok + then return $ Just dir + else case parentDir dir of + "" -> return Nothing + d -> seekUp want d + +isRepoTop :: FilePath -> IO Bool +isRepoTop dir = do + r <- isRepo + b <- isBareRepo + return (r || b) + where + isRepo = gitSignature ".git" ".git/config" + isBareRepo = gitSignature "objects" "config" + gitSignature subdir file = liftM2 (&&) + (doesDirectoryExist (dir ++ "/" ++ subdir)) + (doesFileExist (dir ++ "/" ++ file)) + +newFrom :: RepoLocation -> Repo +newFrom l = + Repo { + location = l, + config = M.empty, + remotes = [], + remoteName = Nothing + } diff --git a/Git/Types.hs b/Git/Types.hs new file mode 100644 index 000000000..250da5f5e --- /dev/null +++ b/Git/Types.hs @@ -0,0 +1,36 @@ +{- git data types + - + - Copyright 2010,2011 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.Types where + +import Network.URI +import qualified Data.Map as M + +{- There are two types of repositories; those on local disk and those + - accessed via an URL. -} +data RepoLocation = Dir FilePath | Url URI | Unknown + deriving (Show, Eq) + +data Repo = Repo { + location :: RepoLocation, + config :: M.Map String String, + remotes :: [Repo], + -- remoteName holds the name used for this repo in remotes + remoteName :: Maybe String +} deriving (Show, Eq) + +{- A git ref. Can be a sha1, or a branch or tag name. -} +newtype Ref = Ref String + deriving (Eq) + +instance Show Ref where + show (Ref v) = v + +{- Aliases for Ref. -} +type Branch = Ref +type Sha = Ref +type Tag = Ref -- cgit v1.2.3