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

lwwref content download

This commit is contained in:
Dmitry Zuikov 2024-03-13 07:05:15 +03:00
parent 6ebd09e596
commit 6d348cfd50
3 changed files with 21 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
hbs2-peer/app/PeerMain.hs
View File

@ -1004,6 +1004,10 @@ runPeer opts = Exception.handle (\e -> myException e
err $ red "Exception" <+> "in thread" <+> pretty t <+> viaShow e err $ red "Exception" <+> "in thread" <+> pretty t <+> viaShow e
liftIO $ throwTo myself GoAgainException liftIO $ throwTo myself GoAgainException
let lwwRefProtoA = lwwRefProto (LWWRefProtoAdapter { lwwFetchBlock = download })
where download h = withPeerM env $ withDownload denv (addDownload Nothing h)
flip runContT pure do flip runContT pure do
peerThread "local multicast" $ forever $ do peerThread "local multicast" $ forever $ do
@ -1054,7 +1058,7 @@ runPeer opts = Exception.handle (\e -> myException e
, makeResponse (refChanRequestProto False refChanAdapter) , makeResponse (refChanRequestProto False refChanAdapter)
, makeResponse (refChanNotifyProto False refChanAdapter) , makeResponse (refChanNotifyProto False refChanAdapter)
-- TODO: change-all-to-authorized -- TODO: change-all-to-authorized
, makeResponse ((authorized . subscribed (SomeBrains brains)) lwwRefProto) , makeResponse ((authorized . subscribed (SomeBrains brains)) lwwRefProtoA)
] ]

4
hbs2-peer/app/RPC2/LWWRef.hs
View File

@ -63,12 +63,14 @@ instance LWWRefContext m => HandleMethod m RpcLWWRefUpdate where
let penv = rpcPeerEnv co let penv = rpcPeerEnv co
let nada = LWWRefProtoAdapter dontHandle
void $ runMaybeT do void $ runMaybeT do
(puk, _) <- unboxSignedBox0 box & toMPlus (puk, _) <- unboxSignedBox0 box & toMPlus
liftIO $ withPeerM penv do liftIO $ withPeerM penv do
me <- ownPeer @L4Proto me <- ownPeer @L4Proto
runResponseM me $ do runResponseM me $ do
lwwRefProto (LWWRefProto1 (LWWProtoSet @L4Proto (LWWRefKey puk) box)) lwwRefProto nada (LWWRefProto1 (LWWProtoSet @L4Proto (LWWRefKey puk) box))

17
hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs
View File

@ -28,6 +28,12 @@ import Data.Maybe
{- HLINT ignore "Functor law" -} {- HLINT ignore "Functor law" -}
data LWWRefProtoAdapter e m =
LWWRefProtoAdapter
{ lwwFetchBlock :: Hash HbSync -> m ()
}
lwwRefProto :: forall e s m proto . ( MonadIO m lwwRefProto :: forall e s m proto . ( MonadIO m
, ForLWWRefProto e , ForLWWRefProto e
, Request e proto m , Request e proto m
@ -43,9 +49,10 @@ lwwRefProto :: forall e s m proto . ( MonadIO m
, s ~ Encryption e , s ~ Encryption e
, proto ~ LWWRefProto 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" debug $ yellow "lwwRefProto"
case req of case req of
@ -79,9 +86,11 @@ lwwRefProto pkt@(LWWRefProto1 req) = do
when new do when new do
lift $ gossip pkt lift $ gossip pkt
lift $ lwwFetchBlock adapter (fromHashRef (lwwValue lww))
getRef sto key >>= \case getRef sto key >>= \case
Nothing -> do Nothing -> do
h <- putBlock sto bs >>= toMPlus h <- enqueueBlock sto bs >>= toMPlus
updateRef sto key h updateRef sto key h
Just rv -> do Just rv -> do
@ -98,6 +107,6 @@ lwwRefProto pkt@(LWWRefProto1 req) = do
where where
forcedUpdateLwwRef sto key bs = do forcedUpdateLwwRef sto key bs = do
h' <- putBlock sto bs h' <- enqueueBlock sto bs
forM_ h' $ updateRef sto key forM_ h' $ updateRef sto key