1{- Construction of Git Repo objects 2 - 3 - Copyright 2010-2021 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE OverloadedStrings #-} 9{-# LANGUAGE CPP #-} 10 11module Git.Construct ( 12 fromCwd, 13 fromAbsPath, 14 fromPath, 15 fromUrl, 16 fromUnknown, 17 localToUrl, 18 remoteNamed, 19 remoteNamedFromKey, 20 fromRemotes, 21 fromRemoteLocation, 22 repoAbsPath, 23 checkForRepo, 24 newFrom, 25 adjustGitDirFile, 26) where 27 28#ifndef mingw32_HOST_OS 29import System.Posix.User 30#endif 31import qualified Data.Map as M 32import Network.URI 33 34import Common 35import Git.Types 36import Git 37import Git.Remote 38import Git.FilePath 39import qualified Git.Url as Url 40import Utility.UserInfo 41 42import qualified Data.ByteString as B 43import qualified System.FilePath.ByteString as P 44 45{- Finds the git repository used for the cwd, which may be in a parent 46 - directory. -} 47fromCwd :: IO (Maybe Repo) 48fromCwd = getCurrentDirectory >>= seekUp 49 where 50 seekUp dir = do 51 r <- checkForRepo dir 52 case r of 53 Nothing -> case upFrom (toRawFilePath dir) of 54 Nothing -> return Nothing 55 Just d -> seekUp (fromRawFilePath d) 56 Just loc -> pure $ Just $ newFrom loc 57 58{- Local Repo constructor, accepts a relative or absolute path. -} 59fromPath :: RawFilePath -> IO Repo 60fromPath dir 61 -- When dir == "foo/.git", git looks for "foo/.git/.git", 62 -- and failing that, uses "foo" as the repository. 63 | (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir = 64 ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git") 65 ( ret dir 66 , ret (P.takeDirectory canondir) 67 ) 68 | otherwise = ifM (doesDirectoryExist (fromRawFilePath dir)) 69 ( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom) 70 -- git falls back to dir.git when dir doesn't 71 -- exist, as long as dir didn't end with a 72 -- path separator 73 , if dir == canondir 74 then ret (dir <> ".git") 75 else ret dir 76 ) 77 where 78 ret = pure . newFrom . LocalUnknown 79 canondir = P.dropTrailingPathSeparator dir 80 81{- Local Repo constructor, requires an absolute path to the repo be 82 - specified. -} 83fromAbsPath :: RawFilePath -> IO Repo 84fromAbsPath dir 85 | absoluteGitPath dir = fromPath dir 86 | otherwise = 87 error $ "internal error, " ++ show dir ++ " is not absolute" 88 89{- Construct a Repo for a remote's url. 90 - 91 - Git is somewhat forgiving about urls to repositories, allowing 92 - eg spaces that are not normally allowed unescaped in urls. Such 93 - characters get escaped. 94 - 95 - This will always succeed, even if the url cannot be parsed 96 - or is invalid, because git can also function despite remotes having 97 - such urls, only failing if such a remote is used. 98 -} 99fromUrl :: String -> IO Repo 100fromUrl url 101 | not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url 102 | otherwise = fromUrl' url 103 104fromUrl' :: String -> IO Repo 105fromUrl' url 106 | "file://" `isPrefixOf` url = case parseURI url of 107 Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u 108 Nothing -> pure $ newFrom $ UnparseableUrl url 109 | otherwise = case parseURI url of 110 Just u -> pure $ newFrom $ Url u 111 Nothing -> pure $ newFrom $ UnparseableUrl url 112 113{- Creates a repo that has an unknown location. -} 114fromUnknown :: Repo 115fromUnknown = newFrom Unknown 116 117{- Converts a local Repo into a remote repo, using the reference repo 118 - which is assumed to be on the same host. -} 119localToUrl :: Repo -> Repo -> Repo 120localToUrl reference r 121 | not $ repoIsUrl reference = error "internal error; reference repo not url" 122 | repoIsUrl r = r 123 | otherwise = case (Url.authority reference, Url.scheme reference) of 124 (Just auth, Just s) -> 125 let absurl = concat 126 [ s 127 , "//" 128 , auth 129 , fromRawFilePath (repoPath r) 130 ] 131 in r { location = Url $ fromJust $ parseURI absurl } 132 _ -> r 133 134{- Calculates a list of a repo's configured remotes, by parsing its config. -} 135fromRemotes :: Repo -> IO [Repo] 136fromRemotes repo = catMaybes <$> mapM construct remotepairs 137 where 138 filterconfig f = filter f $ M.toList $ config repo 139 filterkeys f = filterconfig (\(k,_) -> f k) 140 remotepairs = filterkeys isRemoteUrlKey 141 construct (k,v) = remoteNamedFromKey k $ 142 fromRemoteLocation (fromConfigValue v) repo 143 144{- Sets the name of a remote when constructing the Repo to represent it. -} 145remoteNamed :: String -> IO Repo -> IO Repo 146remoteNamed n constructor = do 147 r <- constructor 148 return $ r { remoteName = Just n } 149 150{- Sets the name of a remote based on the git config key, such as 151 - "remote.foo.url". -} 152remoteNamedFromKey :: ConfigKey -> IO Repo -> IO (Maybe Repo) 153remoteNamedFromKey k r = case remoteKeyToRemoteName k of 154 Nothing -> pure Nothing 155 Just n -> Just <$> remoteNamed n r 156 157{- Constructs a new Repo for one of a Repo's remotes using a given 158 - location (ie, an url). -} 159fromRemoteLocation :: String -> Repo -> IO Repo 160fromRemoteLocation s repo = gen $ parseRemoteLocation s repo 161 where 162 gen (RemotePath p) = fromRemotePath p repo 163 gen (RemoteUrl u) = fromUrl u 164 165{- Constructs a Repo from the path specified in the git remotes of 166 - another Repo. -} 167fromRemotePath :: FilePath -> Repo -> IO Repo 168fromRemotePath dir repo = do 169 dir' <- expandTilde dir 170 fromPath $ repoPath repo P.</> toRawFilePath dir' 171 172{- Git remotes can have a directory that is specified relative 173 - to the user's home directory, or that contains tilde expansions. 174 - This converts such a directory to an absolute path. 175 - Note that it has to run on the system where the remote is. 176 -} 177repoAbsPath :: RawFilePath -> IO RawFilePath 178repoAbsPath d = do 179 d' <- expandTilde (fromRawFilePath d) 180 h <- myHomeDir 181 return $ toRawFilePath $ h </> d' 182 183expandTilde :: FilePath -> IO FilePath 184#ifdef mingw32_HOST_OS 185expandTilde = return 186#else 187expandTilde = expandt True 188 where 189 expandt _ [] = return "" 190 expandt _ ('/':cs) = do 191 v <- expandt True cs 192 return ('/':v) 193 expandt True ('~':'/':cs) = do 194 h <- myHomeDir 195 return $ h </> cs 196 expandt True "~" = myHomeDir 197 expandt True ('~':cs) = do 198 let (name, rest) = findname "" cs 199 u <- getUserEntryForName name 200 return $ homeDirectory u </> rest 201 expandt _ (c:cs) = do 202 v <- expandt False cs 203 return (c:v) 204 findname n [] = (n, "") 205 findname n (c:cs) 206 | c == '/' = (n, cs) 207 | otherwise = findname (n++[c]) cs 208#endif 209 210{- Checks if a git repository exists in a directory. Does not find 211 - git repositories in parent directories. -} 212checkForRepo :: FilePath -> IO (Maybe RepoLocation) 213checkForRepo dir = 214 check isRepo $ 215 check (checkGitDirFile (toRawFilePath dir)) $ 216 check isBareRepo $ 217 return Nothing 218 where 219 check test cont = maybe cont (return . Just) =<< test 220 checkdir c = ifM c 221 ( return $ Just $ LocalUnknown $ toRawFilePath dir 222 , return Nothing 223 ) 224 isRepo = checkdir $ 225 gitSignature (".git" </> "config") 226 <||> 227 -- A git-worktree lacks .git/config, but has .git/commondir. 228 -- (Normally the .git is a file, not a symlink, but it can 229 -- be converted to a symlink and git will still work; 230 -- this handles that case.) 231 gitSignature (".git" </> "gitdir") 232 isBareRepo = checkdir $ gitSignature "config" 233 <&&> doesDirectoryExist (dir </> "objects") 234 gitSignature file = doesFileExist $ dir </> file 235 236-- Check for a .git file. 237checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation) 238checkGitDirFile dir = adjustGitDirFile' $ Local 239 { gitdir = dir P.</> ".git" 240 , worktree = Just dir 241 } 242 243-- git-submodule, git-worktree, and --separate-git-dir 244-- make .git be a file pointing to the real git directory. 245-- Detect that, and return a RepoLocation with gitdir pointing 246-- to the real git directory. 247adjustGitDirFile :: RepoLocation -> IO RepoLocation 248adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc 249 250adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation) 251adjustGitDirFile' loc = do 252 let gd = gitdir loc 253 c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd)) 254 if gitdirprefix `isPrefixOf` c 255 then do 256 top <- fromRawFilePath . P.takeDirectory <$> absPath gd 257 return $ Just $ loc 258 { gitdir = absPathFrom 259 (toRawFilePath top) 260 (toRawFilePath 261 (drop (length gitdirprefix) c)) 262 } 263 else return Nothing 264 where 265 gitdirprefix = "gitdir: " 266 267 268newFrom :: RepoLocation -> Repo 269newFrom l = Repo 270 { location = l 271 , config = M.empty 272 , fullconfig = M.empty 273 , remoteName = Nothing 274 , gitEnv = Nothing 275 , gitEnvOverridesGitDir = False 276 , gitGlobalOpts = [] 277 } 278 279