From 943ae395c49469b148326e41486f39c9113f386e Mon Sep 17 00:00:00 2001 From: voidlizard Date: Mon, 30 Dec 2024 09:37:53 +0300 Subject: [PATCH] wip --- hbs2-git3/app/Main.hs | 80 ++++++++++++++++++++--- hbs2-git3/hbs2-git3.cabal | 2 +- hbs2-git3/lib/HBS2/Data/Log/Structured.hs | 20 +++++- 3 files changed, 91 insertions(+), 11 deletions(-) diff --git a/hbs2-git3/app/Main.hs b/hbs2-git3/app/Main.hs index bbc6efe4..2b731377 100644 --- a/hbs2-git3/app/Main.hs +++ b/hbs2-git3/app/Main.hs @@ -97,6 +97,7 @@ import Control.Monad.Reader import Control.Monad.Except import Control.Monad.Trans.Writer.CPS qualified as Writer import Control.Concurrent.STM qualified as STM +import Codec.Serialise import System.Directory (setCurrentDirectory) import System.Random hiding (next) import System.IO.MMap (mmapFileByteString) @@ -228,7 +229,7 @@ instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (Git3 m) where Git3Disconnected{} -> throwIO Git3PeerNotConnected Git3Connected{..} -> pure peerAPI -instance (MonadUnliftIO m, MonadReader Git3Env m) => HasClientAPI RefLogAPI UNIX m where +instance (MonadUnliftIO m) => HasClientAPI RefLogAPI UNIX (Git3 m) where getClientAPI = do ask >>= \case Git3Disconnected{} -> throwIO Git3PeerNotConnected @@ -240,7 +241,7 @@ nullGit3Env = Git3Disconnected <*> newTVarIO defSegmentSize <*> newTVarIO defCompressionLevel -connectedDo :: (MonadIO m, MonadReader Git3Env m) => m a -> m a +connectedDo :: (MonadIO m) => Git3 m a -> Git3 m a connectedDo what = do env <- ask debug $ red "connectedDo" @@ -549,12 +550,11 @@ class HasExportOpts m where theDict :: forall m . ( HBS2GitPerks m - , HasClientAPI PeerAPI UNIX m - , HasStorage m - , HasGitRemoteKey m - , HasStateDB m - , MonadReader Git3Env m - ) => Dict C m + -- , HasClientAPI PeerAPI UNIX m + -- , HasStorage m + -- , HasGitRemoteKey m + -- , HasStateDB m + ) => Dict C (Git3 m) theDict = do makeDict @C do -- TODO: write-man-entries @@ -1034,6 +1034,70 @@ theDict = do let contents = Zlib.compressWith params o LBS.hPutStr fh contents + + entry $ bindMatch "test:git:reflog:index:list" $ nil_ $ \syn -> lift do + let (_, argz) = splitOpts [] syn + for_ [ x | StringLike x <- argz ] $ \ifn -> do + lbs <- liftIO $ LBS.readFile ifn + void $ runConsumeLBS lbs $ readSections $ \s ss -> do + + let (sha1, blake) = LBS.splitAt 20 ss + & over _1 (coerce @_ @GitHash . LBS.toStrict) + & over _2 (coerce @_ @HashRef . LBS.toStrict) + + liftIO $ hPrint stdout $ pretty sha1 <+> pretty blake + + entry $ bindMatch "test:git:reflog:index" $ nil_ $ \syn -> lift $ connectedDo do + reflog <- getGitRemoteKey >>= orThrowUser "reflog not set" + + api <- getClientAPI @RefLogAPI @UNIX + + sto <- getStorage + + flip runContT pure do + + what' <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 2) api reflog + >>= orThrowUser "rpc timeout" + + what <- ContT $ maybe1 what' none + + idxPath <- getStatePath (AsBase58 reflog) <&> ( "index") + mkdir idxPath + + notice $ "STATE" <+> pretty idxPath + + sink <- newTQueueIO + walkMerkle (coerce what) (getBlock sto) $ \case + Left{} -> throwIO MissedBlockError + Right (hs :: [HashRef]) -> do + for_ hs $ \h -> void $ runMaybeT do + + tx <- getBlock sto (coerce h) + >>= toMPlus + + RefLogUpdate{..} <- deserialiseOrFail @(RefLogUpdate L4Proto) tx + & toMPlus + + AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict _refLogUpdData) + & toMPlus + + -- FIXME: error logging + lbs <- liftIO (runExceptT (getTreeContents sto href)) + >>= orThrowUser "FUCK!" + + void $ runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \o s _ -> do + atomically $ writeTQueue sink (o,h) + + liftIO do + idxName <- emptyTempFile idxPath "objects-.idx" + ss <- L.sortBy (comparing fst) <$> atomically (STM.flushTQueue sink) + UIO.withBinaryFileAtomic idxName WriteMode $ \wh -> do + for_ ss $ \(sha1, tx) -> do + let key = coerce @_ @N.ByteString sha1 + let value = coerce @_ @N.ByteString tx + notice $ pretty sha1 <+> pretty tx + writeSection ( LBS.fromChunks [key,value] ) (LBS.hPutStr wh) + entry $ bindMatch "test:git:export" $ nil_ $ \syn -> lift $ connectedDo do let (opts, argz) = splitOpts [("--index",1),("--ref",1)] syn diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index d92d6765..da46e968 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -19,7 +19,7 @@ common shared-properties -threaded -rtsopts -O2 - "-with-rtsopts=-N4 -A64m -AL256m -I0 -M4G" + "-with-rtsopts=-N4 -A64m -AL256m -I0 -M8G" default-language: GHC2021 diff --git a/hbs2-git3/lib/HBS2/Data/Log/Structured.hs b/hbs2-git3/lib/HBS2/Data/Log/Structured.hs index 6edb36b3..b0009c9e 100644 --- a/hbs2-git3/lib/HBS2/Data/Log/Structured.hs +++ b/hbs2-git3/lib/HBS2/Data/Log/Structured.hs @@ -1,7 +1,9 @@ module HBS2.Data.Log.Structured where import HBS2.Prelude.Plated +import HBS2.OrDie +import Network.ByteOrder qualified as N import Data.ByteString.Builder qualified as B import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as LBS @@ -84,7 +86,7 @@ newtype ConsumeBS m a = ConsumeBS { fromConsumeBS :: StateT BS.ByteString m a } instance Monad m => BytesReader (ConsumeLBS m) where - readBytes n = readChunkSimple n + readBytes = readChunkSimple noBytesLeft = consumed instance Monad m => BytesReader (ConsumeBS m) where @@ -99,10 +101,24 @@ runConsumeBS :: Monad m => BS.ByteString -> ConsumeBS m a -> m a runConsumeBS s m = evalStateT (fromConsumeBS m) s +readSections :: forall m . (MonadIO m, BytesReader m) + => ( Int -> ByteString -> m () ) + -> m () +readSections action = fix \next -> do + done <- noBytesLeft + if done then + pure () + else do + ssize <- readBytesMaybe 4 + >>= orThrow SomeReadLogError + <&> fromIntegral . N.word32 . LBS.toStrict + sdata <- readBytesMaybe ssize + >>= orThrow SomeReadLogError - + action ssize sdata + next writeSection :: forall m . Monad m => ByteString