Merge from git-annex.

1 files changed, 61 insertions, 36 deletions

diff --git a/Git/Construct.hs b/Git/Construct.hs
index 5b656eb..8b63ac4 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -1,10 +1,11 @@
 {- Construction of Git Repo objects
  -
- - Copyright 2010-2012 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 
 module Git.Construct (
@@ -21,6 +22,7 @@ module Git.Construct (
 	repoAbsPath,
 	checkForRepo,
 	newFrom,
+	adjustGitDirFile,
 ) where
 
 #ifndef mingw32_HOST_OS
@@ -37,6 +39,9 @@ import Git.FilePath
 import qualified Git.Url as Url
 import Utility.UserInfo
 
+import qualified Data.ByteString as B
+import qualified System.FilePath.ByteString as P
+
 {- Finds the git repository used for the cwd, which may be in a parent
  - directory. -}
 fromCwd :: IO (Maybe Repo)
@@ -45,40 +50,40 @@ fromCwd = getCurrentDirectory >>= seekUp
 	seekUp dir = do
 		r <- checkForRepo dir
 		case r of
-			Nothing -> case upFrom dir of
+			Nothing -> case upFrom (toRawFilePath dir) of
 				Nothing -> return Nothing
-				Just d -> seekUp d
+				Just d -> seekUp (fromRawFilePath d)
 			Just loc -> pure $ Just $ newFrom loc
 
 {- Local Repo constructor, accepts a relative or absolute path. -}
-fromPath :: FilePath -> IO Repo
+fromPath :: RawFilePath -> IO Repo
 fromPath dir = fromAbsPath =<< absPath dir
 
 {- Local Repo constructor, requires an absolute path to the repo be
  - specified. -}
-fromAbsPath :: FilePath -> IO Repo
+fromAbsPath :: RawFilePath -> IO Repo
 fromAbsPath dir
-	| absoluteGitPath (encodeBS dir) = hunt
+	| absoluteGitPath dir = hunt
 	| otherwise =
-		error $ "internal error, " ++ dir ++ " is not absolute"
+		error $ "internal error, " ++ show dir ++ " is not absolute"
   where
-	ret = pure . newFrom . LocalUnknown . toRawFilePath
-	canondir = dropTrailingPathSeparator dir
+	ret = pure . newFrom . LocalUnknown
+	canondir = P.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")
+		| (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =
+			ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")
 				( ret dir
-				, ret (takeDirectory canondir)
+				, ret (P.takeDirectory canondir)
 				)
-		| otherwise = ifM (doesDirectoryExist dir)
-			( ret dir
+		| otherwise = ifM (doesDirectoryExist (fromRawFilePath dir))
+			( checkGitDirFile dir >>= maybe (ret dir) (pure . newFrom)
 			-- 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")
+				then ret (dir <> ".git")
 				else ret dir
 			)
 
@@ -94,7 +99,8 @@ fromUrl url
 
 fromUrlStrict :: String -> IO Repo
 fromUrlStrict url
-	| "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u
+	| "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $
+		unEscapeString $ uriPath u
 	| otherwise = pure $ newFrom $ Url u
   where
 	u = fromMaybe bad $ parseURI url
@@ -128,7 +134,8 @@ fromRemotes repo = mapM construct remotepairs
 	filterconfig f = filter f $ M.toList $ config repo
 	filterkeys f = filterconfig (\(k,_) -> f k)
 	remotepairs = filterkeys isRemoteKey
-	construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo)
+	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
@@ -154,18 +161,18 @@ fromRemoteLocation s repo = gen $ parseRemoteLocation s repo
 fromRemotePath :: FilePath -> Repo -> IO Repo
 fromRemotePath dir repo = do
 	dir' <- expandTilde dir
-	fromPath $ fromRawFilePath (repoPath repo) </> dir'
+	fromPath $ repoPath repo P.</> toRawFilePath 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 :: RawFilePath -> IO RawFilePath
 repoAbsPath d = do
-	d' <- expandTilde d
+	d' <- expandTilde (fromRawFilePath d)
 	h <- myHomeDir
-	return $ h </> d'
+	return $ toRawFilePath $ h </> d'
 
 expandTilde :: FilePath -> IO FilePath
 #ifdef mingw32_HOST_OS
@@ -198,7 +205,7 @@ expandTilde = expandt True
 checkForRepo :: FilePath -> IO (Maybe RepoLocation)
 checkForRepo dir = 
 	check isRepo $
-		check gitDirFile $
+		check (checkGitDirFile (toRawFilePath dir)) $
 			check isBareRepo $
 				return Nothing
   where
@@ -217,22 +224,40 @@ checkForRepo dir =
 		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 = toRawFilePath $ absPathFrom dir $
-					drop (length gitdirprefix) c
-				, worktree = Just (toRawFilePath dir)
-				}
-			else Nothing
-	  where
-		gitdirprefix = "gitdir: "
 	gitSignature file = doesFileExist $ dir </> file
 
+-- Check for a .git file.
+checkGitDirFile :: RawFilePath -> IO (Maybe RepoLocation)
+checkGitDirFile dir = adjustGitDirFile' $ Local 
+	{ gitdir = dir P.</> ".git"
+	, worktree = Just dir
+	}
+
+-- git-submodule, git-worktree, and --separate-git-dir
+-- make .git be a file pointing to the real git directory.
+-- Detect that, and return a RepoLocation with gitdir pointing 
+-- to the real git directory.
+adjustGitDirFile :: RepoLocation -> IO RepoLocation
+adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc
+
+adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation)
+adjustGitDirFile' loc = do
+	let gd = gitdir loc
+	c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd))
+	if gitdirprefix `isPrefixOf` c
+		then do
+			top <- fromRawFilePath . P.takeDirectory <$> absPath gd
+			return $ Just $ loc
+				{ gitdir = absPathFrom 
+					(toRawFilePath top)
+					(toRawFilePath 
+						(drop (length gitdirprefix) c))
+				}
+		else return Nothing
+ where
+	gitdirprefix = "gitdir: "
+
+
 newFrom :: RepoLocation -> Repo
 newFrom l = Repo
 	{ location = l