merge from git-annex

11 files changed, 123 insertions, 61 deletions

diff --git a/Git/Branch.hs b/Git/Branch.hs
index 54af101..f30e357 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -121,6 +121,13 @@ fastForward branch (first:rest) repo =
 			(False, True) -> findbest c rs -- worse
 			(False, False) -> findbest c rs -- same
 
+{- Should the commit avoid the usual summary output? -}
+newtype CommitQuiet = CommitQuiet Bool
+
+applyCommitQuiet :: CommitQuiet -> [CommandParam] -> [CommandParam]
+applyCommitQuiet (CommitQuiet True) ps = Param "--quiet" : ps
+applyCommitQuiet (CommitQuiet False) ps = ps
+
 {- The user may have set commit.gpgsign, intending all their manual
  - commits to be signed. But signing automatic/background commits could
  - easily lead to unwanted gpg prompts or failures.
@@ -148,12 +155,14 @@ applyCommitModeForCommitTree commitmode ps r
 	ps' = applyCommitMode commitmode ps
 
 {- Commit via the usual git command. -}
-commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool
+commitCommand :: CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO Bool
 commitCommand = commitCommand' runBool
 
-commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a
-commitCommand' runner commitmode ps = runner $
-	Param "commit" : applyCommitMode commitmode ps
+commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO a
+commitCommand' runner commitmode commitquiet ps =
+	runner $ Param "commit" : ps'
+  where
+	ps' = applyCommitMode commitmode (applyCommitQuiet commitquiet ps)
 
 {- Commits the index into the specified branch (or other ref), 
  - with the specified parent refs, and returns the committed sha.
@@ -162,7 +171,7 @@ commitCommand' runner commitmode ps = runner $
  - one parent, and it has the same tree that would be committed.
  -
  - Unlike git-commit, does not run any hooks, or examine the work tree
- - in any way.
+ - in any way, or output a summary.
  -}
 commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
 commit commitmode allowempty message branch parentrefs repo = do
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index b9f8305..f33ad49 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -1,6 +1,6 @@
 {- git cat-file 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.
  -}
@@ -10,9 +10,13 @@
 
 module Git.CatFile (
 	CatFileHandle,
+	CatFileMetaDataHandle,
 	catFileStart,
+	catFileMetaDataStart,
 	catFileStart',
+	catFileMetaDataStart',
 	catFileStop,
+	catFileMetaDataStop,
 	catFile,
 	catFileDetails,
 	catTree,
@@ -55,8 +59,12 @@ import Utility.Tuple
 
 data CatFileHandle = CatFileHandle 
 	{ catFileProcess :: CoProcess.CoProcessHandle
-	, checkFileProcess :: CoProcess.CoProcessHandle
-	, gitRepo :: Repo
+	, catFileGitRepo :: Repo
+	}
+
+data CatFileMetaDataHandle = CatFileMetaDataHandle
+	{ checkFileProcess :: CoProcess.CoProcessHandle
+	, checkFileGitRepo :: Repo
 	}
 
 catFileStart :: Repo -> IO CatFileHandle
@@ -64,22 +72,31 @@ catFileStart = catFileStart' True
 
 catFileStart' :: Bool -> Repo -> IO CatFileHandle
 catFileStart' restartable repo = CatFileHandle
-	<$> startp "--batch"
-	<*> startp ("--batch-check=" ++ batchFormat)
+	<$> startcat restartable repo "--batch"
+	<*> pure repo
+
+catFileMetaDataStart :: Repo -> IO CatFileMetaDataHandle
+catFileMetaDataStart = catFileMetaDataStart' True
+
+catFileMetaDataStart' :: Bool -> Repo -> IO CatFileMetaDataHandle
+catFileMetaDataStart' restartable repo = CatFileMetaDataHandle
+	<$> startcat restartable repo ("--batch-check=" ++ batchFormat)
 	<*> pure repo
-  where
-	startp p = gitCoProcessStart restartable
-		[ Param "cat-file"
-		, Param p
-		] repo
 
 batchFormat :: String
 batchFormat = "%(objectname) %(objecttype) %(objectsize)"
 
+startcat :: Bool -> Repo -> String -> IO CoProcess.CoProcessHandle
+startcat restartable repo p = gitCoProcessStart restartable
+	[ Param "cat-file"
+	, Param p
+	] repo
+
 catFileStop :: CatFileHandle -> IO ()
-catFileStop h = do
-	CoProcess.stop (catFileProcess h)
-	CoProcess.stop (checkFileProcess h)
+catFileStop = CoProcess.stop . catFileProcess
+
+catFileMetaDataStop :: CatFileMetaDataHandle -> IO ()
+catFileMetaDataStop = CoProcess.stop . checkFileProcess
 
 {- Reads a file from a specified branch. -}
 catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString
@@ -106,16 +123,16 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \f
 		Nothing -> error $ "unknown response from git cat-file " ++ show (header, object)
   where
 	-- Slow fallback path for filenames containing newlines.
-	newlinefallback = queryObjectType object (gitRepo h) >>= \case
+	newlinefallback = queryObjectType object (catFileGitRepo h) >>= \case
 		Nothing -> return Nothing
-		Just objtype -> queryContent object (gitRepo h) >>= \case
+		Just objtype -> queryContent object (catFileGitRepo h) >>= \case
 			Nothing -> return Nothing
 			Just content -> do
 				-- only the --batch interface allows getting
 				-- the sha, so have to re-hash the object
 				sha <- hashObject' objtype
 					(flip L.hPut content)
-					(gitRepo h)
+					(catFileGitRepo h)
 				return (Just (content, sha, objtype))
 
 readObjectContent :: Handle -> ParsedResp -> IO L.ByteString
@@ -131,7 +148,7 @@ readObjectContent h (ParsedResp _ _ size) = do
 readObjectContent _ DNE = error "internal"
 
 {- Gets the size and type of an object, without reading its content. -}
-catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))
+catObjectMetaData :: CatFileMetaDataHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))
 catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do
 	resp <- S8.hGetLine from
 	case parseResp object resp of
@@ -142,9 +159,9 @@ catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $
   where
 	-- Slow fallback path for filenames containing newlines.
 	newlinefallback = do
-		sha <- Git.Ref.sha object (gitRepo h)
-		sz <- querySize object (gitRepo h)
-		objtype <- queryObjectType object (gitRepo h)
+		sha <- Git.Ref.sha object (checkFileGitRepo h)
+		sz <- querySize object (checkFileGitRepo h)
+		objtype <- queryObjectType object (checkFileGitRepo h)
 		return $ (,,) <$> sha <*> sz <*> objtype
 
 data ParsedResp = ParsedResp Sha ObjectType FileSize | DNE
diff --git a/Git/Command.hs b/Git/Command.hs
index 2358b17..894f6ae 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -39,7 +39,7 @@ runBool params repo = assertLocal repo $
 run :: [CommandParam] -> Repo -> IO ()
 run params repo = assertLocal repo $
 	unlessM (runBool params repo) $
-		error $ "git " ++ show params ++ " failed"
+		giveup $ "git " ++ show params ++ " failed"
 
 {- Runs git and forces it to be quiet, throwing an error if it fails. -}
 runQuiet :: [CommandParam] -> Repo -> IO ()
diff --git a/Git/Config.hs b/Git/Config.hs
index 20ddf79..5deba6b 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -170,7 +170,7 @@ parse s st
 
 {- Checks if a string from git config is a true/false value. -}
 isTrueFalse :: String -> Maybe Bool
-isTrueFalse = isTrueFalse' . ConfigValue . encodeBS'
+isTrueFalse = isTrueFalse' . ConfigValue . encodeBS
 
 isTrueFalse' :: ConfigValue -> Maybe Bool
 isTrueFalse' (ConfigValue s)
@@ -241,6 +241,14 @@ fromFile r f = fromPipe r "git"
 	, Param "--list"
 	] ConfigList
 
+{- Changes a git config setting in .git/config. -}
+change :: ConfigKey -> S.ByteString -> Repo -> IO Bool
+change (ConfigKey k) v = Git.Command.runBool
+	[ Param "config"
+	, Param (decodeBS k)
+	, Param (decodeBS v)
+	]
+
 {- Changes a git config setting in the specified config file.
  - (Creates the file if it does not already exist.) -}
 changeFile :: FilePath -> ConfigKey -> S.ByteString -> IO Bool
@@ -248,8 +256,8 @@ changeFile f (ConfigKey k) v = boolSystem "git"
 	[ Param "config"
 	, Param "--file"
 	, File f
-	, Param (decodeBS' k)
-	, Param (decodeBS' v)
+	, Param (decodeBS k)
+	, Param (decodeBS v)
 	]
 
 {- Unsets a git config setting, in both the git repo,
@@ -264,4 +272,4 @@ unset ck@(ConfigKey k) r = ifM (Git.Command.runBool ps r)
 	, return Nothing
 	)
   where
-	ps = [Param "config", Param "--unset-all", Param (decodeBS' k)]
+	ps = [Param "config", Param "--unset-all", Param (decodeBS k)]
diff --git a/Git/Construct.hs b/Git/Construct.hs
index c013eb2..a5e825e 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -184,7 +184,10 @@ expandTilde :: FilePath -> IO FilePath
 #ifdef mingw32_HOST_OS
 expandTilde = return
 #else
-expandTilde = expandt True
+expandTilde p = expandt True p
+	-- If unable to expand a tilde, eg due to a user not existing,
+	-- use the path as given.
+	`catchNonAsync` (const (return p))
   where
 	expandt _ [] = return ""
 	expandt _ ('/':cs) = do
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index 297c068..cc824f2 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -5,6 +5,8 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
+
 module Git.LsFiles (
 	Options(..),
 	inRepo,
@@ -66,7 +68,7 @@ safeForLsFiles r = isNothing (remoteName r)
 guardSafeForLsFiles :: Repo -> IO a -> IO a
 guardSafeForLsFiles r a
 	| safeForLsFiles r = a
-	| otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r
+	| otherwise = giveup $ "git ls-files is unsafe to run on repository " ++ repoDescribe r
 
 data Options = ErrorUnmatch
 
@@ -236,7 +238,14 @@ data Unmerged = Unmerged
 	{ unmergedFile :: RawFilePath
 	, unmergedTreeItemType :: Conflicting TreeItemType
 	, unmergedSha :: Conflicting Sha
-	}
+	, unmergedSiblingFile :: Maybe RawFilePath
+	-- ^ Normally this is Nothing, because a
+	-- merge conflict is represented as a single file with two
+	-- stages. However, git resolvers sometimes choose to stage
+	-- two files, one for each side of the merge conflict. In such a case,
+	-- this is used for the name of the second file, which is related
+	-- to the first file. (Eg, "foo" and "foo~ref")
+	} deriving (Show)
 
 {- Returns a list of the files in the specified locations that have
  - unresolved merge conflicts.
@@ -246,12 +255,12 @@ data Unmerged = Unmerged
  -   1 = old version, can be ignored
  -   2 = us
  -   3 = them
- - If a line is omitted, that side removed the file.
+ - If line 2 or 3 is omitted, that side removed the file.
  -}
 unmerged :: [RawFilePath] -> Repo -> IO ([Unmerged], IO Bool)
 unmerged l repo = guardSafeForLsFiles repo $ do
 	(fs, cleanup) <- pipeNullSplit params repo
-	return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL') fs, cleanup)
+	return (reduceUnmerged [] $ catMaybes $ map (parseUnmerged . decodeBL) fs, cleanup)
   where
 	params = 
 		Param "ls-files" :
@@ -265,7 +274,7 @@ data InternalUnmerged = InternalUnmerged
 	, ifile :: RawFilePath
 	, itreeitemtype :: Maybe TreeItemType
 	, isha :: Maybe Sha
-	}
+	} deriving (Show)
 
 parseUnmerged :: String -> Maybe InternalUnmerged
 parseUnmerged s
@@ -277,7 +286,7 @@ parseUnmerged s
 				then Nothing
 				else do
 					treeitemtype <- readTreeItemType (encodeBS rawtreeitemtype)
-					sha <- extractSha (encodeBS' rawsha)
+					sha <- extractSha (encodeBS rawsha)
 					return $ InternalUnmerged (stage == 2) (toRawFilePath file)
 						(Just treeitemtype) (Just sha)
 		_ -> Nothing
@@ -296,16 +305,25 @@ reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
 		{ unmergedFile = ifile i
 		, unmergedTreeItemType = Conflicting treeitemtypeA treeitemtypeB
 		, unmergedSha = Conflicting shaA shaB
+		, unmergedSiblingFile = if ifile sibi == ifile i
+			then Nothing
+			else Just (ifile sibi)
 		}
 	findsib templatei [] = ([], removed templatei)
 	findsib templatei (l:ls)
-		| ifile l == ifile templatei = (ls, l)
+		| ifile l == ifile templatei || issibfile templatei l = (ls, l)
 		| otherwise = (l:ls, removed templatei)
 	removed templatei = templatei
 		{ isus = not (isus templatei)
 		, itreeitemtype = Nothing
 		, isha = Nothing
 		}
+	-- foo~<ref> are unmerged sibling files of foo
+	-- Some versions or resolvers of git stage the sibling files,
+	-- other versions or resolvers do not.
+	issibfile x y = (ifile x <> "~") `S.isPrefixOf` ifile y
+		&& isus x || isus y
+		&& not (isus x && isus y)
 
 {- Gets the InodeCache equivilant information stored in the git index.
  -
diff --git a/Git/LsTree.hs b/Git/LsTree.hs
index a49c4ea..fb3b3e1 100644
--- a/Git/LsTree.hs
+++ b/Git/LsTree.hs
@@ -149,7 +149,7 @@ parserLsTree long = case long of
  - generated, so any size information is not included. -}
 formatLsTree :: TreeItem -> S.ByteString
 formatLsTree ti = S.intercalate (S.singleton (fromIntegral (ord ' ')))
-	[ encodeBS' (showOct (mode ti) "")
+	[ 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 6929a8e..2d2874a 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -64,17 +64,21 @@ branchRef = underBase "refs/heads"
 
 {- A Ref that can be used to refer to a file in the repository, as staged
  - in the index.
+ - 
+ - If the input file is located outside the repository, returns Nothing.
  -}
-fileRef :: RawFilePath -> IO Ref
-fileRef f = do
+fileRef :: RawFilePath -> Repo -> IO (Maybe Ref)
+fileRef f repo = 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'
+	return $ if repoPath repo `dirContains` 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.
+		then Just $ Ref $ ":./" <> toInternalGitPath f'
+		else Nothing
 
 {- A Ref that can be used to refer to a file in a particular branch. -}
 branchFileRef :: Branch -> RawFilePath -> Ref
@@ -82,14 +86,17 @@ branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f
 
 {- Converts a Ref to refer to the content of the Ref on a given date. -}
 dateRef :: Ref -> RefDate -> Ref
-dateRef r (RefDate d) = Ref $ fromRef' r <> "@" <> encodeBS' d
+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 -> IO Ref
-fileFromRef r f = do
-	(Ref fr) <- fileRef f
-	return (Ref (fromRef' r <> fr))
+ - appears in a given Ref. 
+ -
+ - If the file path is located outside the repository, returns Nothing.
+ -}
+fileFromRef :: Ref -> RawFilePath -> Repo -> IO (Maybe Ref)
+fileFromRef r f repo = fileRef f repo >>= return . \case
+	Just (Ref fr) -> Just (Ref (fromRef' r <> fr))
+	Nothing -> Nothing
 
 {- Checks if a ref exists. Note that it must be fully qualified,
  - eg refs/heads/master rather than master. -}
@@ -177,7 +184,7 @@ tree (Ref ref) = extractSha <$$> pipeReadStrict
 	[ Param "rev-parse"
 	, Param "--verify"
 	, Param "--quiet"
-	, Param (decodeBS' ref')
+	, Param (decodeBS ref')
 	]
   where
 	ref' = if ":" `S.isInfixOf` ref
diff --git a/Git/Remote.hs b/Git/Remote.hs
index 8f5d99f..80accca 100644
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -37,7 +37,7 @@ 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)
+		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.
@@ -90,7 +90,7 @@ parseRemoteLocation s repo = ret $ calcloc s
 		| null insteadofs = l
 		| otherwise = replacement ++ drop (S.length bestvalue) l
 	  where
-		replacement = decodeBS' $ S.drop (S.length prefix) $
+		replacement = decodeBS $ S.drop (S.length prefix) $
 			S.take (S.length bestkey - S.length suffix) bestkey
 		(bestkey, bestvalue) = 
 			case maximumBy longestvalue insteadofs of
diff --git a/Git/Types.hs b/Git/Types.hs
index db1c71b..68045fc 100644
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -75,7 +75,7 @@ instance Default ConfigValue where
 	def = ConfigValue mempty
 
 fromConfigKey :: ConfigKey -> String
-fromConfigKey (ConfigKey s) = decodeBS' s
+fromConfigKey (ConfigKey s) = decodeBS s
 
 instance Show ConfigKey where
 	show = fromConfigKey
@@ -88,16 +88,16 @@ instance FromConfigValue S.ByteString where
 	fromConfigValue NoConfigValue = mempty
 
 instance FromConfigValue String where
-	fromConfigValue = decodeBS' . fromConfigValue
+	fromConfigValue = decodeBS . fromConfigValue
 
 instance Show ConfigValue where
 	show = fromConfigValue
 
 instance IsString ConfigKey where
-	fromString = ConfigKey . encodeBS'
+	fromString = ConfigKey . encodeBS
 
 instance IsString ConfigValue where
-	fromString = ConfigValue . encodeBS'
+	fromString = ConfigValue . encodeBS
 
 type RemoteName = String
 
@@ -106,7 +106,7 @@ newtype Ref = Ref S.ByteString
 	deriving (Eq, Ord, Read, Show)
 
 fromRef :: Ref -> String
-fromRef = decodeBS' . fromRef'
+fromRef = decodeBS . fromRef'
 
 fromRef' :: Ref -> S.ByteString
 fromRef' (Ref s) = s
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 8e406b1..74816a6 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -80,14 +80,14 @@ lsTree (Ref x) repo streamer = do
 	mapM_ streamer s
 	void $ cleanup
   where
-	params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x]
+	params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x]
 lsSubTree :: Ref -> FilePath -> Repo -> Streamer
 lsSubTree (Ref x) p repo streamer = do
 	(s, cleanup) <- pipeNullSplit params repo
 	mapM_ streamer s
 	void $ cleanup
   where
-	params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS' x, p]
+	params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x, p]
 
 {- Generates a line suitable to be fed into update-index, to add
  - a given file with a given sha. -}