mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
8d20f10837
commit
8ba476be17
|
|
@ -66,6 +66,7 @@ import Data.HashMap.Strict qualified as HM
|
|||
import Data.HashMap.Strict (HashMap(..))
|
||||
import Data.Word
|
||||
import Data.Fixed
|
||||
import Data.Either
|
||||
import Data.Ord (comparing)
|
||||
import Data.Generics.Labels
|
||||
import Data.Generics.Product
|
||||
|
|
@ -1167,19 +1168,10 @@ theDict = do
|
|||
else do
|
||||
decoded <- readTxMay sto h
|
||||
<&> \case
|
||||
Nothing -> ("missed" <+> pretty h)
|
||||
Just (AnnotatedHashRef _ x) -> (fill 44 (pretty h) <+> fill 44 (pretty x))
|
||||
print decoded
|
||||
Just (TxSegment x) -> Just (fill 44 (pretty h) <+> fill 44 (pretty x))
|
||||
_ -> Nothing
|
||||
|
||||
entry $ bindMatch "reflog:tx:objects:list" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
let (_, argz) = splitOpts [] syn
|
||||
txh <- headMay [ x | HashLike x <- argz ] & orThrowUser "tx hash not set"
|
||||
sto <- getStorage
|
||||
|
||||
AnnotatedHashRef _ tree <- readTxMay sto txh
|
||||
>>= orThrowUser ("missed" <+> pretty txh)
|
||||
|
||||
liftIO $ print $ pretty tree
|
||||
forM_ decoded print
|
||||
|
||||
entry $ bindMatch "test:git:import" $ nil_ $ \syn -> lift $ connectedDo do
|
||||
|
||||
|
|
@ -1191,19 +1183,12 @@ theDict = do
|
|||
rv <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) refLogAPI reflog
|
||||
>>= orThrowUser "rpc timeout"
|
||||
>>= orThrowUser "reflog is empty"
|
||||
<&> coerce
|
||||
<&> coerce @_ @HashRef
|
||||
|
||||
notice $ "test:git:import" <+> pretty (AsBase58 reflog) <+> pretty rv
|
||||
|
||||
sto <- getStorage
|
||||
|
||||
walkMerkle @[HashRef] rv (getBlock sto) \case
|
||||
Left h -> err $ "missed block"
|
||||
Right hs -> do
|
||||
for_ hs $ \h -> void $ runMaybeT do
|
||||
AnnotatedHashRef _ tree <- readTxMay sto h >>= toMPlus
|
||||
notice $ pretty tree
|
||||
none
|
||||
none
|
||||
|
||||
exportEntries "reflog:"
|
||||
|
||||
|
|
|
|||
|
|
@ -276,9 +276,13 @@ bloomFilterSize n k p
|
|||
where
|
||||
rnd x = 2 ** realToFrac (ceiling (logBase 2 x)) & round
|
||||
|
||||
data GitTx =
|
||||
TxSegment HashRef
|
||||
| TxCheckpoint Natural HashRef
|
||||
|
||||
readTxMay :: forall m . ( MonadIO m
|
||||
)
|
||||
=> AnyStorage -> HashRef -> m (Maybe AnnotatedHashRef)
|
||||
=> AnyStorage -> HashRef -> m (Maybe GitTx)
|
||||
|
||||
readTxMay sto href = runMaybeT do
|
||||
|
||||
|
|
@ -288,8 +292,17 @@ readTxMay sto href = runMaybeT do
|
|||
RefLogUpdate{..} <- deserialiseOrFail @(RefLogUpdate L4Proto) tx
|
||||
& toMPlus
|
||||
|
||||
deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict _refLogUpdData)
|
||||
& toMPlus
|
||||
toMPlus $
|
||||
( deserialiseOrFail (LBS.fromStrict _refLogUpdData) & either (const Nothing) fromAnn )
|
||||
<|>
|
||||
( deserialiseOrFail (LBS.fromStrict _refLogUpdData) & either (const Nothing) fromSeq )
|
||||
|
||||
where
|
||||
fromAnn = \case
|
||||
AnnotatedHashRef _ h -> Just (TxSegment h)
|
||||
|
||||
fromSeq = \case
|
||||
(SequentialRef n (AnnotatedHashRef _ h)) -> Just $ TxCheckpoint (fromIntegral n) h
|
||||
|
||||
updateReflogIndex :: forall m . ( Git3Perks m
|
||||
, MonadReader Git3Env m
|
||||
|
|
@ -335,45 +348,46 @@ updateReflogIndex = do
|
|||
Left{} -> throwIO MissedBlockError
|
||||
Right (hs :: [HashRef]) -> do
|
||||
for_ [h | h <- hs, not (HS.member h written)] $ \h -> void $ runMaybeT do
|
||||
readTxMay sto (coerce h) >>= \case
|
||||
Nothing -> mzero
|
||||
Just (TxCheckpoint{}) -> mzero
|
||||
Just (TxSegment href) -> do
|
||||
-- FIXME: error logging
|
||||
chunks <- liftIO (runExceptT (getTreeContents sto href))
|
||||
>>= orThrow MissedBlockError
|
||||
<&> LBS.toChunks
|
||||
|
||||
AnnotatedHashRef _ href <- readTxMay sto (coerce h) >>= toMPlus
|
||||
what <- toMPlus =<< liftIO do
|
||||
init <- decompress
|
||||
flip fix (init, chunks, mempty :: LBS.ByteString) $ \next -> \case
|
||||
|
||||
-- FIXME: error logging
|
||||
chunks <- liftIO (runExceptT (getTreeContents sto href))
|
||||
>>= orThrow MissedBlockError
|
||||
<&> LBS.toChunks
|
||||
(Consume work, [], o) -> do
|
||||
r1 <- work ""
|
||||
next (r1, [], o)
|
||||
|
||||
what <- toMPlus =<< liftIO do
|
||||
init <- decompress
|
||||
flip fix (init, chunks, mempty :: LBS.ByteString) $ \next -> \case
|
||||
(Consume work, e:es, o) -> do
|
||||
r1 <- work e
|
||||
next (r1, es, o)
|
||||
|
||||
(Consume work, [], o) -> do
|
||||
r1 <- work ""
|
||||
next (r1, [], o)
|
||||
(Produce piece r, e, o) -> do
|
||||
r1 <- r
|
||||
next (r1, e, LBS.append o (LBS.fromStrict piece))
|
||||
|
||||
(Consume work, e:es, o) -> do
|
||||
r1 <- work e
|
||||
next (r1, es, o)
|
||||
(ZStdS.Done bs, _, o) -> pure (Just (LBS.append o (LBS.fromStrict bs)))
|
||||
|
||||
(Produce piece r, e, o) -> do
|
||||
r1 <- r
|
||||
next (r1, e, LBS.append o (LBS.fromStrict piece))
|
||||
(Error _ _, _, _) -> do
|
||||
debug $ "not a valid segment" <+> pretty h
|
||||
pure Nothing
|
||||
|
||||
(ZStdS.Done bs, _, o) -> pure (Just (LBS.append o (LBS.fromStrict bs)))
|
||||
guard (LBS.length what > 0)
|
||||
|
||||
(Error _ _, _, _) -> do
|
||||
debug $ "not a valid segment" <+> pretty h
|
||||
pure Nothing
|
||||
notice $ "unpacked!" <+> pretty h <+> pretty (LBS.length what)
|
||||
|
||||
guard (LBS.length what > 0)
|
||||
pieces <- S.toList_ $ do
|
||||
void $ runConsumeLBS what $ readLogFileLBS () $ \o _ _ -> do
|
||||
lift $ S.yield o
|
||||
|
||||
notice $ "unpacked!" <+> pretty h <+> pretty (LBS.length what)
|
||||
|
||||
pieces <- S.toList_ $ do
|
||||
void $ runConsumeLBS what $ readLogFileLBS () $ \o _ _ -> do
|
||||
lift $ S.yield o
|
||||
|
||||
lift $ S.yield (h, pieces)
|
||||
lift $ S.yield (h, pieces)
|
||||
|
||||
liftIO $ forConcurrently_ sink $ \(tx, pieces) -> do
|
||||
idxName <- emptyTempFile idxPath "objects-.idx"
|
||||
|
|
|
|||
Loading…
Reference in New Issue