diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index fbed91b3..3c321d92 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -1004,6 +1004,10 @@ runPeer opts = Exception.handle (\e -> myException e err $ red "Exception" <+> "in thread" <+> pretty t <+> viaShow e liftIO $ throwTo myself GoAgainException + + let lwwRefProtoA = lwwRefProto (LWWRefProtoAdapter { lwwFetchBlock = download }) + where download h = withPeerM env $ withDownload denv (addDownload Nothing h) + flip runContT pure do peerThread "local multicast" $ forever $ do @@ -1054,7 +1058,7 @@ runPeer opts = Exception.handle (\e -> myException e , makeResponse (refChanRequestProto False refChanAdapter) , makeResponse (refChanNotifyProto False refChanAdapter) -- TODO: change-all-to-authorized - , makeResponse ((authorized . subscribed (SomeBrains brains)) lwwRefProto) + , makeResponse ((authorized . subscribed (SomeBrains brains)) lwwRefProtoA) ] diff --git a/hbs2-peer/app/RPC2/LWWRef.hs b/hbs2-peer/app/RPC2/LWWRef.hs index 0f8594bf..2292aac1 100644 --- a/hbs2-peer/app/RPC2/LWWRef.hs +++ b/hbs2-peer/app/RPC2/LWWRef.hs @@ -63,12 +63,14 @@ instance LWWRefContext m => HandleMethod m RpcLWWRefUpdate where let penv = rpcPeerEnv co + let nada = LWWRefProtoAdapter dontHandle + void $ runMaybeT do (puk, _) <- unboxSignedBox0 box & toMPlus liftIO $ withPeerM penv do me <- ownPeer @L4Proto runResponseM me $ do - lwwRefProto (LWWRefProto1 (LWWProtoSet @L4Proto (LWWRefKey puk) box)) + lwwRefProto nada (LWWRefProto1 (LWWProtoSet @L4Proto (LWWRefKey puk) box)) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs index 7de39732..55e76ea6 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs @@ -28,6 +28,12 @@ import Data.Maybe {- HLINT ignore "Functor law" -} + +data LWWRefProtoAdapter e m = + LWWRefProtoAdapter + { lwwFetchBlock :: Hash HbSync -> m () + } + lwwRefProto :: forall e s m proto . ( MonadIO m , ForLWWRefProto e , Request e proto m @@ -43,9 +49,10 @@ lwwRefProto :: forall e s m proto . ( MonadIO m , s ~ Encryption e , proto ~ LWWRefProto e ) - => LWWRefProto e -> m () + => LWWRefProtoAdapter e m + -> LWWRefProto e -> m () -lwwRefProto pkt@(LWWRefProto1 req) = do +lwwRefProto adapter pkt@(LWWRefProto1 req) = do debug $ yellow "lwwRefProto" case req of @@ -79,9 +86,11 @@ lwwRefProto pkt@(LWWRefProto1 req) = do when new do lift $ gossip pkt + lift $ lwwFetchBlock adapter (fromHashRef (lwwValue lww)) + getRef sto key >>= \case Nothing -> do - h <- putBlock sto bs >>= toMPlus + h <- enqueueBlock sto bs >>= toMPlus updateRef sto key h Just rv -> do @@ -98,6 +107,6 @@ lwwRefProto pkt@(LWWRefProto1 req) = do where forcedUpdateLwwRef sto key bs = do - h' <- putBlock sto bs + h' <- enqueueBlock sto bs forM_ h' $ updateRef sto key