mirror of https://github.com/voidlizard/hbs2
96 lines
2.8 KiB
Haskell
96 lines
2.8 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# Language UndecidableInstances #-}
|
|
module RPC2.RefLog
|
|
( module RPC2.RefLog
|
|
, module HBS2.Peer.RPC.Internal.Types
|
|
) where
|
|
|
|
import HBS2.Prelude.Plated
|
|
|
|
import HBS2.Actors.Peer
|
|
import HBS2.Hash
|
|
import HBS2.Base58
|
|
import HBS2.Data.Types.Refs (HashRef(..))
|
|
import HBS2.Events
|
|
import HBS2.Net.Proto.Definition()
|
|
import HBS2.Net.Proto.RefLog
|
|
import HBS2.Net.Proto.Service
|
|
import HBS2.Net.Proto.Types
|
|
import HBS2.Storage
|
|
import HBS2.Net.Messaging.Unix
|
|
|
|
import HBS2.System.Logger.Simple
|
|
import PeerTypes
|
|
import RefLog (doRefLogBroadCast)
|
|
|
|
import HBS2.Peer.RPC.Internal.Types
|
|
|
|
import Data.Functor
|
|
import Lens.Micro.Platform
|
|
import Data.ByteString.Lazy ( ByteString )
|
|
import Codec.Serialise
|
|
import Control.Monad.Reader
|
|
|
|
data RpcRefLogGet
|
|
data RpcRefLogFetch
|
|
data RpcRefLogPost
|
|
|
|
type RefLogAPI = '[ RpcRefLogGet
|
|
, RpcRefLogFetch
|
|
, RpcRefLogPost
|
|
]
|
|
|
|
|
|
type RefLogContext m = (MonadIO m, HasRpcContext RefLogAPI RPC2Context m)
|
|
|
|
instance HasProtocol UNIX (ServiceProto RefLogAPI UNIX) where
|
|
type instance ProtocolId (ServiceProto RefLogAPI UNIX) = 0xDA2371620001
|
|
type instance Encoded UNIX = ByteString
|
|
decode = either (const Nothing) Just . deserialiseOrFail
|
|
encode = serialise
|
|
|
|
|
|
instance (Monad m)
|
|
=> HasRpcContext RefLogAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where
|
|
-- type instance RpcContext RefLogAPI = RPC2Context
|
|
getRpcContext = lift ask
|
|
|
|
instance (RefLogContext m) => HandleMethod m RpcRefLogGet where
|
|
type instance Input RpcRefLogGet = PubKey 'Sign HBS2Basic
|
|
type instance Output RpcRefLogGet = Maybe HashRef
|
|
|
|
handleMethod pk = do
|
|
co <- getRpcContext @RefLogAPI
|
|
debug $ "rpc2.reflogGet:" <+> pretty (AsBase58 pk)
|
|
<+> pretty (hashObject @HbSync (RefLogKey @HBS2Basic pk))
|
|
|
|
liftIO $ withPeerM (rpcPeerEnv co) $ do
|
|
let sto = rpcStorage co
|
|
liftIO (getRef sto (RefLogKey @HBS2Basic pk)) <&> fmap HashRef
|
|
|
|
instance (RefLogContext m) => HandleMethod m RpcRefLogFetch where
|
|
type instance Input RpcRefLogFetch = PubKey 'Sign HBS2Basic
|
|
type instance Output RpcRefLogFetch = ()
|
|
|
|
handleMethod pk = do
|
|
co <- getRpcContext @RefLogAPI
|
|
debug $ "rpc2.reflogFetch:" <+> pretty (AsBase58 pk)
|
|
|
|
liftIO $ withPeerM (rpcPeerEnv co) $ do
|
|
broadCastMessage (RefLogRequest @L4Proto pk)
|
|
|
|
instance (RefLogContext m) => HandleMethod m RpcRefLogPost where
|
|
type instance Input RpcRefLogPost = RefLogUpdate L4Proto
|
|
type instance Output RpcRefLogPost = ()
|
|
|
|
handleMethod msg = do
|
|
co <- getRpcContext @RefLogAPI
|
|
let pk = view refLogId msg
|
|
debug $ "rpc2.reflogPost:" <+> pretty (AsBase58 pk)
|
|
|
|
liftIO $ withPeerM (rpcPeerEnv co) $ do
|
|
emit @L4Proto RefLogUpdateEvKey (RefLogUpdateEvData (pk, msg))
|
|
doRefLogBroadCast msg
|
|
|
|
|