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