mirror of https://github.com/voidlizard/hbs2
118 lines
3.4 KiB
Haskell
118 lines
3.4 KiB
Haskell
module HBS2.Peer.Proto.LWWRef.Internal
|
|
( module HBS2.Peer.Proto.LWWRef.Internal
|
|
, module HBS2.Peer.Proto.LWWRef
|
|
) where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Peer.Proto.LWWRef
|
|
import HBS2.Data.Types.SignedBox
|
|
import HBS2.Storage
|
|
|
|
import HBS2.Hash
|
|
import HBS2.Clock
|
|
import HBS2.Net.Proto
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Base58
|
|
import HBS2.Events
|
|
import HBS2.Actors.Peer.Types
|
|
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
|
|
|
|
{- 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
|
|
, Response e proto m
|
|
, HasDeferred proto e m
|
|
, HasGossip e (LWWRefProto e) m
|
|
, HasStorage m
|
|
, IsPeerAddr e m
|
|
, Pretty (Peer e)
|
|
, Sessions e (KnownPeer e) m
|
|
, Signatures s
|
|
, Pretty (AsBase58 (PubKey 'Sign s))
|
|
, s ~ Encryption e
|
|
, proto ~ LWWRefProto e
|
|
)
|
|
=> LWWRefProtoAdapter e m
|
|
-> LWWRefProto e -> m ()
|
|
|
|
lwwRefProto adapter pkt@(LWWRefProto1 req) = do
|
|
debug $ yellow "lwwRefProto"
|
|
|
|
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
|
|
|
|
(puk, lww) <- MaybeT $ pure $ unboxSignedBox0 box
|
|
|
|
guard ( puk == fromLwwRefKey key )
|
|
|
|
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
|
|
|
|
lift $ lwwFetchBlock adapter (fromHashRef (lwwValue lww))
|
|
|
|
getRef sto key >>= \case
|
|
Nothing -> do
|
|
h <- enqueueBlock sto bs >>= toMPlus
|
|
updateRef sto key h
|
|
|
|
Just rv -> do
|
|
blk' <- getBlock sto rv
|
|
maybe1 blk' (forcedUpdateLwwRef sto key bs) $ \blk -> do
|
|
|
|
let lww0 = deserialiseOrFail @(SignedBox (LWWRef e) e) blk
|
|
& either (const Nothing) Just
|
|
>>= unboxSignedBox0
|
|
<&> snd
|
|
|
|
let seq0 = lwwSeq <$> lww0
|
|
let lwwv0 = lwwValue <$> lww0
|
|
|
|
when ( Just (lwwSeq lww) > seq0
|
|
|| (Just (lwwSeq lww) == seq0 && Just (lwwValue lww) > lwwv0)
|
|
) do
|
|
forcedUpdateLwwRef sto key (serialise box)
|
|
|
|
where
|
|
forcedUpdateLwwRef sto key bs = do
|
|
h' <- enqueueBlock sto bs
|
|
forM_ h' $ updateRef sto key
|
|
|