a6bebe3c0f
git hash-object --stdin-paths is a newline protocol so it cannot support them. It would help to not use absPath, when the problem is that the repository itself is in a path with a newline. But, there's a reason it used absPath, which is that git hash-object --stdin-paths actually chdirs to the top of the repository on startup! That is not documented, and I think is a bug in git. I considered making the path relative to the top of the repo, but then what if this is a git bug and gets fixed? git-annex would break horribly. So instead, keep the absPath, but when the path contains a newline, fall back to running git hash-object once per file, which avoids the problem with newlines and --stdin-paths. It will be slower, but this is an edge case. (Similar slow code paths are already used elsewhere when dealing with filenames with newlines and other parts of git that use line-based protocols.) Sponsored-by: Dartmouth College's Datalad project
98 lines
3.2 KiB
Haskell
98 lines
3.2 KiB
Haskell
{- git hash-object interface
|
|
-
|
|
- Copyright 2011-2023 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Git.HashObject where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Sha
|
|
import Git.Command
|
|
import Git.Types
|
|
import qualified Utility.CoProcess as CoProcess
|
|
import Utility.Tmp
|
|
|
|
import qualified Data.ByteString as S
|
|
import qualified Data.ByteString.Char8 as S8
|
|
import qualified Data.ByteString.Lazy as L
|
|
import Data.ByteString.Builder
|
|
import Data.Char
|
|
|
|
data HashObjectHandle = HashObjectHandle CoProcess.CoProcessHandle Repo [CommandParam]
|
|
|
|
hashObjectStart :: Bool -> Repo -> IO HashObjectHandle
|
|
hashObjectStart writeobject repo = do
|
|
h <- gitCoProcessStart True (ps ++ [Param "--stdin-paths"]) repo
|
|
return (HashObjectHandle h repo ps)
|
|
where
|
|
ps = catMaybes
|
|
[ Just (Param "hash-object")
|
|
, if writeobject then Just (Param "-w") else Nothing
|
|
, Just (Param "--no-filters")
|
|
]
|
|
|
|
hashObjectStop :: HashObjectHandle -> IO ()
|
|
hashObjectStop (HashObjectHandle h _ _) = CoProcess.stop h
|
|
|
|
{- Injects a file into git, returning the Sha of the object. -}
|
|
hashFile :: HashObjectHandle -> RawFilePath -> IO Sha
|
|
hashFile hdl@(HashObjectHandle h _ _) file = do
|
|
-- git hash-object chdirs to the top of the repository on
|
|
-- start, so if the filename is relative, it will
|
|
-- not work. This seems likely to be a git bug.
|
|
-- So, make the filename absolute, which will work now
|
|
-- and also if git's behavior later changes.
|
|
file' <- absPath file
|
|
if newline `S.elem` file'
|
|
then hashFile' hdl file
|
|
else CoProcess.query h (send file') receive
|
|
where
|
|
send file' to = S8.hPutStrLn to file'
|
|
receive from = getSha "hash-object" $ S8.hGetLine from
|
|
newline = fromIntegral (ord '\n')
|
|
|
|
{- Runs git hash-object once per call, rather than using a running
|
|
- one, so is slower. But, is able to handle newlines in the filepath,
|
|
- which --stdin-paths cannot. -}
|
|
hashFile' :: HashObjectHandle -> RawFilePath -> IO Sha
|
|
hashFile' (HashObjectHandle _ repo ps) file = getSha "hash-object" $
|
|
pipeReadStrict (ps ++ [File (fromRawFilePath file)]) repo
|
|
|
|
class HashableBlob t where
|
|
hashableBlobToHandle :: Handle -> t -> IO ()
|
|
|
|
instance HashableBlob L.ByteString where
|
|
hashableBlobToHandle = L.hPut
|
|
|
|
instance HashableBlob S.ByteString where
|
|
hashableBlobToHandle = S.hPut
|
|
|
|
instance HashableBlob Builder where
|
|
hashableBlobToHandle = hPutBuilder
|
|
|
|
{- Injects a blob into git. Unfortunately, the current git-hash-object
|
|
- interface does not allow batch hashing without using temp files. -}
|
|
hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha
|
|
hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do
|
|
hashableBlobToHandle tmph b
|
|
hClose tmph
|
|
hashFile h (toRawFilePath tmp)
|
|
|
|
{- Injects some content into git, returning its Sha.
|
|
-
|
|
- Avoids using a tmp file, but runs a new hash-object command each
|
|
- time called. -}
|
|
hashObject :: ObjectType -> String -> Repo -> IO Sha
|
|
hashObject objtype content = hashObject' objtype (flip hPutStr content)
|
|
|
|
hashObject' :: ObjectType -> (Handle -> IO ()) -> Repo -> IO Sha
|
|
hashObject' objtype writer repo = getSha subcmd $
|
|
pipeWriteRead (map Param params) (Just writer) repo
|
|
where
|
|
subcmd = "hash-object"
|
|
params = [subcmd, "-t", decodeBS (fmtObjectType objtype), "-w", "--stdin", "--no-filters"]
|