diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index 126cd1b6..21cc3c97 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -598,65 +598,12 @@ theDict = do liftIO $ print $ pretty h <+> fill 8 (viaShow tp) <+> pretty s - entry $ bindMatch "test:segment:dump:pack" $ nil_ $ \syn -> lift do - sto <- getStorage - let (_, argz) = splitOpts [] syn - + let (opts, argz) = splitOpts [ ("--dir",1)] syn + let dir = headDef "." [ p | ListVal [StringLike "--dir", StringLike p] <- opts ] let trees = [ x | HashLike x <- argz ] - for_ trees $ \tree -> do - - notice $ "running" <+> pretty tree - - lbs <- runExceptT (getTreeContents sto tree) >>= orThrowPassIO - - file <- liftIO $ Temp.emptyTempFile "" (show (pretty tree) <> ".pack") - - liftIO $ UIO.withBinaryFileAtomic file ReadWriteMode $ \fh -> do - - let header = BS.concat [ "PACK", N.bytestring32 2, N.bytestring32 0 ] - - BS.hPutStr fh header - - no_ <- newTVarIO 0 - seen_ <- newTVarIO (mempty :: HashSet GitHash) - - runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \h s obs -> do - seen <- readTVarIO seen_ <&> HS.member h - unless seen do - - let (t, body) = LBS.splitAt 1 obs - - let tp = fromStringMay @(Short GitObjectType) (LBS8.unpack t) - & maybe Blob coerce - - let params = Zlib.defaultCompressParams { Zlib.compressMethod = Zlib.deflateMethod } - - let packed = Zlib.compressWith params body - - let preamble = encodeObjectSize (gitPackTypeOf tp) (fromIntegral $ LBS.length body) - - liftIO do - atomically $ modifyTVar seen_ (HS.insert h) - BS.hPutStr fh preamble - LBS.hPutStr fh packed - - atomically $ modifyTVar no_ succ - - no <- readTVarIO no_ - hSeek fh AbsoluteSeek 8 - BS.hPutStr fh (N.bytestring32 no) - hFlush fh - - sz <- hFileSize fh - hSeek fh AbsoluteSeek 0 - - sha <- LBS.hGetNonBlocking fh (fromIntegral sz) <&> sha1lazy - - hSeek fh SeekFromEnd 0 - - BS.hPutStr fh sha + writeAsGitPack dir tree entry $ bindMatch "test:segment:import:loose" $ nil_ $ \syn -> lift $ connectedDo do let (opts, argz) = splitOpts [] syn