From aa2688c0a38841f8b26ce0cefb55ccc807051f20 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 12 Mar 2024 10:53:54 +0300 Subject: [PATCH] lwwref proto skeleton / compiles --- hbs2-peer/app/PeerMain.hs | 2 +- hbs2-peer/app/PeerTypes.hs | 28 ++++++++ hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs | 8 +-- .../lib/HBS2/Peer/Proto/LWWRef/Internal.hs | 64 +++++++++++++++++-- 4 files changed, 90 insertions(+), 12 deletions(-) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 93dba7a1..89c6c3a7 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -1049,7 +1049,7 @@ runPeer opts = Exception.handle (\e -> myException e , makeResponse (refChanRequestProto False refChanAdapter) , makeResponse (refChanNotifyProto False refChanAdapter) -- TODO: change-all-to-authorized - , makeResponse (authorized lwwRefProto) + , makeResponse ((authorized . subscribed (SomeBrains brains)) lwwRefProto) ] diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index 287e61e7..2bf08a35 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -3,6 +3,7 @@ {-# Language UndecidableInstances #-} {-# Language AllowAmbiguousTypes #-} {-# Language MultiWayIf #-} +{-# Language FunctionalDependencies #-} module PeerTypes ( module PeerTypes , module PeerLogger @@ -13,6 +14,8 @@ module PeerTypes import HBS2.Polling import HBS2.Actors.Peer import HBS2.Clock +import HBS2.Net.Auth.Schema +import HBS2.Net.Auth.Credentials import HBS2.Data.Types.SignedBox import HBS2.Data.Types.Peer import HBS2.Data.Types.Refs @@ -24,6 +27,7 @@ import HBS2.Net.IP.Addr import HBS2.Net.Proto import HBS2.Peer.Proto.Peer import HBS2.Peer.Proto.BlockInfo +import HBS2.Peer.Proto.LWWRef import HBS2.Net.Proto.Sessions import HBS2.Prelude.Plated import HBS2.Storage @@ -481,6 +485,30 @@ simpleBlockAnnounce size h = do pure $ BlockAnnounce @e no annInfo +class IsPolledKey e proto | proto -> e where + getPolledKey :: proto -> PubKey 'Sign (Encryption e) + +instance IsPolledKey e (LWWRefProto e) where + getPolledKey = \case + LWWRefProto1 (LWWProtoGet (LWWRefKey k)) -> k + LWWRefProto1 (LWWProtoSet (LWWRefKey k) _) -> k + +subscribed :: forall e proto m . ( MonadIO m + , IsPolledKey e proto + , Request e proto m + , Response e proto m + ) + + => SomeBrains e + -> (proto -> m ()) + -> proto + -> m () + +subscribed brains f req = do + let ref = getPolledKey req + polled <- isPolledRef @e brains ref + when polled $ f req + authorized :: forall e proto m . ( MonadIO m , Request e proto m , Response e proto m diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs index 7d2ba2f6..2fedf73f 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs @@ -14,11 +14,9 @@ import Data.Hashable hiding (Hashed) import Data.Maybe import Data.Word -type Epoch = Word64 - data LWWRefProtoReq e = LWWProtoGet (LWWRefKey (Encryption e)) - | LWWProtoSet (SignedBox (LWWRef e) e) + | LWWProtoSet (LWWRefKey (Encryption e)) (SignedBox (LWWRef e) e) deriving stock Generic @@ -28,7 +26,7 @@ data LWWRefProto e = data LWWRef e = LWWRef - { lwwEpoch :: Epoch + { lwwSeq :: Word64 , lwwProof :: Maybe HashRef , lwwValue :: HashRef } @@ -48,6 +46,8 @@ newtype LWWRefKey s = deriving stock (Generic) +instance RefMetaData (LWWRefKey s) + deriving stock instance IsRefPubKey s => Eq (LWWRefKey s) instance IsRefPubKey e => Serialise (LWWRefKey e) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs index 0c30b4d4..292c6456 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs @@ -5,6 +5,7 @@ module HBS2.Peer.Proto.LWWRef.Internal import HBS2.Prelude.Plated import HBS2.Peer.Proto.LWWRef +import HBS2.Data.Types.SignedBox import HBS2.Storage import HBS2.Hash @@ -18,18 +19,17 @@ import HBS2.Peer.Proto.Peer import HBS2.Net.Proto.Sessions import HBS2.Data.Types.Refs import HBS2.Misc.PrettyStuff - import HBS2.System.Logger.Simple +import Codec.Serialise +import Control.Monad import Control.Monad.Trans.Maybe import Data.Maybe -import Data.Hashable hiding (Hashed) -import Data.ByteString (ByteString) -import Type.Reflection (someTypeRep) -import Lens.Micro.Platform +{- HLINT ignore "Functor law" -} lwwRefProto :: forall e s m proto . ( MonadIO m + , ForLWWRefProto e , Request e proto m , Response e proto m , HasDeferred proto e m @@ -45,7 +45,57 @@ lwwRefProto :: forall e s m proto . ( MonadIO m ) => LWWRefProto e -> m () -lwwRefProto req = do +lwwRefProto pkt@(LWWRefProto1 req) = do debug $ yellow "lwwRefProto" - pure () + + case req of + LWWProtoGet key -> deferred @proto $ void $ runMaybeT do + sto <- getStorage + + ref <- getRef sto key >>= toMPlus + + box <- getBlock sto ref + >>= toMPlus + <&> deserialiseOrFail + >>= toMPlus + + lift $ response (LWWRefProto1 (LWWProtoSet @e key box)) + + LWWProtoSet key box -> void $ runMaybeT do + + (_, lww) <- MaybeT $ pure $ unboxSignedBox0 box + + deferred @proto do + + sto <- getStorage + + let bs = serialise box + let h0 = hashObject @HbSync bs + + new <- hasBlock sto h0 <&> isNothing + + when new do + lift $ gossip pkt + + getRef sto key >>= \case + Nothing -> do + h <- putBlock sto bs >>= toMPlus + updateRef sto key h + + Just rv -> do + blk' <- getBlock sto rv + maybe1 blk' (forcedUpdateLwwRef sto key bs) $ \blk -> do + let seq0 = deserialiseOrFail @(SignedBox (LWWRef e) e) blk + & either (const Nothing) Just + >>= unboxSignedBox0 + <&> snd + <&> lwwSeq + + when (Just (lwwSeq lww) > seq0) do + forcedUpdateLwwRef sto key (serialise box) + + where + forcedUpdateLwwRef sto key bs = do + h' <- putBlock sto bs + forM_ h' $ updateRef sto key