mirror of https://github.com/voidlizard/hbs2
92 lines
2.8 KiB
Haskell
92 lines
2.8 KiB
Haskell
{-# Language PatternSynonyms #-}
|
|
{-# Language ViewPatterns #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module HBS2.Peer.RPC.Client.RefLog where
|
|
|
|
import HBS2.OrDie
|
|
import HBS2.Storage
|
|
import HBS2.Merkle
|
|
import HBS2.Storage.Operations.ByteString
|
|
import HBS2.Data.Types.SignedBox
|
|
|
|
import HBS2.Peer.Proto.RefLog
|
|
import HBS2.Peer.Prelude
|
|
import HBS2.Peer.RPC.API.RefLog
|
|
import HBS2.Peer.RPC.API.Storage
|
|
import HBS2.Peer.RPC.Client.Internal
|
|
import HBS2.Peer.RPC.Client.StorageClient
|
|
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.ByteString (ByteString)
|
|
import Data.Coerce
|
|
import Control.Monad.Except
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.Trans.Cont
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Identity
|
|
import Codec.Serialise
|
|
import UnliftIO
|
|
|
|
|
|
data RefLogClientException =
|
|
RefLogClientRpcTimeout
|
|
deriving (Typeable, Show)
|
|
|
|
instance Exception RefLogClientException
|
|
|
|
getRefLogValue :: forall proto m . ( MonadUnliftIO m
|
|
, HasClientAPI RefLogAPI proto m
|
|
, HasProtocol proto (ServiceProto RefLogAPI proto)
|
|
, HasStorage m
|
|
)
|
|
=> PubKey Sign HBS2Basic
|
|
-> m (Maybe HashRef)
|
|
|
|
getRefLogValue pk = do
|
|
api <- getClientAPI @RefLogAPI @proto
|
|
callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) api pk
|
|
>>= orThrow RefLogClientRpcTimeout
|
|
|
|
walkRefLogTx :: forall proto m . ( MonadUnliftIO m
|
|
, HasClientAPI RefLogAPI proto m
|
|
, HasProtocol proto (ServiceProto RefLogAPI proto)
|
|
, HasStorage m
|
|
, Signatures (Encryption L4Proto)
|
|
, IsRefPubKey (Encryption L4Proto)
|
|
, Serialise (Nonce (RefLogUpdate L4Proto))
|
|
, Serialise (Signature (Encryption L4Proto))
|
|
)
|
|
=> (HashRef -> m Bool)
|
|
-> PubKey 'Sign 'HBS2Basic
|
|
-> (HashRef -> ByteString -> m ())
|
|
-> m ()
|
|
walkRefLogTx filt puk action = do
|
|
sto <- getStorage
|
|
|
|
flip runContT pure $ callCC $ \exit -> do
|
|
|
|
rcv' <- lift $ getRefLogValue @proto puk
|
|
|
|
rcv <- ContT $ maybe1 rcv' none
|
|
|
|
walkMerkle (coerce rcv) (getBlock sto) $ \case
|
|
-- FIXME: error-handling
|
|
Left _ -> exit ()
|
|
|
|
Right (hs :: [HashRef]) -> do
|
|
for_ hs $ \h -> do
|
|
-- want <- lift (filt h)
|
|
-- when want do
|
|
lbs' <- getBlock sto (coerce h)
|
|
lbs <- ContT $ maybe1 lbs' none
|
|
RefLogUpdate{..} <- ContT $ maybe1 (unpackRU h lbs) none
|
|
lift $ action h _refLogUpdData
|
|
|
|
where
|
|
unpackRU h lbs = do
|
|
deserialiseOrFail @(RefLogUpdate L4Proto) lbs
|
|
& either (const Nothing) Just
|
|
|
|
|
|
|