mirror of https://github.com/voidlizard/hbs2
89 lines
2.7 KiB
Haskell
89 lines
2.7 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# Language UndecidableInstances #-}
|
|
module RPC2.RefChan
|
|
( module RPC2.RefChan
|
|
, module HBS2.Peer.RPC.Internal.Types
|
|
) where
|
|
|
|
import HBS2.Peer.Prelude
|
|
|
|
import HBS2.Actors.Peer
|
|
import HBS2.Base58
|
|
import HBS2.Data.Types.Refs (HashRef(..))
|
|
import HBS2.Net.Proto.Service
|
|
import HBS2.Peer.Proto.RefChan
|
|
import HBS2.Net.Messaging.Unix
|
|
import HBS2.Storage
|
|
|
|
import HBS2.Peer.RPC.API.RefChan
|
|
import HBS2.Peer.RPC.Internal.Types
|
|
|
|
import PeerTypes
|
|
|
|
import Control.Monad.Reader
|
|
|
|
type RefChanContext m = (MonadIO m, HasRpcContext RefChanAPI RPC2Context m)
|
|
|
|
instance (Monad m)
|
|
=> HasRpcContext RefChanAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where
|
|
-- type instance RpcContext RefChanAPI = RPC2Context
|
|
getRpcContext = lift ask
|
|
|
|
instance RefChanContext m => HandleMethod m RpcRefChanHeadGet where
|
|
|
|
handleMethod puk = do
|
|
co <- getRpcContext @RefChanAPI
|
|
let penv = rpcPeerEnv co
|
|
debug $ "rpc.refchanHeadGet:" <+> pretty (AsBase58 puk)
|
|
liftIO $ withPeerM penv $ do
|
|
sto <- getStorage
|
|
liftIO $ getRef sto (RefChanHeadKey @'HBS2Basic puk) <&> fmap HashRef
|
|
|
|
instance (RefChanContext m) => HandleMethod m RpcRefChanHeadFetch where
|
|
|
|
handleMethod puk = do
|
|
debug $ "rpc.refchanHeadFetch:" <+> pretty (AsBase58 puk)
|
|
penv <- rpcPeerEnv <$> getRpcContext @RefChanAPI
|
|
void $ liftIO $ withPeerM penv $ do
|
|
broadCastMessage (RefChanGetHead @L4Proto puk)
|
|
|
|
instance RefChanContext m => HandleMethod m RpcRefChanFetch where
|
|
|
|
handleMethod puk = do
|
|
debug $ "rpc.refchanFetch:" <+> pretty (AsBase58 puk)
|
|
penv <- rpcPeerEnv <$> getRpcContext @RefChanAPI
|
|
void $ liftIO $ withPeerM penv $ do
|
|
gossip (RefChanRequest @L4Proto puk)
|
|
|
|
instance RefChanContext m => HandleMethod m RpcRefChanGet where
|
|
|
|
handleMethod puk = do
|
|
co <- getRpcContext @RefChanAPI
|
|
let penv = rpcPeerEnv co
|
|
debug $ "rpc.refchanGet:" <+> pretty (AsBase58 puk)
|
|
liftIO $ withPeerM penv $ do
|
|
sto <- getStorage
|
|
liftIO $ getRef sto (RefChanLogKey @'HBS2Basic puk) <&> fmap HashRef
|
|
|
|
instance RefChanContext m => HandleMethod m RpcRefChanPropose where
|
|
|
|
handleMethod (puk, box) = do
|
|
co <- getRpcContext @RefChanAPI
|
|
debug $ "rpc.refChanNotifyAction" <+> pretty (AsBase58 puk)
|
|
liftIO $ rpcDoRefChanPropose co (puk, box)
|
|
|
|
|
|
instance RefChanContext m => HandleMethod m RpcRefChanNotify where
|
|
|
|
handleMethod (puk, box) = do
|
|
co <- getRpcContext @RefChanAPI
|
|
debug $ "rpc.refChanNotifyAction" <+> pretty (AsBase58 puk)
|
|
liftIO $ rpcDoRefChanNotify co (puk, box)
|
|
|
|
instance RefChanContext m => HandleMethod m RpcRefChanHeadPost where
|
|
|
|
handleMethod href = do
|
|
co <- getRpcContext @RefChanAPI
|
|
liftIO $ rpcDoRefChanHeadPost co href
|
|
|