mirror of https://github.com/voidlizard/hbs2
103 lines
3.3 KiB
Haskell
103 lines
3.3 KiB
Haskell
{-# Language UndecidableInstances #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module HBS2.Peer.Proto.RefChan.RefChanNotify where
|
|
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Hash
|
|
import HBS2.Net.Proto
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Events
|
|
import HBS2.Peer.Proto.Peer
|
|
import HBS2.Net.Proto.Sessions
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Data.Types.SignedBox
|
|
import HBS2.Actors.Peer.Types
|
|
import HBS2.Storage
|
|
|
|
import HBS2.Peer.Proto.RefChan.Types
|
|
|
|
import HBS2.System.Logger.Simple
|
|
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.Maybe
|
|
|
|
refChanNotifyProto :: forall e s m proto . ( MonadIO m
|
|
, Request e proto m
|
|
, Response e proto m
|
|
, HasRefChanId e proto
|
|
, HasDeferred proto e m
|
|
, HasGossip e proto m
|
|
, IsPeerAddr e m
|
|
, Pretty (Peer e)
|
|
, Sessions e (RefChanHeadBlock e) m
|
|
, Sessions e (KnownPeer e) m
|
|
, EventEmitter e proto m
|
|
, HasStorage m
|
|
, Signatures s
|
|
, IsRefPubKey s
|
|
, ForRefChans e
|
|
, proto ~ RefChanNotify e
|
|
, s ~ Encryption e
|
|
)
|
|
=> Bool
|
|
-> RefChanAdapter e m
|
|
-> RefChanNotify e
|
|
-> m ()
|
|
|
|
refChanNotifyProto self adapter msg@(ActionRequest rchan a) = do
|
|
debug $ "RefChanNotify ACTION REQUEST"
|
|
pure ()
|
|
|
|
refChanNotifyProto self adapter msg@(Notify rchan box) = do
|
|
-- аутентифицируем
|
|
-- проверяем ACL
|
|
-- пересылаем всем
|
|
|
|
sto <- getStorage
|
|
|
|
peer <- thatPeer @proto
|
|
|
|
let h0 = hashObject @HbSync (serialise msg)
|
|
|
|
auth <- find (KnownPeerKey peer) id <&> isJust
|
|
|
|
void $ runMaybeT do
|
|
|
|
guard =<< lift (refChanSubscribed adapter rchan)
|
|
|
|
guard (self || auth)
|
|
|
|
debug $ "&&& refChanNotifyProto" <+> pretty self
|
|
|
|
deferred @proto do
|
|
|
|
guard =<< liftIO (hasBlock sto h0 <&> isNothing)
|
|
|
|
(authorKey, bs) <- MaybeT $ pure $ unboxSignedBox0 box
|
|
|
|
let refchanKey = RefChanHeadKey @s rchan
|
|
headBlock <- MaybeT $ getActualRefChanHead @e refchanKey
|
|
|
|
guard $ checkACL headBlock Nothing authorKey
|
|
|
|
-- FIXME: garbage-collection-required
|
|
liftIO $ putBlock sto (serialise msg)
|
|
|
|
-- теперь пересылаем по госсипу
|
|
lift $ gossip msg
|
|
|
|
-- FIXME: remove-debug
|
|
let h1 = hashObject @HbSync (serialise box)
|
|
debug $ "^^^ refChanNotifyProto" <+> pretty peer <+> pretty h0 <+> pretty h1
|
|
|
|
-- тут надо заслать во внешнее приложение,
|
|
-- равно как и в остальных refchan-протоколах
|
|
|
|
unless self do
|
|
debug $ "^^^ CALL refChanNotifyRely" <+> pretty h0
|
|
lift $ refChanNotifyRely adapter rchan msg
|
|
|
|
lift $ emit @e (RefChanNotifyEventKey rchan) (RefChanNotifyEvent (HashRef h0) msg)
|
|
|