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/Construct.hs | 241 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 241 insertions(+) create mode 100644 Git/Construct.hs (limited to 'Git/Construct.hs') diff --git a/Git/Construct.hs b/Git/Construct.hs new file mode 100644 index 0000000..03dd29f --- /dev/null +++ b/Git/Construct.hs @@ -0,0 +1,241 @@ +{- Construction of Git Repo objects + - + - Copyright 2010-2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Git.Construct ( + fromCwd, + fromAbsPath, + fromPath, + fromUrl, + fromUnknown, + localToUrl, + remoteNamed, + remoteNamedFromKey, + fromRemotes, + fromRemoteLocation, + repoAbsPath, + checkForRepo, + newFrom, +) where + +#ifndef mingw32_HOST_OS +import System.Posix.User +#endif +import qualified Data.Map as M hiding (map, split) +import Network.URI + +import Common +import Git.Types +import Git +import Git.Remote +import Git.FilePath +import qualified Git.Url as Url +import Utility.UserInfo + +{- Finds the git repository used for the cwd, which may be in a parent + - directory. -} +fromCwd :: IO (Maybe Repo) +fromCwd = getCurrentDirectory >>= seekUp + where + seekUp dir = do + r <- checkForRepo dir + case r of + Nothing -> case upFrom dir of + Nothing -> return Nothing + Just d -> seekUp d + Just loc -> pure $ Just $ newFrom loc + +{- Local Repo constructor, accepts a relative or absolute path. -} +fromPath :: FilePath -> IO Repo +fromPath dir = fromAbsPath =<< absPath dir + +{- Local Repo constructor, requires an absolute path to the repo be + - specified. -} +fromAbsPath :: FilePath -> IO Repo +fromAbsPath dir + | absoluteGitPath dir = hunt + | otherwise = + error $ "internal error, " ++ dir ++ " is not absolute" + where + ret = pure . newFrom . LocalUnknown + canondir = dropTrailingPathSeparator dir + {- When dir == "foo/.git", git looks for "foo/.git/.git", + - and failing that, uses "foo" as the repository. -} + hunt + | (pathSeparator:".git") `isSuffixOf` canondir = + ifM (doesDirectoryExist $ dir ".git") + ( ret dir + , ret (takeDirectory canondir) + ) + | otherwise = ifM (doesDirectoryExist dir) + ( ret dir + -- git falls back to dir.git when dir doesn't + -- exist, as long as dir didn't end with a + -- path separator + , if dir == canondir + then ret (dir ++ ".git") + else ret dir + ) + +{- Remote Repo constructor. Throws exception on invalid url. + - + - Git is somewhat forgiving about urls to repositories, allowing + - eg spaces that are not normally allowed unescaped in urls. + -} +fromUrl :: String -> IO Repo +fromUrl url + | not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url + | otherwise = fromUrlStrict url + +fromUrlStrict :: String -> IO Repo +fromUrlStrict url + | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u + | otherwise = pure $ 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 = case Url.authority reference of + Nothing -> r + Just auth -> + let absurl = concat + [ Url.scheme reference + , "//" + , auth + , repoPath r + ] + in r { location = Url $ fromJust $ parseURI absurl } + +{- 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) = remoteNamedFromKey k $ fromRemoteLocation v repo + +{- Sets the name of a remote when constructing the Repo to represent it. -} +remoteNamed :: String -> IO Repo -> IO Repo +remoteNamed n constructor = do + r <- constructor + return $ r { remoteName = Just n } + +{- Sets the name of a remote based on the git config key, such as + - "remote.foo.url". -} +remoteNamedFromKey :: String -> IO Repo -> IO Repo +remoteNamedFromKey k = remoteNamed basename + where + basename = intercalate "." $ + reverse $ drop 1 $ reverse $ drop 1 $ split "." k + +{- 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 $ parseRemoteLocation s repo + where + gen (RemotePath p) = fromRemotePath p repo + gen (RemoteUrl u) = fromUrl u + +{- 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 + fromPath $ repoPath 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 +#ifdef mingw32_HOST_OS +expandTilde = return +#else +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 +#endif + +{- Checks if a git repository exists in a directory. Does not find + - git repositories in parent directories. -} +checkForRepo :: FilePath -> IO (Maybe RepoLocation) +checkForRepo dir = + check isRepo $ + check gitDirFile $ + check isBareRepo $ + return Nothing + where + check test cont = maybe cont (return . Just) =<< test + checkdir c = ifM c + ( return $ Just $ LocalUnknown dir + , return Nothing + ) + isRepo = checkdir $ gitSignature $ ".git" "config" + isBareRepo = checkdir $ gitSignature "config" + <&&> doesDirectoryExist (dir "objects") + gitDirFile = do + c <- firstLine <$> + catchDefaultIO "" (readFile $ dir ".git") + return $ if gitdirprefix `isPrefixOf` c + then Just $ Local + { gitdir = absPathFrom dir $ + drop (length gitdirprefix) c + , worktree = Just dir + } + else Nothing + where + gitdirprefix = "gitdir: " + gitSignature file = doesFileExist $ dir file + +newFrom :: RepoLocation -> Repo +newFrom l = Repo + { location = l + , config = M.empty + , fullconfig = M.empty + , remotes = [] + , remoteName = Nothing + , gitEnv = Nothing + , gitGlobalOpts = [] + } + -- cgit v1.2.3