merge from git-annex and relicense accordingly

Merge git library and utility from git-annex. The former is now relicensed
AGPL, so git-repair as a whole becomes AGPL.

For simplicity, I am relicensing the remainder of the code in git-repair
AGPL as well, per the header changes in this commit. While that code is
also technically available under the GPL license, as it's been released
under that license before, changes going forward will be only released by
me under the AGPL.

1 files changed, 89 insertions, 18 deletions

diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index ba68c4e..6402001 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -1,8 +1,8 @@
 {- git cat-file interface
  -
- - Copyright 2011-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2019 Joey Hess <id@joeyh.name>
  -
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
  -}
 
 module Git.CatFile (
@@ -28,20 +28,23 @@ import Data.String
 import Data.Char
 import Numeric
 import System.Posix.Types
+import Text.Read
 
 import Common
 import Git
 import Git.Sha
+import qualified Git.Ref
 import Git.Command
 import Git.Types
 import Git.FilePath
+import Git.HashObject
 import qualified Utility.CoProcess as CoProcess
-import Utility.FileSystemEncoding
 import Utility.Tuple
 
 data CatFileHandle = CatFileHandle 
 	{ catFileProcess :: CoProcess.CoProcessHandle
 	, checkFileProcess :: CoProcess.CoProcessHandle
+	, gitRepo :: Repo
 	}
 
 catFileStart :: Repo -> IO CatFileHandle
@@ -51,6 +54,7 @@ catFileStart' :: Bool -> Repo -> IO CatFileHandle
 catFileStart' restartable repo = CatFileHandle
 	<$> startp "--batch"
 	<*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)"
+	<*> pure repo
   where
 	startp p = gitCoProcessStart restartable
 		[ Param "cat-file"
@@ -63,13 +67,13 @@ catFileStop h = do
 	CoProcess.stop (checkFileProcess h)
 
 {- Reads a file from a specified branch. -}
-catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
+catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString
 catFile h branch file = catObject h $ Ref $
-	fromRef branch ++ ":" ++ toInternalGitPath file
+	fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)
 
-catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
+catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType))
 catFileDetails h branch file = catObjectDetails h $ Ref $
-	fromRef branch ++ ":" ++ toInternalGitPath file
+	fromRef branch ++ ":" ++ fromRawFilePath (toInternalGitPath file)
 
 {- Uses a running git cat-file read the content of an object.
  - Objects that do not exist will have "" returned. -}
@@ -77,7 +81,7 @@ catObject :: CatFileHandle -> Ref -> IO L.ByteString
 catObject h object = maybe L.empty fst3 <$> catObjectDetails h object
 
 catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha, ObjectType))
-catObjectDetails h object = query (catFileProcess h) object $ \from -> do
+catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do
 	header <- hGetLine from
 	case parseResp object header of
 		Just (ParsedResp sha size objtype) -> do
@@ -91,23 +95,53 @@ catObjectDetails h object = query (catFileProcess h) object $ \from -> do
 		c <- hGetChar from
 		when (c /= expected) $
 			error $ "missing " ++ (show expected) ++ " from git cat-file"
+	
+	-- Slow fallback path for filenames containing newlines.
+	newlinefallback = queryObjectType object (gitRepo h) >>= \case
+		Nothing -> return Nothing
+		Just objtype -> queryContent object (gitRepo 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)
+				return (Just (content, sha, objtype))
 
 {- Gets the size and type of an object, without reading its content. -}
-catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Integer, ObjectType))
-catObjectMetaData h object = query (checkFileProcess h) object $ \from -> do
+catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType))
+catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do
 	resp <- hGetLine from
 	case parseResp object resp of
-		Just (ParsedResp _ size objtype) ->
-			return $ Just (size, objtype)
+		Just (ParsedResp sha size objtype) ->
+			return $ Just (sha, size, objtype)
 		Just DNE -> return Nothing
 		Nothing -> error $ "unknown response from git cat-file " ++ show (resp, object)
+  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)
+		return $ (,,) <$> sha <*> sz <*> objtype
 
-data ParsedResp = ParsedResp Sha Integer ObjectType | DNE
+data ParsedResp = ParsedResp Sha FileSize ObjectType | DNE
 
-query :: CoProcess.CoProcessHandle -> Ref -> (Handle -> IO a) -> IO a
-query hdl object receive = CoProcess.query hdl send receive
+query :: CoProcess.CoProcessHandle -> Ref -> IO a -> (Handle -> IO a) -> IO a
+query hdl object newlinefallback receive
+	-- git cat-file --batch uses a line based protocol, so when the
+	-- filename itself contains a newline, have to fall back to another
+	-- method of getting the information.
+	| '\n' `elem` s = newlinefallback
+	-- git strips carriage return from the end of a line, out of some
+	-- misplaced desire to support windows, so also use the newline
+	-- fallback for those.
+	| "\r" `isSuffixOf` s = newlinefallback
+	| otherwise = CoProcess.query hdl send receive
   where
-	send to = hPutStrLn to (fromRef object)
+	send to = hPutStrLn to s
+	s = fromRef object
 
 parseResp :: Ref -> String -> Maybe ParsedResp
 parseResp object l 
@@ -116,13 +150,50 @@ parseResp object l
 	| otherwise = case words l of
 		[sha, objtype, size]
 			| length sha == shaSize ->
-				case (readObjectType objtype, reads size) of
+				case (readObjectType (encodeBS objtype), reads size) of
 					(Just t, [(bytes, "")]) -> 
 						Just $ ParsedResp (Ref sha) bytes t
 					_ -> Nothing
 			| otherwise -> Nothing
 		_ -> Nothing
 
+querySingle :: CommandParam -> Ref -> Repo -> (Handle -> IO a) -> IO (Maybe a)
+querySingle o r repo reader = assertLocal repo $
+	-- In non-batch mode, git cat-file warns on stderr when
+	-- asked for an object that does not exist.
+	-- Squelch that warning to behave the same as batch mode.
+	withNullHandle $ \nullh -> do
+		let p = gitCreateProcess 
+			[ Param "cat-file"
+			, o
+			, Param (fromRef r)
+			] repo
+		let p' = p
+			{ std_err = UseHandle nullh
+			, std_in = Inherit
+			, std_out = CreatePipe
+			}
+		pid <- createProcess p'
+		let h = stdoutHandle pid
+		output <- reader h
+		hClose h
+		ifM (checkSuccessProcess (processHandle pid))
+			( return (Just output)
+			, return Nothing
+			)
+
+querySize :: Ref -> Repo -> IO (Maybe FileSize)
+querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n'))
+	<$> querySingle (Param "-s") r repo hGetContentsStrict
+
+queryObjectType :: Ref -> Repo -> IO (Maybe ObjectType)
+queryObjectType r repo = maybe Nothing (readObjectType . encodeBS . takeWhile (/= '\n'))
+	<$> querySingle (Param "-t") r repo hGetContentsStrict
+
+queryContent :: Ref -> Repo -> IO (Maybe L.ByteString)
+queryContent r repo = fmap (\b -> L.fromChunks [b])
+	<$> querySingle (Param "-p") r repo S.hGetContents
+
 {- Gets a list of files and directories in a tree. (Not recursive.) -}
 catTree :: CatFileHandle -> Ref -> IO [(FilePath, FileMode)]
 catTree h treeref = go <$> catObjectDetails h treeref
@@ -141,7 +212,7 @@ catTree h treeref = go <$> catObjectDetails h treeref
 	dropsha = L.drop 21
 
 	parsemodefile b = 
-		let (modestr, file) = separate (== ' ') (decodeBS b)
+		let (modestr, file) = separate (== ' ') (decodeBL b)
 		in (file, readmode modestr)
 	readmode = fromMaybe 0 . fmap fst . headMaybe . readOct