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

Revert "not-good" 

This reverts commit 7e0305891b.
This commit is contained in:
Dmitry Zuikov 2024-08-08 05:26:47 +03:00
parent 8a8e347a35
commit 2761af5d60
2 changed files with 6 additions and 29 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,5 +1,4 @@
{-# 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
@ -135,8 +134,6 @@ 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 :: ( MonadUnliftIO m getStateFromDir0 :: ( MonadIO 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 :: ( MonadUnliftIO m getStateFromDir :: ( MonadIO m
, HasClientAPI RefChanAPI UNIX m , HasClientAPI RefChanAPI UNIX m
, HasClientAPI StorageAPI UNIX m , HasClientAPI StorageAPI UNIX m
, HasStorage m , HasStorage m
@ -883,44 +883,24 @@ getStateFromDir seed path incl excl = do
S.yield (p,e) S.yield (p,e)
getStateFromRefChan :: forall m . ( MonadUnliftIO m getStateFromRefChan :: forall m . ( MonadIO 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 = flip runContT pure do getStateFromRefChan rchan = do
cacheFile <- getRunDir <&> (</> ".hbs2-sync/state/txcache")
debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan) debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan)
cache <- ContT $ bracket (compactStorageOpen mempty cacheFile) compactStorageClose sto <- getStorage
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
for_ vals $ \case walkRefChanTx @UNIX (const $ pure True) rchan $ \txh -> \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