{-# LANGUAGE UndecidableInstances #-}
module Tendermint.Utils.TxClient.Class
( ClientConfig(..)
, RunTxClient(..)
, HasTxClient(..)
, EmptyTxClient(..)
, defaultClientTxOpts
) where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ReaderT, ask)
import qualified Data.ByteArray.Base64String as Base64
import Data.Proxy
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Word (Word64)
import GHC.TypeLits (KnownSymbol,
symbolVal)
import qualified Network.Tendermint.Client as RPC
import Servant.API ((:<|>) (..), (:>))
import qualified Tendermint.SDK.BaseApp.Transaction as T
import qualified Tendermint.SDK.BaseApp.Transaction.Modifier as T
import Tendermint.SDK.Codec (HasCodec (..))
import Tendermint.SDK.Types.Address (Address)
import Tendermint.SDK.Types.Message (HasMessageType (..),
TypedMessage (..))
import Tendermint.SDK.Types.Transaction (RawTransaction (..))
import Tendermint.Utils.TxClient.Types
class Monad m => RunTxClient m where
runTx :: RawTransaction -> m RPC.ResultBroadcastTxCommit
getNonce :: Address -> m Word64
data ClientConfig = ClientConfig
{ clientRPC :: RPC.Config
, clientGetNonce :: Address -> IO Word64
}
instance RunTxClient (ReaderT ClientConfig IO) where
getNonce addr = do
nonceGetter <- clientGetNonce <$> ask
liftIO $ nonceGetter addr
runTx tx = do
let txReq = RPC.broadcastTxCommit . RPC.RequestBroadcastTxCommit . Base64.fromBytes . encode $ tx
rpc <- clientRPC <$> ask
liftIO . RPC.runTendermintM rpc $ txReq
data ClientTxOpts = ClientTxOpts
{ clientTxOptsRoute :: Text
, clientTxOptsNonce :: Word64
}
defaultClientTxOpts :: ClientTxOpts
defaultClientTxOpts = ClientTxOpts "" 0
class HasTxClient m layout where
type ClientT (m :: * -> *) layout :: *
genClientT :: Proxy m -> Proxy layout -> ClientTxOpts -> ClientT m layout
instance (HasTxClient m a, HasTxClient m b) => HasTxClient m (a :<|> b) where
type ClientT m (a :<|> b) = ClientT m a :<|> ClientT m b
genClientT pm _ opts = genClientT pm (Proxy @a) opts :<|> genClientT pm (Proxy @b) opts
instance (KnownSymbol path, HasTxClient m a) => HasTxClient m (path :> a) where
type ClientT m (path :> a) = ClientT m a
genClientT pm _ clientOpts =
let clientOpts' = clientOpts { clientTxOptsRoute = cs $ symbolVal (Proxy @path) }
in genClientT pm (Proxy @a) clientOpts'
makeRawTxForSigning
:: forall msg.
HasMessageType msg
=> HasCodec msg
=> ClientTxOpts
-> TxOpts
-> msg
-> RawTransaction
makeRawTxForSigning ClientTxOpts{..} TxOpts{..} msg =
RawTransaction
{ rawTransactionData = TypedMessage (encode msg) (messageType $ Proxy @msg)
, rawTransactionGas = txOptsGas
, rawTransactionNonce = clientTxOptsNonce
, rawTransactionRoute = clientTxOptsRoute
, rawTransactionSignature = ""
}
instance ( HasMessageType msg, HasCodec msg
, HasCodec a, HasCodec (T.OnCheckReturn 'T.CheckTx oc a)
, RunTxClient m
) => HasTxClient m (T.TypedMessage msg T.:~> T.Return' oc a) where
type ClientT m (T.TypedMessage msg T.:~> T.Return' oc a) = TxOpts -> msg -> m (TxClientResponse (T.OnCheckReturn 'T.CheckTx oc a) a)
genClientT _ _ clientOpts opts msg = do
let Signer signerAddress signer = txOptsSigner opts
nonce <- getNonce signerAddress
let clientOpts' = clientOpts {clientTxOptsNonce = nonce}
rawTxForSigning = makeRawTxForSigning clientOpts' opts msg
rawTxWithSig = signer rawTxForSigning
txRes <- runTx rawTxWithSig
pure $ parseRPCResponse (Proxy @a) (Proxy @oc) txRes
data EmptyTxClient = EmptyTxClient deriving (Eq, Show, Bounded, Enum)
instance HasTxClient m T.EmptyTxServer where
type ClientT m T.EmptyTxServer = EmptyTxClient
genClientT _ _ _ = EmptyTxClient