mirror of https://github.com/voidlizard/hbs2
142 lines
3.7 KiB
Haskell
142 lines
3.7 KiB
Haskell
{-# LANGUAGE StrictData #-}
|
|
|
|
module RefChanQBLF.RPCServer where
|
|
|
|
import HBS2.Actors.Peer
|
|
import HBS2.Base58
|
|
import HBS2.Data.Types.SignedBox
|
|
import HBS2.Hash
|
|
import HBS2.Net.Messaging.Unix
|
|
import HBS2.Net.Proto.QBLF
|
|
import HBS2.Net.Proto.Service
|
|
import HBS2.System.Logger.Simple
|
|
|
|
import Codec.Serialise
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.Reader
|
|
import Data.ByteString.Lazy (ByteString)
|
|
import Data.Function
|
|
import Data.String.Conversions (cs)
|
|
import Data.Text (Text)
|
|
import Data.Text qualified as T
|
|
import GHC.Generics (Generic)
|
|
import Prettyprinter
|
|
import UnliftIO
|
|
|
|
import RefChanQBLF.Common
|
|
import RefChanQBLF.Impl
|
|
import RefChanQBLF.Transactions
|
|
|
|
data PingRPC
|
|
data PostTxRPC
|
|
|
|
type QBLFAppRPC =
|
|
'[ PingRPC
|
|
, PostTxRPC
|
|
]
|
|
|
|
instance HasProtocol UNIX (ServiceProto QBLFAppRPC UNIX) where
|
|
type ProtocolId (ServiceProto QBLFAppRPC UNIX) = 0x0B1F0B1F
|
|
type Encoded UNIX = ByteString
|
|
decode = either (const Nothing) Just . deserialiseOrFail
|
|
encode = serialise
|
|
|
|
type instance Input PingRPC = ()
|
|
type instance Output PingRPC = Text
|
|
|
|
type instance Input PostTxRPC = QBLFDemoToken 'HBS2Basic
|
|
type instance Output PostTxRPC = Either RPCServerError (Either MyError Text)
|
|
|
|
data QRPCEnv = QRPCEnv
|
|
{ qrpcenvQConsensus :: QBLF ConsensusQBLF
|
|
, qrpcenvRefchanId :: PubKey 'Sign 'HBS2Basic
|
|
, qrpcenvFabriq :: Fabriq UNIX
|
|
, qrpcenvOwnPeer :: Peer UNIX
|
|
}
|
|
|
|
newtype QRPCAppT m a = QRPCAppT {fromQRPCAppT :: ReaderT QRPCEnv m a}
|
|
deriving newtype
|
|
( Functor
|
|
, Applicative
|
|
, Monad
|
|
, MonadIO
|
|
, MonadUnliftIO
|
|
, MonadReader QRPCEnv
|
|
, MonadTrans
|
|
)
|
|
|
|
instance (Monad m) => HasFabriq UNIX (QRPCAppT m) where
|
|
getFabriq = asks qrpcenvFabriq
|
|
|
|
instance (Monad m) => HasOwnPeer UNIX (QRPCAppT m) where
|
|
ownPeer = asks qrpcenvOwnPeer
|
|
|
|
instance (Monad m) => HasQBLFEnv (ResponseM UNIX (QRPCAppT m)) where
|
|
getQBLFEnv = lift ask
|
|
|
|
runQRPCT
|
|
:: (MonadIO m, PeerMessaging UNIX)
|
|
=> QRPCEnv
|
|
-> QRPCAppT m a
|
|
-> m a
|
|
runQRPCT env m = runReaderT (fromQRPCAppT m) env
|
|
|
|
class HasQBLFEnv m where
|
|
getQBLFEnv :: m QRPCEnv
|
|
|
|
data RPCServerError = RPCServerError Text
|
|
deriving (Generic, Show)
|
|
instance Serialise RPCServerError
|
|
|
|
wrapErrors :: (MonadUnliftIO m) => m a -> m (Either RPCServerError a)
|
|
wrapErrors =
|
|
UnliftIO.tryAny >=> flip either (pure . Right) \e -> do
|
|
debug $ "RPC ServerError" <+> viaShow e
|
|
pure $ (Left . RPCServerError . T.pack . show) e
|
|
|
|
instance (MonadIO m, HasQBLFEnv m) => HandleMethod m PingRPC where
|
|
handleMethod _ = do
|
|
debug $ "RPC PING"
|
|
pure "pong"
|
|
|
|
instance
|
|
( MonadUnliftIO m
|
|
, HasQBLFEnv m
|
|
)
|
|
=> HandleMethod m PostTxRPC
|
|
where
|
|
handleMethod tok = wrapErrors $ UnliftIO.try do
|
|
let txhash = (hashObject @HbSync . serialise) tok
|
|
ptok = pretty tok
|
|
|
|
debug $ "RPC got post tx" <+> pretty txhash <+> ptok
|
|
|
|
refchanId <- qrpcenvRefchanId <$> getQBLFEnv
|
|
validateQBLFToken refchanId tok
|
|
& either throwIO pure
|
|
|
|
qblf <- qrpcenvQConsensus <$> getQBLFEnv
|
|
qblfEnqueue qblf tok
|
|
|
|
debug $ "TX ENQUEUED OK" <+> ptok
|
|
pure $ "Enqueued: " <> (cs . show) ptok
|
|
|
|
validateQBLFToken
|
|
:: (MonadError MyError m)
|
|
=> PubKey 'Sign 'HBS2Basic
|
|
-> QBLFDemoToken 'HBS2Basic
|
|
-> m ()
|
|
validateQBLFToken chan = \case
|
|
Emit box -> do
|
|
(signer, _tx) <- orE SignatureError $ unboxSignedBox0 box
|
|
unless (signer == chan) do
|
|
throwError
|
|
( SignerDoesNotMatchRefchan
|
|
((cs . show . pretty . AsBase58) signer)
|
|
((cs . show . pretty . AsBase58) chan)
|
|
)
|
|
Move box -> do
|
|
(_sign, _tx) <- orE SignatureError $ unboxSignedBox0 box
|
|
pure ()
|