diff options
Diffstat (limited to 'Git/Construct.hs')
| -rw-r--r-- | Git/Construct.hs | 40 |
1 files changed, 22 insertions, 18 deletions
diff --git a/Git/Construct.hs b/Git/Construct.hs index 4ad74fd..5b656eb 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE CPP #-} @@ -58,11 +58,11 @@ fromPath dir = fromAbsPath =<< absPath dir - specified. -} fromAbsPath :: FilePath -> IO Repo fromAbsPath dir - | absoluteGitPath dir = hunt + | absoluteGitPath (encodeBS dir) = hunt | otherwise = error $ "internal error, " ++ dir ++ " is not absolute" where - ret = pure . newFrom . LocalUnknown + ret = pure . newFrom . LocalUnknown . toRawFilePath canondir = dropTrailingPathSeparator dir {- When dir == "foo/.git", git looks for "foo/.git/.git", - and failing that, uses "foo" as the repository. -} @@ -117,7 +117,7 @@ localToUrl reference r [ Url.scheme reference , "//" , auth - , repoPath r + , fromRawFilePath (repoPath r) ] in r { location = Url $ fromJust $ parseURI absurl } @@ -127,9 +127,8 @@ 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 = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k - construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo + remotepairs = filterkeys isRemoteKey + construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo) {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo @@ -139,11 +138,8 @@ remoteNamed n constructor = do {- 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 $ splitc '.' k +remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo +remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} @@ -158,7 +154,7 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo fromRemotePath :: FilePath -> Repo -> IO Repo fromRemotePath dir repo = do dir' <- expandTilde dir - fromPath $ repoPath repo </> dir' + fromPath $ fromRawFilePath (repoPath repo) </> dir' {- Git remotes can have a directory that is specified relative - to the user's home directory, or that contains tilde expansions. @@ -208,20 +204,29 @@ checkForRepo dir = where check test cont = maybe cont (return . Just) =<< test checkdir c = ifM c - ( return $ Just $ LocalUnknown dir + ( return $ Just $ LocalUnknown $ toRawFilePath dir , return Nothing ) - isRepo = checkdir $ gitSignature $ ".git" </> "config" + isRepo = checkdir $ + gitSignature (".git" </> "config") + <||> + -- A git-worktree lacks .git/config, but has .git/commondir. + -- (Normally the .git is a file, not a symlink, but it can + -- be converted to a symlink and git will still work; + -- this handles that case.) + gitSignature (".git" </> "gitdir") isBareRepo = checkdir $ gitSignature "config" <&&> doesDirectoryExist (dir </> "objects") gitDirFile = do + -- git-submodule, git-worktree, and --separate-git-dir + -- make .git be a file pointing to the real git directory. c <- firstLine <$> catchDefaultIO "" (readFile $ dir </> ".git") return $ if gitdirprefix `isPrefixOf` c then Just $ Local - { gitdir = absPathFrom dir $ + { gitdir = toRawFilePath $ absPathFrom dir $ drop (length gitdirprefix) c - , worktree = Just dir + , worktree = Just (toRawFilePath dir) } else Nothing where @@ -233,7 +238,6 @@ newFrom l = Repo { location = l , config = M.empty , fullconfig = M.empty - , remotes = [] , remoteName = Nothing , gitEnv = Nothing , gitEnvOverridesGitDir = False |