merge from git-annex

Fixes 2 bugs, one a data loss bug. It is possible to get those fixes
without merging all the other changes, if a backport is wanted.

12 files changed, 278 insertions, 150 deletions

diff --git a/Git/Branch.hs b/Git/Branch.hs
index fcae905..54af101 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -1,6 +1,6 @@
 {- git branch stuff
  -
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -166,7 +166,7 @@ commitCommand' runner commitmode ps = runner $
  -}
 commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
 commit commitmode allowempty message branch parentrefs repo = do
-	tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo
+	tree <- writeTree repo
 	ifM (cancommit tree)
 		( do
 			sha <- commitTree commitmode message parentrefs tree repo
@@ -185,6 +185,19 @@ commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
 commitAlways commitmode message branch parentrefs repo = fromJust
 	<$> commit commitmode True message branch parentrefs repo
 
+-- Throws exception if the index is locked, with an error message output by
+-- git on stderr.
+writeTree :: Repo -> IO Sha
+writeTree repo = getSha "write-tree" $
+	pipeReadStrict [Param "write-tree"] repo
+
+-- Avoids error output if the command fails due to eg, the index being locked.
+writeTreeQuiet :: Repo -> IO (Maybe Sha)
+writeTreeQuiet repo = extractSha <$> withNullHandle go
+  where
+	go nullh = pipeReadStrict' (\p -> p { std_err = UseHandle nullh }) 
+		[Param "write-tree"] repo
+
 commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha
 commitTree commitmode message parentrefs tree repo =
 	getSha "commit-tree" $
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index 6bea8c0..b9f8305 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -326,7 +326,7 @@ catObjectStream repo a = withCatFileStream False repo go
 		(hClose hin)
 		(catObjectReader readObjectContent c hout)
 	feeder c h (v, ref) = do
-		liftIO $ writeChan c (ref, v)
+		writeChan c (ref, v)
 		S8.hPutStrLn h (fromRef' ref)
 
 catObjectMetaDataStream
diff --git a/Git/Command.hs b/Git/Command.hs
index fef7eb9..2358b17 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -70,17 +70,15 @@ pipeReadLazy params repo = assertLocal repo $ do
  - Nonzero exit status is ignored.
  -}
 pipeReadStrict :: [CommandParam] -> Repo -> IO S.ByteString
-pipeReadStrict = pipeReadStrict' S.hGetContents
+pipeReadStrict = pipeReadStrict' id
 
-{- The reader action must be strict. -}
-pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a
-pipeReadStrict' reader params repo = assertLocal repo $ withCreateProcess p go
+pipeReadStrict' :: (CreateProcess -> CreateProcess) -> [CommandParam] -> Repo -> IO S.ByteString
+pipeReadStrict' fp params repo = assertLocal repo $ withCreateProcess p go
   where
-	p  = (gitCreateProcess params repo)
-		{ std_out = CreatePipe }
+	p = fp (gitCreateProcess params repo) { std_out = CreatePipe }
 
 	go _ (Just outh) _ pid = do
-		output <- reader outh
+		output <- S.hGetContents outh
 		hClose outh
 		void $ waitForProcess pid
 		return output
diff --git a/Git/Construct.hs b/Git/Construct.hs
index 8b63ac4..c013eb2 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -1,6 +1,6 @@
 {- Construction of Git Repo objects
  -
- - Copyright 2010-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -57,54 +57,58 @@ fromCwd = getCurrentDirectory >>= seekUp
 
 {- Local Repo constructor, accepts a relative or absolute path. -}
 fromPath :: RawFilePath -> IO Repo
-fromPath dir = fromAbsPath =<< absPath dir
+fromPath dir
+	-- When dir == "foo/.git", git looks for "foo/.git/.git",
+	-- and failing that, uses "foo" as the repository.
+	| (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =
+		ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")
+			( ret dir
+			, ret (P.takeDirectory canondir)
+			)
+	| 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")
+			else ret dir
+		)
+  where
+	ret = pure . newFrom . LocalUnknown
+	canondir = P.dropTrailingPathSeparator dir
 
 {- Local Repo constructor, requires an absolute path to the repo be
  - specified. -}
 fromAbsPath :: RawFilePath -> IO Repo
 fromAbsPath dir
-	| absoluteGitPath dir = hunt
+	| absoluteGitPath dir = fromPath dir
 	| otherwise =
 		error $ "internal error, " ++ show dir ++ " is not absolute"
-  where
-	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
-		| (P.pathSeparator `B.cons` ".git") `B.isSuffixOf` canondir =
-			ifM (doesDirectoryExist $ fromRawFilePath dir </> ".git")
-				( ret dir
-				, ret (P.takeDirectory canondir)
-				)
-		| 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")
-				else ret dir
-			)
 
-{- Remote Repo constructor. Throws exception on invalid url.
+{- Construct a Repo for a remote's url.
  -
  - Git is somewhat forgiving about urls to repositories, allowing
- - eg spaces that are not normally allowed unescaped in urls.
+ - eg spaces that are not normally allowed unescaped in urls. Such
+ - characters get escaped.
+ -
+ - This will always succeed, even if the url cannot be parsed
+ - or is invalid, because git can also function despite remotes having
+ - such urls, only failing if such a remote is used.
  -}
 fromUrl :: String -> IO Repo
 fromUrl url
-	| not (isURI url) = fromUrlStrict $ escapeURIString isUnescapedInURI url
-	| otherwise = fromUrlStrict url
+	| not (isURI url) = fromUrl' $ escapeURIString isUnescapedInURI url
+	| otherwise = fromUrl' url
 
-fromUrlStrict :: String -> IO Repo
-fromUrlStrict url
-	| "file://" `isPrefixOf` url = fromAbsPath $ toRawFilePath $
-		unEscapeString $ uriPath u
-	| otherwise = pure $ newFrom $ Url u
-  where
-	u = fromMaybe bad $ parseURI url
-	bad = error $ "bad url " ++ url
+fromUrl' :: String -> IO Repo
+fromUrl' url
+	| "file://" `isPrefixOf` url = case parseURI url of
+		Just u -> fromAbsPath $ toRawFilePath $ unEscapeString $ uriPath u
+		Nothing -> pure $ newFrom $ UnparseableUrl url
+	| otherwise = case parseURI url of
+		Just u -> pure $ newFrom $ Url u
+		Nothing -> pure $ newFrom $ UnparseableUrl url
 
 {- Creates a repo that has an unknown location. -}
 fromUnknown :: Repo
@@ -116,24 +120,24 @@ 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 -> 
+	| otherwise = case (Url.authority reference, Url.scheme reference) of
+		(Just auth, Just s) -> 
 			let absurl = concat
-				[ Url.scheme reference
+				[ s
 				, "//"
 				, auth
 				, fromRawFilePath (repoPath r)
 				]
 			in r { location = Url $ fromJust $ parseURI absurl }
+		_ -> r
 
 {- Calculates a list of a repo's configured remotes, by parsing its config. -}
 fromRemotes :: Repo -> IO [Repo]
-fromRemotes repo = mapM construct remotepairs
+fromRemotes repo = catMaybes <$> mapM construct remotepairs
   where
 	filterconfig f = filter f $ M.toList $ config repo
 	filterkeys f = filterconfig (\(k,_) -> f k)
-	remotepairs = filterkeys isRemoteKey
+	remotepairs = filterkeys isRemoteUrlKey
 	construct (k,v) = remoteNamedFromKey k $
 		fromRemoteLocation (fromConfigValue v) repo
 
@@ -145,8 +149,10 @@ remoteNamed n constructor = do
 
 {- Sets the name of a remote based on the git config key, such as
  - "remote.foo.url". -}
-remoteNamedFromKey :: ConfigKey -> IO Repo -> IO Repo
-remoteNamedFromKey = remoteNamed . remoteKeyToRemoteName
+remoteNamedFromKey :: ConfigKey -> IO Repo -> IO (Maybe Repo)
+remoteNamedFromKey k r = case remoteKeyToRemoteName k of
+	Nothing -> pure Nothing
+	Just n -> Just <$> remoteNamed n r
 
 {- Constructs a new Repo for one of a Repo's remotes using a given
  - location (ie, an url). -}
@@ -187,6 +193,7 @@ expandTilde = expandt True
 	expandt True ('~':'/':cs) = do
 		h <- myHomeDir
 		return $ h </> cs
+	expandt True "~" = myHomeDir
 	expandt True ('~':cs) = do
 		let (name, rest) = findname "" cs
 		u <- getUserEntryForName name
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index 25bdc5c..9261eab 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -10,6 +10,7 @@
 module Git.CurrentRepo where
 
 import Common
+import Git
 import Git.Types
 import Git.Construct
 import qualified Git.Config
@@ -46,12 +47,12 @@ get = do
 	wt <- maybe (worktree (location r)) Just
 		<$> getpathenvprefix "GIT_WORK_TREE" prefix
 	case wt of
-		Nothing -> return r
+		Nothing -> relPath r
 		Just d -> do
 			curr <- R.getCurrentDirectory
 			unless (d `dirContains` curr) $
 				setCurrentDirectory (fromRawFilePath d)
-			return $ addworktree wt r
+			relPath $ addworktree wt r
   where
 	getpathenv s = do
 		v <- getEnv s
diff --git a/Git/Env.hs b/Git/Env.hs
new file mode 100644
index 0000000..fb0377f
--- /dev/null
+++ b/Git/Env.hs
@@ -0,0 +1,52 @@
+{- Adjusting the environment while running git commands.
+ -
+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module Git.Env where
+
+import Common
+import Git
+import Git.Types
+import Utility.Env
+
+{- Adjusts the gitEnv of a Repo. Copies the system environment if the repo
+ - does not have any gitEnv yet. -}
+adjustGitEnv :: Repo -> ([(String, String)] -> [(String, String)]) -> IO Repo
+adjustGitEnv g adj = do
+	e <- maybe getEnvironment return (gitEnv g)
+	let e' = adj e
+	return $ g { gitEnv = Just e' }
+  where
+
+addGitEnv :: Repo -> String -> String -> IO Repo
+addGitEnv g var val = adjustGitEnv g (addEntry var val)
+
+{- Environment variables to use when running a command.
+ - Includes GIT_DIR pointing at the repo, and GIT_WORK_TREE when the repo
+ - is not bare. Also includes anything added to the Repo's gitEnv,
+ - and a copy of the rest of the system environment. -}
+propGitEnv :: Repo -> IO [(String, String)]
+propGitEnv g = do
+	g' <- addGitEnv g "GIT_DIR" (fromRawFilePath (localGitDir g))
+	g'' <- maybe (pure g')
+		(addGitEnv g' "GIT_WORK_TREE" . fromRawFilePath)
+		(repoWorkTree g)
+	return $ fromMaybe [] (gitEnv g'')
+
+{- Use with any action that makes a commit to set metadata. -}
+commitWithMetaData :: CommitMetaData -> CommitMetaData -> (Repo -> IO a) -> Repo -> IO a
+commitWithMetaData authormetadata committermetadata a g =
+	a =<< adjustGitEnv g adj
+  where
+	adj = mkadj "AUTHOR" authormetadata
+		. mkadj "COMMITTER" committermetadata
+	mkadj p md = go "NAME" commitName
+		. go "EMAIL" commitEmail
+		. go "DATE" commitDate
+	  where
+		go s getv = case getv md of
+			Nothing -> id
+			Just v -> addEntry ("GIT_" ++ p ++ "_" ++ s) v
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index cd0d406..a49c4ea 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -1,13 +1,14 @@
 {- git ls-tree interface
  -
- - Copyright 2011-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
 module Git.LsTree (
 	TreeItem(..),
-	LsTreeMode(..),
+	LsTreeRecursive(..),
+	LsTreeLong(..),
 	lsTree,
 	lsTree',
 	lsTreeStrict,
@@ -27,6 +28,7 @@ import Utility.Attoparsec
 
 import Numeric
 import Data.Either
+import Data.Char
 import System.Posix.Types
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
@@ -38,44 +40,55 @@ data TreeItem = TreeItem
 	{ mode :: FileMode
 	, typeobj :: S.ByteString
 	, sha :: Ref
+	, size :: Maybe FileSize
 	, file :: TopFilePath
+	-- ^ only available when long is used
 	} deriving (Show)
 
-data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive
+data LsTreeRecursive = LsTreeRecursive | LsTreeNonRecursive
+
+{- Enabling --long also gets the size of tree items.
+ - This slows down ls-tree some, since it has to look up the size of each
+ - blob.
+ -}
+data LsTreeLong = LsTreeLong Bool
 
 {- Lists the contents of a tree, with lazy output. -}
-lsTree :: LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
+lsTree :: LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO ([TreeItem], IO Bool)
 lsTree = lsTree' []
 
-lsTree' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO ([TreeItem], IO Bool)
-lsTree' ps lsmode t repo = do
-	(l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo
-	return (rights (map parseLsTree l), cleanup)
+lsTree' :: [CommandParam] -> LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO ([TreeItem], IO Bool)
+lsTree' ps recursive long t repo = do
+	(l, cleanup) <- pipeNullSplit (lsTreeParams recursive long t ps) repo
+	return (rights (map (parseLsTree long) l), cleanup)
 
-lsTreeStrict :: LsTreeMode -> Ref -> Repo -> IO [TreeItem]
+lsTreeStrict :: LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO [TreeItem]
 lsTreeStrict = lsTreeStrict' []
 
-lsTreeStrict' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO [TreeItem]
-lsTreeStrict' ps lsmode t repo = rights . map parseLsTreeStrict
-	<$> pipeNullSplitStrict (lsTreeParams lsmode t ps) repo
+lsTreeStrict' :: [CommandParam] -> LsTreeRecursive -> LsTreeLong -> Ref -> Repo -> IO [TreeItem]
+lsTreeStrict' ps recursive long t repo = rights . map (parseLsTreeStrict long)
+	<$> pipeNullSplitStrict (lsTreeParams recursive long t ps) repo
 
-lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam]
-lsTreeParams lsmode r ps =
+lsTreeParams :: LsTreeRecursive -> LsTreeLong -> Ref -> [CommandParam] -> [CommandParam]
+lsTreeParams recursive long r ps =
 	[ Param "ls-tree"
 	, Param "--full-tree"
 	, Param "-z"
-	] ++ recursiveparams ++ ps ++
+	] ++ recursiveparams ++ longparams ++ ps ++
 	[ Param "--"
 	, File $ fromRef r
 	]
   where
-	recursiveparams = case lsmode of
+	recursiveparams = case recursive of
 		LsTreeRecursive -> [ Param "-r" ]
 		LsTreeNonRecursive -> []
+	longparams = case long of
+		LsTreeLong True -> [ Param "--long" ]
+		LsTreeLong False -> []
 
 {- Lists specified files in a tree. -}
-lsTreeFiles :: Ref -> [FilePath] -> Repo -> IO [TreeItem]
-lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict)
+lsTreeFiles :: LsTreeLong -> Ref -> [FilePath] -> Repo -> IO [TreeItem]
+lsTreeFiles long t fs repo = rights . map (parseLsTree long . L.fromStrict)
 	<$> pipeNullSplitStrict ps repo
   where
 	ps =
@@ -86,41 +99,57 @@ lsTreeFiles t fs repo = rights . map (parseLsTree . L.fromStrict)
 		, File $ fromRef t
 		] ++ map File fs
 
-parseLsTree :: L.ByteString -> Either String TreeItem
-parseLsTree b = case A.parse parserLsTree b of
+parseLsTree :: LsTreeLong -> L.ByteString -> Either String TreeItem
+parseLsTree long b = case A.parse (parserLsTree long) b of
 	A.Done _ r  -> Right r
 	A.Fail _ _ err -> Left err
 
-parseLsTreeStrict :: S.ByteString -> Either String TreeItem
-parseLsTreeStrict b = go (AS.parse parserLsTree b)
+parseLsTreeStrict :: LsTreeLong -> S.ByteString -> Either String TreeItem
+parseLsTreeStrict long b = go (AS.parse (parserLsTree long) b)
   where
 	go (AS.Done _ r) = Right r
 	go (AS.Fail _ _ err) = Left err
 	go (AS.Partial c) = go (c mempty)
 
 {- Parses a line of ls-tree output, in format:
- - mode SP type SP sha TAB file
+ -   mode SP type SP sha TAB file
+ - Or long format:
+ -   mode SP type SP sha SPACES size TAB file
  -
- - (The --long format is not currently supported.) -}
-parserLsTree :: A.Parser TreeItem
-parserLsTree = TreeItem
-	-- mode
-	<$> octal
-	<* A8.char ' '
-	-- type
-	<*> A8.takeTill (== ' ')
-	<* A8.char ' '
-	-- sha
-	<*> (Ref <$> A8.takeTill (== '\t'))
-	<* A8.char '\t'
-	-- file
-	<*> (asTopFilePath . Git.Filename.decode <$> A.takeByteString)
-
-{- Inverse of parseLsTree -}
-formatLsTree :: TreeItem -> String
-formatLsTree ti = unwords
-	[ showOct (mode ti) ""
-	, decodeBS (typeobj ti)
-	, fromRef (sha ti)
-	, fromRawFilePath (getTopFilePath (file ti))
-	]
+ - The TAB can also be a space. Git does not use that, but an earlier
+ - version of formatLsTree did, and this keeps parsing what it output
+ - working.
+ -}
+parserLsTree :: LsTreeLong -> A.Parser TreeItem
+parserLsTree long = case long of
+	LsTreeLong False -> 
+		startparser <*> pure Nothing <* filesep <*> fileparser
+	LsTreeLong True ->
+		startparser <* sizesep <*> sizeparser <* filesep <*> fileparser
+  where
+	startparser = TreeItem
+		-- mode
+		<$> octal
+		<* A8.char ' '
+		-- type
+		<*> A8.takeTill (== ' ')
+		<* A8.char ' '
+		-- sha
+		<*> (Ref <$> A8.takeTill A8.isSpace)
+
+	fileparser = asTopFilePath . Git.Filename.decode <$> A.takeByteString
+
+	sizeparser = fmap Just A8.decimal
+
+	filesep = A8.space
+
+	sizesep = A.many1 A8.space
+
+{- Inverse of parseLsTree. Note that the long output format is not
+ - generated, so any size information is not included. -}
+formatLsTree :: TreeItem -> S.ByteString
+formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' ')))
+	[ encodeBS' (showOct (mode ti) "")
+	, typeobj ti
+	, fromRef' (sha ti)
+	] <> (S.cons (fromIntegral (ord '\t')) (getTopFilePath (file ti)))
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 7179a4e..6929a8e 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -64,12 +64,17 @@ branchRef = underBase "refs/heads"
 
 {- A Ref that can be used to refer to a file in the repository, as staged
  - in the index.
- -
- - Prefixing the file with ./ makes this work even if in a subdirectory
- - of a repo.
  -}
-fileRef :: RawFilePath -> Ref
-fileRef f = Ref $ ":./" <> toInternalGitPath f
+fileRef :: RawFilePath -> IO Ref
+fileRef f = do
+	-- The filename could be absolute, or contain eg "../repo/file",
+	-- neither of which work in a ref, so convert it to a minimal
+	-- relative path.
+	f' <- relPathCwdToFile f
+ 	-- Prefixing the file with ./ makes this work even when in a
+	-- subdirectory of a repo. Eg, ./foo in directory bar refers
+	-- to bar/foo, not to foo in the top of the repository.
+	return $ Ref $ ":./" <> toInternalGitPath f'
 
 {- A Ref that can be used to refer to a file in a particular branch. -}
 branchFileRef :: Branch -> RawFilePath -> Ref
@@ -81,10 +86,13 @@ dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d
 
 {- A Ref that can be used to refer to a file in the repository as it
  - appears in a given Ref. -}
-fileFromRef :: Ref -> RawFilePath -> Ref
-fileFromRef r f = let (Ref fr) = fileRef f in Ref (fromRef' r <> fr)
+fileFromRef :: Ref -> RawFilePath -> IO Ref
+fileFromRef r f = do
+	(Ref fr) <- fileRef f
+	return (Ref (fromRef' r <> fr))
 
-{- Checks if a ref exists. -}
+{- Checks if a ref exists. Note that it must be fully qualified,
+ - eg refs/heads/master rather than master. -}
 exists :: Ref -> Repo -> IO Bool
 exists ref = runBool
 	[ Param "show-ref"
diff --git a/Git/Remote.hs b/Git/Remote.hs
index 7c6cfc2..8f5d99f 100644
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -1,6 +1,6 @@
 {- git remote stuff
  -
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -23,14 +23,22 @@ import Network.URI
 import Git.FilePath
 #endif
 
-{- Is a git config key one that specifies the location of a remote? -}
-isRemoteKey :: ConfigKey -> Bool
-isRemoteKey (ConfigKey k) = "remote." `S.isPrefixOf` k && ".url" `S.isSuffixOf` k
+{- Is a git config key one that specifies the url of a remote? -}
+isRemoteUrlKey :: ConfigKey -> Bool
+isRemoteUrlKey = isRemoteKey "url"
 
-{- Get a remote's name from the config key that specifies its location. -}
-remoteKeyToRemoteName :: ConfigKey -> RemoteName
-remoteKeyToRemoteName (ConfigKey k) = decodeBS' $
-	S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k
+isRemoteKey :: S.ByteString -> ConfigKey -> Bool
+isRemoteKey want (ConfigKey k) =
+	"remote." `S.isPrefixOf` k && ("." <> want) `S.isSuffixOf` k
+
+{- Get a remote's name from the a config key such as remote.name.url
+ - or any other per-remote config key. -}
+remoteKeyToRemoteName :: ConfigKey -> Maybe RemoteName
+remoteKeyToRemoteName (ConfigKey k)
+	| "remote." `S.isPrefixOf` k = 
+		let n = S.intercalate "." $ dropFromEnd 1 $ drop 1 $ S8.split '.' k
+		in if S.null n then Nothing else Just (decodeBS' n)
+	| otherwise = Nothing
 
 {- Construct a legal git remote name out of an arbitrary input string.
  -
@@ -99,7 +107,9 @@ parseRemoteLocation s repo = ret $ calcloc s
 			concatMap splitconfigs $ M.toList $ fullconfig repo
 		splitconfigs (k, vs) = map (\v -> (k, v)) vs
 		(prefix, suffix) = ("url." , ".insteadof")
-	urlstyle v = isURI v || ":" `isInfixOf` v && "//" `isInfixOf` v
+	-- git supports URIs that contain unescaped characters such as
+	-- spaces. So to test if it's a (git) URI, escape those.
+	urlstyle v = isURI (escapeURIString isUnescapedInURI v)
 	-- git remotes can be written scp style -- [user@]host:dir
 	-- but foo::bar is a git-remote-helper location instead
 	scpstyle v = ":" `isInfixOf` v 
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 034d7e9..144c96f 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -1,6 +1,6 @@
 {- git repository recovery
  -
- - Copyright 2013-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -29,6 +29,7 @@ import Git.Sha
 import Git.Types
 import Git.Fsck
 import Git.Index
+import Git.Env
 import qualified Git.Config as Config
 import qualified Git.Construct as Construct
 import qualified Git.LsTree as LsTree
@@ -61,15 +62,14 @@ cleanCorruptObjects fsckresults r = do
 		whenM (isMissing s r) $
 			removeLoose s
 
-{- Explodes all pack files, and deletes them.
+{- Explodes all pack files to loose objects, and deletes the pack files.
  -
- - First moves all pack files to a temp dir, before unpacking them each in
- - turn.
+ - git unpack-objects will not unpack objects from a pack file that are
+ - in the git repo. So, GIT_OBJECT_DIRECTORY is pointed to a temporary
+ - directory, and the loose objects then are moved into place, before
+ - deleting the pack files.
  -
- - This is because unpack-objects will not unpack a pack file if it's in the
- - git repo.
- -
- - Also, this prevents unpack-objects from possibly looking at corrupt
+ - Also, that prevents unpack-objects from possibly looking at corrupt
  - pack files to see if they contain an object, while unpacking a
  - non-corrupt pack file.
  -}
@@ -78,18 +78,28 @@ explodePacks r = go =<< listPackFiles r
   where
 	go [] = return False
 	go packs = withTmpDir "packs" $ \tmpdir -> do
+		r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir
 		putStrLn "Unpacking all pack files."
 		forM_ packs $ \packfile -> do
-			moveFile packfile (tmpdir </> takeFileName packfile)
-			removeWhenExistsWith R.removeLink
-				(packIdxFile (toRawFilePath packfile))
-		forM_ packs $ \packfile -> do
-			let tmp = tmpdir </> takeFileName packfile
-			allowRead (toRawFilePath tmp)
+			-- Just in case permissions are messed up.
+			allowRead (toRawFilePath packfile)
 			-- May fail, if pack file is corrupt.
 			void $ tryIO $
-				pipeWrite [Param "unpack-objects", Param "-r"] r $ \h ->
-				L.hPut h =<< L.readFile tmp
+				pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
+				L.hPut h =<< L.readFile packfile
+		objs <- dirContentsRecursive tmpdir
+		forM_ objs $ \objfile -> do
+			f <- relPathDirToFile
+				(toRawFilePath tmpdir)
+				(toRawFilePath objfile)
+			let dest = objectsDir r P.</> f
+			createDirectoryIfMissing True
+				(fromRawFilePath (parentDir dest))
+			moveFile objfile (fromRawFilePath dest)
+		forM_ packs $ \packfile -> do
+			let f = toRawFilePath packfile
+			removeWhenExistsWith R.removeLink f
+			removeWhenExistsWith R.removeLink (packIdxFile f)
 		return True
 
 {- Try to retrieve a set of missing objects, from the remotes of a
@@ -105,7 +115,10 @@ retrieveMissingObjects missing referencerepo r
 	| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
 		unlessM (boolSystem "git" [Param "init", File tmpdir]) $
 			error $ "failed to create temp repository in " ++ tmpdir
-		tmpr <- Config.read =<< Construct.fromAbsPath (toRawFilePath tmpdir)
+		tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir)
+		let repoconfig r' = fromRawFilePath (localGitDir r' P.</> "config")
+		whenM (doesFileExist (repoconfig r)) $
+			L.readFile (repoconfig r) >>= L.writeFile (repoconfig tmpr)
 		rs <- Construct.fromRemotes r
 		stillmissing <- pullremotes tmpr rs fetchrefstags missing
 		if S.null (knownMissing stillmissing)
@@ -351,8 +364,9 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool
 verifyTree missing treesha r
 	| S.member treesha missing = return False
 	| otherwise = do
-		(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r
-		let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls
+		let nolong = LsTree.LsTreeLong False
+		(ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive nolong treesha []) r
+		let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree nolong) ls
 		if any (`S.member` missing) objshas
 			then do
 				void cleanup
diff --git a/Git/Types.hs b/Git/Types.hs
index 73c4fe6..db1c71b 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -34,6 +34,7 @@ data RepoLocation
 	= Local { gitdir :: RawFilePath, worktree :: Maybe RawFilePath }
 	| LocalUnknown RawFilePath
 	| Url URI
+	| UnparseableUrl String
 	| Unknown
 	deriving (Show, Eq, Ord)
 
diff --git a/Git/Url.hs b/Git/Url.hs
index 8430655..ad0e61b 100644
--- a/Git/Url.hs
+++ b/Git/Url.hs
@@ -1,6 +1,6 @@
 {- git repository urls
  -
- - Copyright 2010, 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -18,12 +18,11 @@ import Network.URI hiding (scheme, authority, path)
 
 import Common
 import Git.Types
-import Git
 
 {- Scheme of an URL repo. -}
-scheme :: Repo -> String
-scheme Repo { location = Url u } = uriScheme u
-scheme repo = notUrl repo
+scheme :: Repo -> Maybe String
+scheme Repo { location = Url u } = Just (uriScheme u)
+scheme _ = Nothing
 
 {- Work around a bug in the real uriRegName
  - <http://trac.haskell.org/network/ticket/40> -}
@@ -65,13 +64,9 @@ authority = authpart assemble
 {- Applies a function to extract part of the uriAuthority of an URL repo. -}
 authpart :: (URIAuth -> a) -> Repo -> Maybe a
 authpart a Repo { location = Url u } = a <$> uriAuthority u
-authpart _ repo = notUrl repo
+authpart _ _ = Nothing
 
 {- Path part of an URL repo. -}
-path :: Repo -> FilePath
-path Repo { location = Url u } = uriPath u
-path repo = notUrl repo
-
-notUrl :: Repo -> a
-notUrl repo = error $
-	"acting on local git repo " ++ repoDescribe repo ++ " not supported"
+path :: Repo -> Maybe FilePath
+path Repo { location = Url u } = Just (uriPath u)
+path _ = Nothing