lwwref proto skeleton / compiles

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)
                     ]
 
 

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

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)

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