voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
voidlizard 2024-11-22 07:31:15 +03:00
parent a5970a4080
commit 2b89922e90
1 changed files with 8 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
hbs2-git3/app/Main.hs
View File

@ -342,8 +342,8 @@ gitReadCommitParents bs = do
| ListVal [ StringLike "parent", StringLike hash ] <- what | ListVal [ StringLike "parent", StringLike hash ] <- what
] & catMaybes ] & catMaybes
gitWriteCommitPackIO :: (GitWritePacksOpts opt, Pretty what) => opt -> what -> ( BS.ByteString -> IO () ) -> IO () gitWriteCommitPackIO :: (GitWritePacksOpts opt, GitObjectReader reader, Pretty what) => opt -> reader -> what -> ( BS.ByteString -> IO () ) -> IO ()
gitWriteCommitPackIO opts what action = do gitWriteCommitPackIO opts reader what action = do
hhead <- gitRevParse what >>= orThrow (OtherGitError $ show $ "can't parse" <+> pretty what) hhead <- gitRevParse what >>= orThrow (OtherGitError $ show $ "can't parse" <+> pretty what)
parents <- gitReadObjectThrow Commit hhead >>= gitReadCommitParents parents <- gitReadObjectThrow Commit hhead >>= gitReadCommitParents
@ -361,9 +361,6 @@ gitWriteCommitPackIO opts what action = do
<&> sortGitTreeEntries <&> sortGitTreeEntries
flip runContT pure do flip runContT pure do
ph <- ContT withGitCat
let ssin = getStdin ph
let ssout = getStdout ph
inq <- newTQueueIO inq <- newTQueueIO
@ -384,21 +381,9 @@ gitWriteCommitPackIO opts what action = do
Nothing -> go =<< next mempty Nothing -> go =<< next mempty
Just (t,ha) -> do Just (t,ha) -> do
(tt,bs) <- gitReadObjectMaybe reader ha >>= orThrow (GitReadError (show $ pretty ha))
liftIO $ hPrint ssin $ pretty ha let header = [qc|{pretty (Short tt)} {pretty $ LBS.length bs} {pretty ha}|]
liftIO $ hFlush ssin go =<< next (LBS.toStrict (LBS8.intercalate "\n" [header, bs]))
s <- liftIO $ hGetLine ssout
case words s of
[_,_,s] -> do
n <- readMay @Int s & orThrow (OtherGitError "git cat-file --batch error")
co <- liftIO $ LBS.hGet ssout n
void $ liftIO $ hGetLine ssout
let header = [qc|{pretty (Short t)} {s} {pretty ha}|]
go =<< next (LBS.toStrict (LBS8.intercalate "\n" [header, co]))
e -> throwIO $ OtherGitError ("git cat-file --batch error: " <> show e)
BZ.CompressOutputAvailable outchunk next -> do BZ.CompressOutputAvailable outchunk next -> do
action outchunk action outchunk
@ -507,7 +492,9 @@ theDict = do
_ -> pure ( "HEAD", stdout ) _ -> pure ( "HEAD", stdout )
liftIO $ gitWriteCommitPackIO o what $ \bs -> do rd <- ContT withGitCat
liftIO $ gitWriteCommitPackIO o rd what $ \bs -> do
BS.hPut to bs BS.hPut to bs
entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> do entry $ bindMatch "test:git:tree:export" $ nil_ $ \syn -> do