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

not-good

This commit is contained in:
Dmitry Zuikov 2024-08-08 05:25:59 +03:00
parent 7b69d85dd9
commit 7e0305891b
2 changed files with 29 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs
View File

@ -1,4 +1,5 @@
{-# Language AllowAmbiguousTypes #-} {-# Language AllowAmbiguousTypes #-}
{-# Language UndecidableInstances #-}
module HBS2.Peer.RPC.Client.RefChan where module HBS2.Peer.RPC.Client.RefChan where
import HBS2.OrDie import HBS2.OrDie
@ -134,6 +135,8 @@ data RefChanUpdateUnpacked e =
A (AcceptTran e) | P HashRef (ProposeTran e) A (AcceptTran e) | P HashRef (ProposeTran e)
deriving stock (Generic) deriving stock (Generic)
instance ForRefChans e => Serialise (RefChanUpdateUnpacked e)
{-# COMPLETE A,P #-} {-# COMPLETE A,P #-}
walkRefChanTx :: forall proto m . ( MonadIO m walkRefChanTx :: forall proto m . ( MonadIO m

32
hbs2-sync/src/HBS2/Sync/Prelude.hs
View File

@ -822,7 +822,7 @@ mergeState seed orig = do
-- впоследствии -- впоследствии
-- --
getStateFromDir0 :: ( MonadIO m getStateFromDir0 :: ( MonadUnliftIO m
, HasClientAPI RefChanAPI UNIX m , HasClientAPI RefChanAPI UNIX m
, HasClientAPI StorageAPI UNIX m , HasClientAPI StorageAPI UNIX m
, HasStorage m , HasStorage m
@ -841,7 +841,7 @@ getStateFromDir0 seed = do
getStateFromDir seed dir incl excl getStateFromDir seed dir incl excl
getStateFromDir :: ( MonadIO m getStateFromDir :: ( MonadUnliftIO m
, HasClientAPI RefChanAPI UNIX m , HasClientAPI RefChanAPI UNIX m
, HasClientAPI StorageAPI UNIX m , HasClientAPI StorageAPI UNIX m
, HasStorage m , HasStorage m
@ -883,24 +883,44 @@ getStateFromDir seed path incl excl = do
S.yield (p,e) S.yield (p,e)
getStateFromRefChan :: forall m . ( MonadIO m getStateFromRefChan :: forall m . ( MonadUnliftIO m
, HasClientAPI RefChanAPI UNIX m , HasClientAPI RefChanAPI UNIX m
, HasClientAPI StorageAPI UNIX m , HasClientAPI StorageAPI UNIX m
, HasStorage m , HasStorage m
, HasRunDir m
) )
=> MyRefChan => MyRefChan
-> m [(FilePath, Entry)] -> m [(FilePath, Entry)]
getStateFromRefChan rchan = do getStateFromRefChan rchan = flip runContT pure do
cacheFile <- getRunDir <&> (</> ".hbs2-sync/state/txcache")
debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan) debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan)
sto <- getStorage cache <- ContT $ bracket (compactStorageOpen mempty cacheFile) compactStorageClose
sto <- lift getStorage
outq <- newTQueueIO outq <- newTQueueIO
tss <- newTVarIO mempty tss <- newTVarIO mempty
let check h = Compact.getValEither @(RefChanUpdateUnpacked L4Proto) cache h
<&> either (const True) isNothing
lift $ walkRefChanTx @UNIX check rchan $ \txh -> \case
tx -> Compact.putVal cache txh tx
txhashes <- Compact.keys cache
<&> fmap (deserialiseOrFail @HashRef . LBS.fromStrict)
<&> rights
vals <- mapM (Compact.getValEither @(RefChanUpdateUnpacked L4Proto) cache) txhashes
<&> rights
<&> catMaybes
-- FIXME: may-be-slow -- FIXME: may-be-slow
walkRefChanTx @UNIX (const $ pure True) rchan $ \txh -> \case for_ vals $ \case
A (AcceptTran ts _ what) -> do A (AcceptTran ts _ what) -> do
-- debug $ red "ACCEPT" <+> pretty ts <+> pretty what -- debug $ red "ACCEPT" <+> pretty ts <+> pretty what
for_ ts $ \w -> do for_ ts $ \w -> do