diff --git a/hs-abci-examples/nameservice/package.yaml b/hs-abci-examples/nameservice/package.yaml index f6494519..d1481d96 100644 --- a/hs-abci-examples/nameservice/package.yaml +++ b/hs-abci-examples/nameservice/package.yaml @@ -52,7 +52,6 @@ library: - aeson-casing - base >= 4.7 && < 5 - bloodhound - - bytestring - errors - hs-abci-extra - hs-abci-server @@ -66,6 +65,7 @@ library: - polysemy-plugin - proto3-suite - proto3-wire + - servant - string-conversions - text - validation @@ -83,14 +83,13 @@ library: - Nameservice.Config - Nameservice.Aeson - Nameservice.Server - - Nameservice.Modules.TypedMessage - - Nameservice.Modules.Nameservice - Nameservice.Modules.Token - Nameservice.Modules.Token.Messages - Nameservice.Modules.Token.Types - Nameservice.Modules.Token.Keeper - Nameservice.Modules.Token.Query - Nameservice.Modules.Token.Router + - Nameservice.Modules.Nameservice - Nameservice.Modules.Nameservice.Messages - Nameservice.Modules.Nameservice.Types - Nameservice.Modules.Nameservice.Keeper @@ -170,10 +169,9 @@ tests: - base >= 4.7 && < 5 - data-default-class - hs-abci-sdk - - hs-abci-types - hs-abci-test-utils - hs-tendermint-client - hspec - - lens + - mtl - nameservice - servant diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice.hs index c9cccbae..440f860a 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice.hs @@ -9,7 +9,6 @@ module Nameservice.Modules.Nameservice , Name(..) , Whois (..) , NameserviceError(..) - , NameserviceMessage(..) , NameClaimed(..) , NameRemapped(..) , NameDeleted(..) @@ -28,14 +27,16 @@ module Nameservice.Modules.Nameservice , eval -- * message router - , router + , MessageApi + , messageHandlers -- * query API - , Api + , QueryApi , server ) where +import Data.Proxy import Nameservice.Modules.Nameservice.Keeper import Nameservice.Modules.Nameservice.Messages import Nameservice.Modules.Nameservice.Query @@ -43,12 +44,12 @@ import Nameservice.Modules.Nameservice.Router import Nameservice.Modules.Nameservice.Types import Nameservice.Modules.Token (TokenEffs) import Polysemy (Members) -import Tendermint.SDK.Application (Module (..), - defaultTxChecker) -import Tendermint.SDK.BaseApp (BaseAppEffs) +import Tendermint.SDK.Application (Module (..)) +import Tendermint.SDK.BaseApp (BaseAppEffs, + DefaultCheckTx (..)) type NameserviceM r = - Module "nameservice" NameserviceMessage () Api NameserviceEffs r + Module "nameservice" MessageApi QueryApi NameserviceEffs r nameserviceModule :: Members BaseAppEffs r @@ -56,8 +57,8 @@ nameserviceModule => Members NameserviceEffs r => NameserviceM r nameserviceModule = Module - { moduleTxDeliverer = router - , moduleTxChecker = defaultTxChecker + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r) , moduleQueryServer = server , moduleEval = eval } diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Messages.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Messages.hs index d25aa00e..a08d88ff 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Messages.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Messages.hs @@ -1,4 +1,8 @@ -module Nameservice.Modules.Nameservice.Messages where +module Nameservice.Modules.Nameservice.Messages + ( SetName(..) + , BuyName(..) + , DeleteName(..) + ) where import Data.Bifunctor (first) import Data.Foldable (sequenceA_) @@ -7,25 +11,19 @@ import Data.Text (Text) import GHC.Generics (Generic) import Nameservice.Modules.Nameservice.Types (Name (..)) import Nameservice.Modules.Token (Amount (..)) -import Nameservice.Modules.TypedMessage (TypedMessage (..)) import Proto3.Suite (Message, Named, fromByteString, toLazyByteString) import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Types.Address (Address (..)) -import Tendermint.SDK.Types.Message (Msg (..), +import Tendermint.SDK.Types.Message (HasMessageType (..), + Msg (..), ValidateMessage (..), coerceProto3Error, formatMessageParseError, isAuthorCheck, nonEmptyCheck) -data NameserviceMessage = - NSetName SetName - | NBuyName BuyName - | NDeleteName DeleteName - deriving (Eq, Show, Generic) - -- @NOTE: .proto genration will use these type names as is -- only field names stripped of prefixes during generation data SetName = SetName @@ -37,10 +35,26 @@ data SetName = SetName instance Message SetName instance Named SetName +instance HasMessageType SetName where + messageType _ = "SetName" + instance HasCodec SetName where encode = cs . toLazyByteString decode = first (formatMessageParseError . coerceProto3Error) . fromByteString +-- TL;DR. ValidateBasic: https://cosmos.network/docs/tutorial/set-name.html#msg +instance ValidateMessage SetName where + validateMessage msg@Msg{..} = + let SetName{setNameName, setNameValue} = msgData + Name name = setNameName + in sequenceA_ + [ nonEmptyCheck "Name" name + , nonEmptyCheck "Value" setNameValue + , isAuthorCheck "Owner" msg setNameOwner + ] + +-------------------------------------------------------------------------------- + data DeleteName = DeleteName { deleteNameOwner :: Address , deleteNameName :: Name @@ -49,10 +63,24 @@ data DeleteName = DeleteName instance Message DeleteName instance Named DeleteName +instance HasMessageType DeleteName where + messageType _ = "DeleteName" + instance HasCodec DeleteName where encode = cs . toLazyByteString decode = first (formatMessageParseError . coerceProto3Error) . fromByteString +instance ValidateMessage DeleteName where + validateMessage msg@Msg{..} = + let DeleteName{deleteNameName} = msgData + Name name = deleteNameName + in sequenceA_ + [ nonEmptyCheck "Name" name + , isAuthorCheck "Owner" msg deleteNameOwner + ] + +-------------------------------------------------------------------------------- + data BuyName = BuyName { buyNameBid :: Amount , buyNameName :: Name @@ -63,49 +91,13 @@ data BuyName = BuyName instance Message BuyName instance Named BuyName +instance HasMessageType BuyName where + messageType _ = "BuyName" + instance HasCodec BuyName where encode = cs . toLazyByteString decode = first (formatMessageParseError . coerceProto3Error) . fromByteString -instance HasCodec NameserviceMessage where - decode bs = do - TypedMessage{..} <- decode bs - case typedMessageType of - "SetName" -> NSetName <$> decode typedMessageContents - "DeleteName" -> NDeleteName <$> decode typedMessageContents - "BuyName" -> NBuyName <$> decode typedMessageContents - _ -> Left . cs $ "Unknown Nameservice message type " ++ cs typedMessageType - encode = \case - NSetName msg -> encode msg - NBuyName msg -> encode msg - NDeleteName msg -> encode msg - -instance ValidateMessage NameserviceMessage where - validateMessage m@Msg{msgData} = case msgData of - NBuyName msg -> validateMessage m {msgData = msg} - NSetName msg -> validateMessage m {msgData = msg} - NDeleteName msg -> validateMessage m {msgData = msg} - --- TL;DR. ValidateBasic: https://cosmos.network/docs/tutorial/set-name.html#msg -instance ValidateMessage SetName where - validateMessage msg@Msg{..} = - let SetName{setNameName, setNameValue} = msgData - Name name = setNameName - in sequenceA_ - [ nonEmptyCheck "Name" name - , nonEmptyCheck "Value" setNameValue - , isAuthorCheck "Owner" msg setNameOwner - ] - -instance ValidateMessage DeleteName where - validateMessage msg@Msg{..} = - let DeleteName{deleteNameName} = msgData - Name name = deleteNameName - in sequenceA_ - [ nonEmptyCheck "Name" name - , isAuthorCheck "Owner" msg deleteNameOwner - ] - instance ValidateMessage BuyName where validateMessage msg@Msg{..} = let BuyName{buyNameName, buyNameValue} = msgData diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Query.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Query.hs index 1786db0e..bc5864dc 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Query.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Query.hs @@ -13,10 +13,10 @@ import qualified Tendermint.SDK.BaseApp as BaseApp type NameserviceContents = '[(Name, Whois)] -type Api = BaseApp.QueryApi NameserviceContents +type QueryApi = BaseApp.QueryApi NameserviceContents server :: Members [BaseApp.RawStore, Error BaseApp.AppError] r - => BaseApp.RouteT Api r + => BaseApp.RouteQ QueryApi r server = BaseApp.storeQueryHandlers (Proxy :: Proxy NameserviceContents) storeKey (Proxy :: Proxy r) diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Router.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Router.hs index 4a274226..8f292bbb 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Router.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Nameservice/Router.hs @@ -3,31 +3,63 @@ module Nameservice.Modules.Nameservice.Router where import Nameservice.Modules.Nameservice.Keeper (NameserviceEffs, buyName, deleteName, setName) -import Nameservice.Modules.Nameservice.Messages (NameserviceMessage (..)) +import Nameservice.Modules.Nameservice.Messages (BuyName, DeleteName, + SetName) import Nameservice.Modules.Token (TokenEffs) import Polysemy (Members, Sem) -import Tendermint.SDK.BaseApp (BaseAppEffs, TxEffs, +import Servant.API ((:<|>) (..)) +import Tendermint.SDK.BaseApp ((:~>), BaseAppEffs, + Return, + RouteContext (..), + RouteTx, + RoutingTx (..), + TxEffs, TypedMessage, incCount, withTimer) import Tendermint.SDK.Types.Message (Msg (..)) -import Tendermint.SDK.Types.Transaction (PreRoutedTx (..), - Tx (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) -router - :: Members TokenEffs r + + +type MessageApi = + TypedMessage BuyName :~> Return () + :<|> TypedMessage SetName :~> Return () + :<|> TypedMessage DeleteName :~> Return () + +messageHandlers + :: Members BaseAppEffs r + => Members TokenEffs r => Members NameserviceEffs r - => Members BaseAppEffs r + => RouteTx MessageApi r 'DeliverTx +messageHandlers = buyNameH :<|> setNameH :<|> deleteNameH + +buyNameH + :: Members BaseAppEffs r => Members TxEffs r - => PreRoutedTx NameserviceMessage + => Members TokenEffs r + => Members NameserviceEffs r + => RoutingTx BuyName + -> Sem r () +buyNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "buy_total" + withTimer "buy_duration_seconds" $ buyName msgData + +setNameH + :: Members BaseAppEffs r + => Members TxEffs r + => Members NameserviceEffs r + => RoutingTx SetName + -> Sem r () +setNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "set_total" + withTimer "set_duration_seconds" $ setName msgData + +deleteNameH + :: Members BaseAppEffs r + => Members TxEffs r + => Members TokenEffs r + => Members NameserviceEffs r + => RoutingTx DeleteName -> Sem r () -router (PreRoutedTx Tx{txMsg}) = - let Msg{msgData} = txMsg - in case msgData of - NSetName msg -> do - incCount "set_total" - withTimer "set_duration_seconds" $ setName msg - NBuyName msg -> do - incCount "buy_total" - withTimer "buy_duration_seconds" $ buyName msg - NDeleteName msg -> do - incCount "delete_total" - withTimer "delete_duration_seconds" $ deleteName msg +deleteNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "delete_total" + withTimer "delete_duration_seconds" $ deleteName msgData diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token.hs index c42d4b64..7e9fafbd 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token.hs @@ -8,14 +8,16 @@ module Nameservice.Modules.Token , Address , Amount(..) , TokenError(..) + , Transfer(..) + , Burn(..) + , FaucetAccount(..) -- * effects , Token , TokenEffs , Faucetted(..) , TransferEvent(..) - , FaucetAccount(..) , getBalance , faucetAccount , transfer @@ -25,35 +27,37 @@ module Nameservice.Modules.Token -- * interpreter , eval - -- * router - , router + -- * Transaction + , MessageApi + , messageHandlers -- * Query Api - , Api + , QueryApi , server ) where +import Data.Proxy import Nameservice.Modules.Token.Keeper import Nameservice.Modules.Token.Messages import Nameservice.Modules.Token.Query import Nameservice.Modules.Token.Router import Nameservice.Modules.Token.Types import Polysemy (Members) -import Tendermint.SDK.Application (Module (..), - defaultTxChecker) -import Tendermint.SDK.BaseApp (BaseAppEffs) +import Tendermint.SDK.Application (Module (..)) +import Tendermint.SDK.BaseApp (BaseAppEffs, + DefaultCheckTx (..)) import Tendermint.SDK.Types.Address (Address) -type TokenM r = Module "token" TokenMessage () Api TokenEffs r +type TokenM r = Module "token" MessageApi QueryApi TokenEffs r tokenModule :: Members BaseAppEffs r => Members TokenEffs r => TokenM r tokenModule = Module - { moduleTxDeliverer = router - , moduleTxChecker = defaultTxChecker + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r) , moduleQueryServer = server , moduleEval = eval } diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Messages.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Messages.hs index 9ce3c885..592cd38c 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Messages.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Messages.hs @@ -1,26 +1,23 @@ -module Nameservice.Modules.Token.Messages where - -import Data.Bifunctor (first) -import Data.String.Conversions (cs) -import Data.Validation (Validation (..)) -import GHC.Generics (Generic) -import Nameservice.Modules.Token.Types (Amount) -import Nameservice.Modules.TypedMessage (TypedMessage (..)) -import Proto3.Suite (Message, Named, - fromByteString, - toLazyByteString) -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Types.Address (Address) -import Tendermint.SDK.Types.Message (Msg (..), - ValidateMessage (..), - coerceProto3Error, - formatMessageParseError) - -data TokenMessage = - TTransfer Transfer - | TFaucetAccount FaucetAccount - | TBurn Burn - deriving (Eq, Show, Generic) +module Nameservice.Modules.Token.Messages + ( Transfer(..) + , Burn(..) + , FaucetAccount(..) + ) where + +import Data.Bifunctor (first) +import Data.String.Conversions (cs) +import Data.Validation (Validation (..)) +import GHC.Generics (Generic) +import Nameservice.Modules.Token.Types (Amount) +import Proto3.Suite (Message, Named, + fromByteString, + toLazyByteString) +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Address (Address) +import Tendermint.SDK.Types.Message (HasMessageType (..), + ValidateMessage (..), + coerceProto3Error, + formatMessageParseError) data FaucetAccount = FaucetAccount { faucetAccountTo :: Address @@ -30,10 +27,18 @@ data FaucetAccount = FaucetAccount instance Message FaucetAccount instance Named FaucetAccount +instance HasMessageType FaucetAccount where + messageType _ = "FaucetAccount" + instance HasCodec FaucetAccount where encode = cs . toLazyByteString decode = first (formatMessageParseError . coerceProto3Error) . fromByteString +instance ValidateMessage FaucetAccount where + validateMessage _ = Success () + +-------------------------------------------------------------------------------- + data Transfer = Transfer { transferTo :: Address , transferFrom :: Address @@ -43,10 +48,18 @@ data Transfer = Transfer instance Message Transfer instance Named Transfer +instance HasMessageType Transfer where + messageType _ = "Transfer" + instance HasCodec Transfer where encode = cs . toLazyByteString decode = first (formatMessageParseError . coerceProto3Error) . fromByteString +instance ValidateMessage Transfer where + validateMessage _ = Success () + +-------------------------------------------------------------------------------- + data Burn = Burn { burnAddress :: Address , burnAmount :: Amount @@ -55,34 +68,12 @@ data Burn = Burn instance Message Burn instance Named Burn +instance HasMessageType Burn where + messageType _ = "Burn" + instance HasCodec Burn where encode = cs . toLazyByteString decode = first (formatMessageParseError . coerceProto3Error) . fromByteString -instance HasCodec TokenMessage where - decode bs = do - TypedMessage{..} <- decode bs - case typedMessageType of - "Transfer" -> TTransfer <$> decode typedMessageContents - "Burn" -> TBurn <$> decode typedMessageContents - "FaucetAccount" -> TFaucetAccount <$> decode typedMessageContents - _ -> Left . cs $ "Unknown Token message type " ++ cs typedMessageType - encode = \case - TTransfer msg -> encode msg - TBurn msg -> encode msg - TFaucetAccount msg -> encode msg - -instance ValidateMessage TokenMessage where - validateMessage m@Msg{msgData} = case msgData of - TTransfer msg -> validateMessage m {msgData = msg} - TFaucetAccount msg -> validateMessage m {msgData = msg} - TBurn msg -> validateMessage m {msgData = msg} - -instance ValidateMessage Transfer where - validateMessage _ = Success () - -instance ValidateMessage FaucetAccount where - validateMessage _ = Success () - instance ValidateMessage Burn where validateMessage _ = Success () diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Query.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Query.hs index fd22193c..5685c852 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Query.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Query.hs @@ -14,10 +14,10 @@ import Tendermint.SDK.Types.Address (Address) type TokenContents = '[(Address, Amount)] -type Api = BaseApp.QueryApi TokenContents +type QueryApi = BaseApp.QueryApi TokenContents server :: Members [BaseApp.RawStore, Error BaseApp.AppError] r - => BaseApp.RouteT Api r + => BaseApp.RouteQ QueryApi r server = BaseApp.storeQueryHandlers (Proxy :: Proxy TokenContents) storeKey (Proxy :: Proxy r) diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Router.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Router.hs index b427a342..3c5de02d 100644 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Router.hs +++ b/hs-abci-examples/nameservice/src/Nameservice/Modules/Token/Router.hs @@ -1,27 +1,56 @@ -module Nameservice.Modules.Token.Router where +module Nameservice.Modules.Token.Router + ( MessageApi + , messageHandlers + + ) where import Nameservice.Modules.Token.Keeper (TokenEffs, burn, faucetAccount, transfer) -import Nameservice.Modules.Token.Messages (Burn (..), - TokenMessage (..), +import Nameservice.Modules.Token.Messages (Burn (..), FaucetAccount, Transfer (..)) import Polysemy (Members, Sem) -import Tendermint.SDK.BaseApp (BaseAppEffs, TxEffs) +import Servant.API ((:<|>) (..)) +import Tendermint.SDK.BaseApp ((:~>), BaseAppEffs, Return, + RouteContext (..), RouteTx, + RoutingTx (..), TxEffs, + TypedMessage) import Tendermint.SDK.Types.Message (Msg (..)) -import Tendermint.SDK.Types.Transaction (PreRoutedTx (..), Tx (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) + +type MessageApi = + TypedMessage Burn :~> Return () + :<|> TypedMessage Transfer :~> Return () + :<|> TypedMessage FaucetAccount :~> Return () -router +messageHandlers :: Members TokenEffs r => Members BaseAppEffs r + => RouteTx MessageApi r 'DeliverTx +messageHandlers = burnH :<|> transferH :<|> faucetH + +transferH + :: Members TokenEffs r => Members TxEffs r - => PreRoutedTx TokenMessage + => Members BaseAppEffs r + => RoutingTx Transfer + -> Sem r () +transferH (RoutingTx Tx{txMsg=Msg{msgData}}) = + let Transfer{..} = msgData + in transfer transferFrom transferAmount transferTo + +burnH + :: Members TokenEffs r + => RoutingTx Burn + -> Sem r () +burnH (RoutingTx Tx{txMsg=Msg{msgData}}) = + let Burn{..} = msgData + in burn burnAddress burnAmount + +faucetH + :: Members TokenEffs r + => Members TxEffs r + => Members BaseAppEffs r + => RoutingTx FaucetAccount -> Sem r () -router (PreRoutedTx Tx{txMsg}) = - let Msg{msgData} = txMsg - in case msgData of - TFaucetAccount faucet -> - faucetAccount faucet - TTransfer Transfer{..} -> - transfer transferFrom transferAmount transferTo - TBurn Burn{..} -> - burn burnAddress burnAmount +faucetH (RoutingTx Tx{txMsg=Msg{msgData}}) = + faucetAccount msgData diff --git a/hs-abci-examples/nameservice/src/Nameservice/Modules/TypedMessage.hs b/hs-abci-examples/nameservice/src/Nameservice/Modules/TypedMessage.hs deleted file mode 100644 index e7bdb768..00000000 --- a/hs-abci-examples/nameservice/src/Nameservice/Modules/TypedMessage.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Nameservice.Modules.TypedMessage where - -import Data.Bifunctor (first) -import qualified Data.ByteString as BS -import Data.String.Conversions (cs) -import Data.Text (Text) -import GHC.Generics (Generic) -import Proto3.Suite (Message, Named, fromByteString, - toLazyByteString) -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Types.Message (coerceProto3Error, - formatMessageParseError) - --- Tags messages to disambiguate decoding instances -data TypedMessage = TypedMessage - { typedMessageType :: Text - , typedMessageContents :: BS.ByteString - } deriving (Eq, Show, Generic) - -instance Message TypedMessage -instance Named TypedMessage - -instance HasCodec TypedMessage where - encode = cs . toLazyByteString - decode = first (formatMessageParseError . coerceProto3Error) . fromByteString diff --git a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs index c6a388a6..ebacc1b4 100644 --- a/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs +++ b/hs-abci-examples/nameservice/test/Nameservice/Test/E2ESpec.hs @@ -1,214 +1,432 @@ module Nameservice.Test.E2ESpec (spec) where -import Control.Lens ((^.)) -import Control.Monad (void) -import Data.Default.Class (def) +import Control.Monad (forM_, void) +import Control.Monad.Reader (ReaderT, runReaderT) +import Data.Default.Class (def) import Data.Proxy -import Nameservice.Modules.Nameservice (BuyName (..), - DeleteName (..), - Name (..), - NameClaimed (..), - NameDeleted (..), - NameRemapped (..), - SetName (..), Whois (..)) -import qualified Nameservice.Modules.Nameservice as N (Api) -import Nameservice.Modules.Token (Amount (..), - FaucetAccount (..), - Faucetted (..), - Transfer (..), - TransferEvent (..)) -import qualified Nameservice.Modules.Token as T (Api) -import Nameservice.Modules.TypedMessage (TypedMessage (..)) -import Nameservice.Test.EventOrphans () -import qualified Network.ABCI.Types.Messages.Response as Response -import qualified Network.Tendermint.Client as RPC -import Servant.API ((:<|>) (..), (:>)) -import Tendermint.SDK.BaseApp.Query (QueryArgs (..), - defaultQueryWithData) -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Types.Address (Address (..)) -import Tendermint.Utils.Client (ClientResponse (..), - HasClient (..)) -import Tendermint.Utils.Request (ensureCheckAndDeliverResponseCodes, - getDeliverTxResponse, - getQueryResponseSuccess, - runRPC) -import Tendermint.Utils.Response (ensureDeliverResponseCode, - ensureEventLogged) -import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) +import Nameservice.Application +import qualified Nameservice.Modules.Nameservice as N +import qualified Nameservice.Modules.Token as T +import Nameservice.Test.EventOrphans () +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..)) +import Tendermint.SDK.Application.Module (AppQueryRouter (QApi), + AppTxRouter (TApi)) +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + QueryResult (..), + defaultQueryArgs) +import qualified Tendermint.SDK.Modules.Auth as Auth +import Tendermint.SDK.Types.Address (Address) +import Tendermint.Utils.Client (ClientConfig (..), + EmptyTxClient (..), + HasQueryClient (..), + HasTxClient (..), + QueryClientResponse (..), + Signer (..), + TxClientResponse (..), + TxOpts (..), + defaultClientTxOpts) +import Tendermint.Utils.ClientUtils (assertQuery, assertTx, + deliverTxEvents, + ensureQueryResponseCode, + ensureResponseCodes, + rpcConfig) +import Tendermint.Utils.User (makeSignerFromUser, + makeUser) import Test.Hspec spec :: Spec spec = do - let satoshi = Name "satoshi" - addr1 = userAddress user1 - addr2 = userAddress user2 + let satoshi = N.Name "satoshi" faucetAmount = 1000 - beforeAll (do faucetAccount user1 faucetAmount; faucetAccount user2 faucetAmount) $ + beforeAll (forM_ [user1, user2] $ faucetUser faucetAmount) $ do + describe "Nameservice Spec" $ do it "Can query /health to make sure the node is alive" $ do - resp <- runRPC RPC.health + resp <- RPC.runTendermintM rpcConfig $ RPC.health resp `shouldBe` RPC.ResultHealth it "Can query account balances" $ do - let queryReq = defaultQueryWithData addr1 - void $ getQueryResponseSuccess $ getBalance queryReq + void . assertQuery . RPC.runTendermintM rpcConfig $ + getBalance defaultQueryArgs { queryArgsData = signerAddress user1 } - it "Can create a name (success 0)" $ do + it "Can create a name" $ do let val = "hello world" - msg = TypedMessage "BuyName" (encode $ BuyName 0 satoshi val addr1) - claimedLog = NameClaimed addr1 satoshi val 0 - deliverResp <- mkSignedRawTransactionWithRoute "nameservice" user1 msg >>= getDeliverTxResponse - ensureDeliverResponseCode deliverResp 0 - ensureEventLogged deliverResp "NameClaimed" claimedLog + msg = N.BuyName + { buyNameBid = 0 + , buyNameName = satoshi + , buyNameValue = val + , buyNameBuyer = signerAddress user1 + } + claimedLog = N.NameClaimed + { nameClaimedOwner = signerAddress user1 + , nameClaimedName = satoshi + , nameClaimedValue = val + , nameClaimedBid = 0 + } + opts = TxOpts + { txOptsSigner = user1 + , txOptsGas = 0 + } + resp <- assertTx . runTxClientM $ buyName opts msg + ensureResponseCodes (0,0) resp + (errs, es) <- deliverTxEvents (Proxy @N.NameClaimed) resp + errs `shouldBe` [] + filter (claimedLog ==) es `shouldBe` [claimedLog] it "Can query for a name" $ do - let queryReq = defaultQueryWithData satoshi - foundWhois <- getQueryResponseSuccess $ getWhois queryReq - foundWhois `shouldBe` Whois "hello world" addr1 0 + let expected = N.Whois + { whoisValue = "hello world" + , whoisOwner = signerAddress user1 + , whoisPrice = 0 + } + foundWhois <- fmap queryResultData . assertQuery . RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = satoshi } + foundWhois `shouldBe` expected it "Can query for a name that doesn't exist" $ do - let nope = Name "nope" - queryReq = defaultQueryWithData nope - ClientResponse{ clientResponseData, clientResponseRaw } <- runRPC $ getWhois queryReq - let queryRespCode = clientResponseRaw ^. Response._queryCode - -- storage failure - queryRespCode `shouldBe` 2 - clientResponseData `shouldBe` Nothing - - it "Can set a name value (success 0)" $ do + let nope = N.Name "nope" + resp <- RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = nope } + ensureQueryResponseCode 2 resp + + it "Can set a name value" $ do let oldVal = "hello world" newVal = "goodbye to a world" - msg = TypedMessage "SetName" (encode $ SetName satoshi addr1 newVal) - remappedLog = NameRemapped satoshi oldVal newVal - deliverResp <- mkSignedRawTransactionWithRoute "nameservice" user1 msg >>= getDeliverTxResponse - ensureDeliverResponseCode deliverResp 0 - ensureEventLogged deliverResp "NameRemapped" remappedLog - -- check for changes - let queryReq = defaultQueryWithData satoshi - foundWhois <- getQueryResponseSuccess $ getWhois queryReq - foundWhois `shouldBe` Whois "goodbye to a world" addr1 0 - - it "Can fail to set a name (failure 2)" $ do + msg = N.SetName + { setNameName = satoshi + , setNameOwner = signerAddress user1 + , setNameValue = newVal + } + remappedLog = N.NameRemapped + { nameRemappedName = satoshi + , nameRemappedOldValue = oldVal + , nameRemappedNewValue = newVal + } + opts = TxOpts + { txOptsSigner = user1 + , txOptsGas = 0 + } + resp <- assertTx . runTxClientM $ setName opts msg + ensureResponseCodes (0,0) resp + (errs, es) <- deliverTxEvents (Proxy @N.NameRemapped) resp + errs `shouldBe` [] + filter (remappedLog ==) es `shouldBe` [remappedLog] + + let expected = N.Whois + { whoisValue = "goodbye to a world" + , whoisOwner = signerAddress user1 + , whoisPrice = 0 + } + foundWhois <- fmap queryResultData . assertQuery . RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = satoshi } + foundWhois `shouldBe` expected + + it "Can fail to set a name" $ do -- try to set a name without being the owner - let msg = TypedMessage "SetName" (encode $ SetName satoshi addr2 "goodbye to a world") - ensureCheckAndDeliverResponseCodes (0,2) =<< mkSignedRawTransactionWithRoute "nameservice" user2 msg + let msg = N.SetName + { setNameName = satoshi + , setNameOwner = signerAddress user2 + , setNameValue = "goodbye to a world" + } + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } + resp <- assertTx . runTxClientM $ setName opts msg + ensureResponseCodes (0,2) resp - it "Can buy an existing name (success 0)" $ do - balance1 <- getQueryResponseSuccess $ getBalance $ defaultQueryWithData addr1 - balance2 <- getQueryResponseSuccess $ getBalance $ defaultQueryWithData addr2 - Whois{whoisPrice} <- getQueryResponseSuccess $ getWhois $ defaultQueryWithData satoshi + it "Can buy an existing name" $ do + balance1 <- getUserBalance user1 + balance2 <- getUserBalance user2 + N.Whois{whoisPrice} <- fmap queryResultData . assertQuery . RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = satoshi } let purchaseAmount = whoisPrice + 1 newVal = "hello (again) world" - msg = TypedMessage "BuyName" (encode $ BuyName purchaseAmount satoshi newVal addr2) - claimedLog = NameClaimed addr2 satoshi newVal purchaseAmount - deliverResp <- mkSignedRawTransactionWithRoute "nameservice" user2 msg >>= getDeliverTxResponse - ensureDeliverResponseCode deliverResp 0 - ensureEventLogged deliverResp "NameClaimed" claimedLog + msg = N.BuyName + { buyNameBid = purchaseAmount + , buyNameName = satoshi + , buyNameValue = newVal + , buyNameBuyer = signerAddress user2 + } + claimedLog = N.NameClaimed + { nameClaimedOwner = signerAddress user2 + , nameClaimedName = satoshi + , nameClaimedValue = newVal + , nameClaimedBid = purchaseAmount + } + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } + + resp <- assertTx . runTxClientM $ buyName opts msg + ensureResponseCodes (0,0) resp + (errs, es) <- deliverTxEvents (Proxy @N.NameClaimed) resp + errs `shouldBe` [] + filter (claimedLog ==) es `shouldBe` [claimedLog] + -- check for updated balances - seller: addr1, buyer: addr2 - let sellerQueryReq = defaultQueryWithData addr1 - sellerFoundAmount <- getQueryResponseSuccess $ getBalance sellerQueryReq + sellerFoundAmount <- getUserBalance user1 sellerFoundAmount `shouldBe` (balance1 + purchaseAmount) - let buyerQueryReq = defaultQueryWithData addr2 - buyerFoundAmount <- getQueryResponseSuccess $ getBalance buyerQueryReq + buyerFoundAmount <- getUserBalance user2 buyerFoundAmount `shouldBe` (balance2 - purchaseAmount) - -- check for ownership changes - let queryReq = defaultQueryWithData satoshi - foundWhois <- getQueryResponseSuccess $ getWhois queryReq - foundWhois `shouldBe` Whois "hello (again) world" addr2 purchaseAmount + + let expected = N.Whois + { whoisValue = "hello (again) world" + , whoisOwner = signerAddress user2 + , whoisPrice = purchaseAmount + } + foundWhois <- fmap queryResultData . assertQuery . RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = satoshi } + foundWhois `shouldBe` expected -- @NOTE: this is possibly a problem with the go application too -- https://cosmos.network/docs/tutorial/buy-name.html#msg - it "Can buy self-owned names and make a profit (success 0)" $ do + it "Can buy self-owned names and make a profit " $ do -- check balance before - let queryReq = defaultQueryWithData addr2 - beforeBuyAmount <- getQueryResponseSuccess $ getBalance queryReq + beforeBuyAmount <- getUserBalance user2 -- buy let val = "hello (again) world" - msg = TypedMessage "BuyName" (encode $ BuyName 500 satoshi val addr2) - claimedLog = NameClaimed addr2 satoshi val 500 - deliverResp <- mkSignedRawTransactionWithRoute "nameservice" user2 msg >>= getDeliverTxResponse - ensureDeliverResponseCode deliverResp 0 - ensureEventLogged deliverResp "NameClaimed" claimedLog + msg = N.BuyName + { buyNameBid = 500 + , buyNameName = satoshi + , buyNameValue = val + , buyNameBuyer = signerAddress user2 + } + claimedLog = N.NameClaimed + { nameClaimedOwner = signerAddress user2 + , nameClaimedName = satoshi + , nameClaimedValue = val + , nameClaimedBid = 500 + } + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } + + resp <- assertTx . runTxClientM $ buyName opts msg + ensureResponseCodes (0,0) resp + (errs, es) <- deliverTxEvents (Proxy @N.NameClaimed) resp + errs `shouldBe` [] + filter (claimedLog ==) es `shouldBe` [claimedLog] + -- check balance after - afterBuyAmount <- getQueryResponseSuccess $ getBalance queryReq + afterBuyAmount <- getUserBalance user2 -- owner/buyer still profits afterBuyAmount `shouldSatisfy` (> beforeBuyAmount) - it "Can fail to buy a name (failure 1)" $ do + it "Can fail to buy a name" $ do -- try to buy at a lower price - let msg = TypedMessage "BuyName" (encode $ BuyName 100 satoshi "hello (again) world" addr1) - mkSignedRawTransactionWithRoute "nameservice" user1 msg >>= ensureCheckAndDeliverResponseCodes (0,1) - - it "Can delete names (success 0)" $ do - let msg = TypedMessage "DeleteName" (encode $ DeleteName addr2 satoshi) - deletedLog = NameDeleted satoshi - deliverResp <- mkSignedRawTransactionWithRoute "nameservice" user2 msg >>= getDeliverTxResponse - ensureDeliverResponseCode deliverResp 0 - ensureEventLogged deliverResp "NameDeleted" deletedLog - -- name shouldn't exist - let queryReq = defaultQueryWithData satoshi - ClientResponse{ clientResponseData, clientResponseRaw } <- runRPC $ getWhois queryReq - let queryRespCode = clientResponseRaw ^. Response._queryCode - -- storage failure - queryRespCode `shouldBe` 2 - clientResponseData `shouldBe` Nothing - - it "Can fail a transfer (failure 1)" $ do - let senderBeforeQueryReq = defaultQueryWithData addr2 - addr2Balance <- getQueryResponseSuccess $ getBalance senderBeforeQueryReq + let msg = N.BuyName + { buyNameBid = 100 + , buyNameName = satoshi + , buyNameValue = "hello (again) world" + , buyNameBuyer = signerAddress user1 + } + opts = TxOpts + { txOptsSigner = user1 + , txOptsGas = 0 + } + + resp <- assertTx . runTxClientM $ buyName opts msg + ensureResponseCodes (0,1) resp + + it "Can delete names" $ do + let msg = N.DeleteName + { deleteNameOwner = signerAddress user2 + , deleteNameName = satoshi + } + deletedLog = N.NameDeleted + { nameDeletedName = satoshi + } + + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } + + resp <- assertTx . runTxClientM $ deleteName opts msg + ensureResponseCodes (0,0) resp + (errs, es) <- deliverTxEvents (Proxy @N.NameDeleted) resp + errs `shouldBe` [] + filter (deletedLog ==) es `shouldBe` [deletedLog] + + respQ <- RPC.runTendermintM rpcConfig $ + getWhois defaultQueryArgs { queryArgsData = satoshi } + ensureQueryResponseCode 2 respQ + + + it "Can fail a transfer" $ do + addr2Balance <- getUserBalance user2 let tooMuchToTransfer = addr2Balance + 1 - msg = TypedMessage "Transfer" (encode $ Transfer addr2 addr1 tooMuchToTransfer) - ensureCheckAndDeliverResponseCodes (0,1) =<< mkSignedRawTransactionWithRoute "token" user2 msg + msg = T.Transfer + { transferFrom = signerAddress user2 + , transferTo = signerAddress user1 + , transferAmount = tooMuchToTransfer + } + opts = TxOpts + { txOptsSigner = user2 + , txOptsGas = 0 + } - it "Can transfer (success 0)" $ do - balance1 <- getQueryResponseSuccess $ getBalance $ defaultQueryWithData addr1 - balance2 <- getQueryResponseSuccess $ getBalance $ defaultQueryWithData addr2 + resp <- assertTx . runTxClientM $ transfer opts msg + ensureResponseCodes (0,1) resp + + it "Can transfer" $ do + balance1 <- getUserBalance user1 + balance2 <- getUserBalance user2 let transferAmount = 1 - msg = TypedMessage "Transfer" $ encode - Transfer - { transferFrom = addr1 - , transferTo = addr2 + msg = + T.Transfer + { transferFrom = signerAddress user1 + , transferTo = signerAddress user2 , transferAmount = transferAmount } - transferEvent = TransferEvent + transferLog = T.TransferEvent { transferEventAmount = transferAmount - , transferEventTo = addr2 - , transferEventFrom = addr1 + , transferEventTo = signerAddress user2 + , transferEventFrom = signerAddress user1 + } + opts = TxOpts + { txOptsSigner = user1 + , txOptsGas = 0 } - deliverResp <- mkSignedRawTransactionWithRoute "token" user1 msg >>= getDeliverTxResponse - ensureDeliverResponseCode deliverResp 0 - ensureEventLogged deliverResp "TransferEvent" transferEvent + + resp <- assertTx . runTxClientM $ transfer opts msg + ensureResponseCodes (0,0) resp + (errs, es) <- deliverTxEvents (Proxy @T.TransferEvent) resp + errs `shouldBe` [] + filter (transferLog ==) es `shouldBe` [transferLog] + -- check balances - balance1' <- getQueryResponseSuccess $ getBalance $ defaultQueryWithData addr1 + balance1' <- getUserBalance user1 balance1' `shouldBe` balance1 - transferAmount - balance2' <- getQueryResponseSuccess $ getBalance $ defaultQueryWithData addr2 + balance2' <- getUserBalance user2 balance2' `shouldBe` balance2 + transferAmount +faucetUser + :: T.Amount + -> Signer + -> IO () +faucetUser amount s@(Signer addr _) = + void . assertTx .runTxClientM $ + let msg = T.FaucetAccount addr amount + opts = TxOpts + { txOptsGas = 0 + , txOptsSigner = s + } + in faucet opts msg + +getUserBalance + :: Signer + -> IO T.Amount +getUserBalance usr = fmap queryResultData . assertQuery . RPC.runTendermintM rpcConfig $ + getBalance defaultQueryArgs { queryArgsData = signerAddress usr } + -------------------------------------------------------------------------------- -user1 :: User -user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" +user1 :: Signer +user1 = makeSignerFromUser $ + makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" -user2 :: User -user2 = makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" +user2 :: Signer +user2 = makeSignerFromUser $ + makeUser "f65242094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" -------------------------------------------------------------------------------- +-- Query Client +-------------------------------------------------------------------------------- + +getAccount + :: QueryArgs Address + -> RPC.TendermintM (QueryClientResponse Auth.Account) + +getWhois + :: QueryArgs N.Name + -> RPC.TendermintM (QueryClientResponse N.Whois) + +getBalance + :: QueryArgs Address + -> RPC.TendermintM (QueryClientResponse T.Amount) + +getWhois :<|> getBalance :<|> getAccount = + genClientQ (Proxy :: Proxy m) queryApiP def + where + queryApiP :: Proxy (QApi NameserviceModules) + queryApiP = Proxy + + +-------------------------------------------------------------------------------- +-- Tx Client +-------------------------------------------------------------------------------- + +txClientConfig :: ClientConfig +txClientConfig = + let getNonce addr = do + resp <- RPC.runTendermintM rpcConfig $ getAccount $ + QueryArgs + { queryArgsHeight = -1 + , queryArgsProve = False + , queryArgsData = addr + } + case resp of + QueryError e -> + if appErrorCode e == 2 + then pure 0 + else error $ "Unknown nonce error: " <> show (appErrorMessage e) + QueryResponse QueryResult {queryResultData} -> + pure $ Auth.accountNonce queryResultData + + in ClientConfig + { clientGetNonce = getNonce + , clientRPC = rpcConfig + } + +type TxClientM = ReaderT ClientConfig IO + +runTxClientM :: TxClientM a -> IO a +runTxClientM m = runReaderT m txClientConfig + + +-- Nameservice Client +buyName + :: TxOpts + -> N.BuyName + -> TxClientM (TxClientResponse () ()) + +setName + :: TxOpts + -> N.SetName + -> TxClientM (TxClientResponse () ()) + +deleteName + :: TxOpts + -> N.DeleteName + -> TxClientM (TxClientResponse () ()) -faucetAccount :: User -> Amount -> IO () -faucetAccount user@User{userAddress} amount = do - let msg = TypedMessage "FaucetAccount" (encode $ FaucetAccount userAddress amount) - faucetEvent = Faucetted userAddress amount - deliverResp <- mkSignedRawTransactionWithRoute "token" user msg >>= getDeliverTxResponse - ensureDeliverResponseCode deliverResp 0 - ensureEventLogged deliverResp "Faucetted" faucetEvent +-- Token Client +--burn +-- :: TxOpts +-- -> T.Burn +-- -> TxClientM (TxClientResponse () ()) -getWhois :: QueryArgs Name -> RPC.TendermintM (ClientResponse Whois) -getBalance :: QueryArgs Address -> RPC.TendermintM (ClientResponse Amount) +transfer + :: TxOpts + -> T.Transfer + -> TxClientM (TxClientResponse () ()) -apiP :: Proxy ("token" :> T.Api :<|> ("nameservice" :> N.Api)) -apiP = Proxy +faucet + :: TxOpts + -> T.FaucetAccount + -> TxClientM (TxClientResponse () ()) -(getBalance :<|> getWhois) = - genClient (Proxy :: Proxy RPC.TendermintM) apiP def +(buyName :<|> setName :<|> deleteName) :<|> + (_ :<|> transfer :<|> faucet) :<|> + EmptyTxClient = + genClientT (Proxy @TxClientM) txApiP defaultClientTxOpts + where + txApiP :: Proxy (TApi NameserviceModules) + txApiP = Proxy diff --git a/hs-abci-examples/nameservice/tutorial/Foundations/Modules.md b/hs-abci-examples/nameservice/tutorial/Foundations/Modules.md index 2473573b..c2b33654 100644 --- a/hs-abci-examples/nameservice/tutorial/Foundations/Modules.md +++ b/hs-abci-examples/nameservice/tutorial/Foundations/Modules.md @@ -5,10 +5,10 @@ A `Module` has a very specific meaning in the context of this SDK. A `Module` is something between a library and a small state machine. It is built on top of the `BaseApp` abstraction in the sense that all `Module`s must be explicitly interpeted in terms of `BaseApp` in order to compile the application. The full type definition is ~~~ haskell ignore -data Module (name :: Symbol) msg (api :: *) (val :: *) (s :: EffectRow) (r :: EffectRow) = Module - { moduleTxDeliverer :: RoutedTx msg -> Sem r val - , moduleTxChecker :: RoutedTx msg -> Sem r val - , moduleQueryServer :: RouteT api (Sem r) +data Module (name :: Symbol) (h :: *) (q :: *) (s :: EffectRow) (r :: EffectRow) = Module + { moduleTxDeliverer :: T.RouteTx h r 'DeliverTx + , moduleTxChecker :: T.RouteTx h r 'CheckTx + , moduleQueryServer :: Q.RouteQ q r , moduleEval :: forall deps. Members BaseAppEffs deps => forall a. Sem (s :& deps) a -> Sem deps a } ~~~ @@ -16,9 +16,8 @@ data Module (name :: Symbol) msg (api :: *) (val :: *) (s :: EffectRow) (r :: Ef where the type parameters - `name` is the name of the module, e.g. `"bank"`. -- `msg` is the type of the incoming messages the module must handle. -- `val` is the type of the return value (must be common across all messages the module receives). -- `api` is the query api for querying state in the url format (more on this later). +- `h` is the transaction router api type. +- `q` is the query api type for querying state in the url format (more on this later). - `s` is the set of effects introduced by this module. - `r` is the global set of effects that this module will run in when part of a larger application (more on this later). diff --git a/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Message.md b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Message.md index 8cd0aa37..39220d24 100644 --- a/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Message.md +++ b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Message.md @@ -2,7 +2,7 @@ ## Message Types -The `Message` module is ultimately a small state machine used for processing messages. Each module must define what messages it accepts, if any. Like many other types found in the SDK, this message class must implement the `HasCodec` class. We recommend using a protobuf serialization format for messages using either the `proto3-suite` or `proto-lens` libraries, though in theory you could use anything (e.g. `JSON`). +Each module is ultimately a small state machine used for processing messages. Each module must define what messages it accepts, if any. Like many other types found in the SDK, this message class must implement the `HasCodec` class. We recommend using a protobuf serialization format for messages using either the `proto3-suite` or `proto-lens` libraries, though in theory you could use anything (e.g. `JSON`). ### `proto3-suite` The advantages of using the `proto3-suite` library are that it has support for generics and that you can generate a `.proto` file from your haskell code for export to other applications. This is particularly useful when prototyping or when you have control over the message specification. @@ -26,10 +26,9 @@ import Data.Text (Text) import GHC.Generics (Generic) import Nameservice.Modules.Nameservice.Types (Name(..)) import Nameservice.Modules.Token (Amount) -import Nameservice.Modules.TypedMessage (TypedMessage(..)) import Proto3.Suite (Named, Message, fromByteString, toLazyByteString) import Tendermint.SDK.Types.Address (Address) -import Tendermint.SDK.Types.Message (Msg(..), ValidateMessage(..), +import Tendermint.SDK.Types.Message (Msg(..), ValidateMessage(..), HasMessageType(..), isAuthorCheck, nonEmptyCheck, coerceProto3Error, formatMessageParseError) import Tendermint.SDK.Codec (HasCodec(..)) @@ -81,45 +80,28 @@ instance HasCodec BuyName where decode = first (formatMessageParseError . coerceProto3Error) . fromByteString ~~~ -We want a sum type that covers all possible messages the module can receive. As `protobuf` is a schemaless format, parsing is sometimes ambiguous if two types are the same up to field names, or one is a subset of the other. For this reason we defined a type called `TypedMessage`: +As `protobuf` is a schemaless format, parsing is sometimes ambiguous if two types are the same up to field names, or one is a subset of the other. For this reason we use the type class `HasTypedMessage` ~~~ haskell ignore -data TypedMessage = TypedMessage - { typedMessageType :: Text - , typedMessageContents :: BS.ByteString - } deriving (Eq, Show, Generic) - -instance Message TypedMessage -instance Named TypedMessage - -instance HasCodec TypedMessage where - encode = cs . toLazyByteString - decode = first (formatMessageParseError . coerceProto3Error) . fromByteString +class HasMessageType msg where + messageType :: Proxy msg -> Text ~~~ -This allows us to disambiguated messages based on the `type` field, so that for example we can distinguish `DeleteName` from a submessage of `BuyName`. With that out of the way, we can define the module level (sum) message type: +to associate each message to a tag to assist in parsing. So for example, we can implement this class for our message types as ~~~ haskell -data NameserviceMessage = - NSetName SetName - | NBuyName BuyName - | NDeleteName DeleteName - deriving (Eq, Show, Generic) - -instance HasCodec NameserviceMessage where - decode bs = do - TypedMessage{..} <- decode bs - case typedMessageType of - "SetName" -> NSetName <$> decode typedMessageContents - "DeleteName" -> NDeleteName <$> decode typedMessageContents - "BuyName" -> NBuyName <$> decode typedMessageContents - _ -> Left . cs $ "Unknown Nameservice message type " ++ cs typedMessageType - encode = \case - NSetName msg -> encode msg - NBuyName msg -> encode msg - NDeleteName msg -> encode msg + +instance HasMessageType SetName where + messageType _ = "SetName" + +instance HasMessageType DeleteName where + messageType _ = "DeleteName" + +instance HasMessageType BuyName where + messageType _ = "BuyName" ~~~ + ## Message Validation Message validation is an important part of the transaction life cycle. When a `checkTx` message comes in, Tendermint is asking whether a transaction bytestring from the mempool is potentially runnable. At the very least this means that @@ -192,14 +174,4 @@ instance ValidateMessage BuyName where ] ~~~ -Finally we can define a `ValidateMessage` instance for our top level message type by dispatching on the message type: - -~~~ haskell -instance ValidateMessage NameserviceMessage where - validateMessage m@Msg{msgData} = case msgData of - NBuyName msg -> validateMessage m {msgData = msg} - NSetName msg -> validateMessage m {msgData = msg} - NDeleteName msg -> validateMessage m {msgData = msg} -~~~ - [Next: Keeper](Keeper.md) diff --git a/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Module.md b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Module.md index 00a9622a..92f77a8b 100644 --- a/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Module.md +++ b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Module.md @@ -8,19 +8,19 @@ At this point we can collect the relevant pieces to form the Nameservice module: module Tutorial.Nameservice.Module where import Nameservice.Modules.Nameservice.Keeper (NameserviceEffs, eval) -import Nameservice.Modules.Nameservice.Messages (NameserviceMessage) -import Nameservice.Modules.Nameservice.Query (Api, server) -import Nameservice.Modules.Nameservice.Router (router) +import Nameservice.Modules.Nameservice.Query (QueryApi, server) +import Nameservice.Modules.Nameservice.Router (MessageApi, messageHandlers) import Nameservice.Modules.Nameservice.Types (NameserviceModuleName) import Nameservice.Modules.Token (TokenEffs) import Polysemy (Members) -import Tendermint.SDK.Application (Module (..), - defaultTxChecker) -import Tendermint.SDK.BaseApp (BaseAppEffs) +import Data.Proxy +import Tendermint.SDK.Application (Module (..)) +import Tendermint.SDK.BaseApp (BaseAppEffs, + DefaultCheckTx (..)) -- a convenient type alias type NameserviceM r = - Module NameserviceModuleName NameserviceMessage () Api NameserviceEffs r + Module NameserviceModuleName MessageApi QueryApi NameserviceEffs r nameserviceModule :: Members BaseAppEffs r @@ -28,31 +28,38 @@ nameserviceModule => Members NameserviceEffs r => NameserviceM r nameserviceModule = Module - { moduleTxDeliverer = router - , moduleTxChecker = defaultTxChecker + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r) , moduleQueryServer = server , moduleEval = eval } + ~~~ -We are using `defaultTxChecker` as our transaction checker, which is a static message validator defined as +Here We are using `defaultCheckTx` as our transaction checker, which is a static message validator defined that respons to any message with the following handler: ~~~ haskell ignore -defaultTxChecker + +defaultCheckTxHandler :: Member (Error AppError) r => ValidateMessage msg - => RoutedTx msg + => RoutingTx msg -> Sem r () -defaultTxChecker (RoutedTx Tx{txMsg}) = +defaultCheckTxHandler(RoutingTx Tx{txMsg}) = case validateMessage txMsg of V.Failure err -> throwSDKError . MessageValidation . map formatMessageSemanticError $ err V.Success _ -> pure () + ~~~ -This means that we are only doing static validation, meaning that we're not interested in checking message validitity against the database. This is reflected in the return type for the checker `Sem r ()`. If you want to add custom checking, you may write a custom checker for your module. +Note that this checker can be used to implement any transaction for which +1. The message accepted by the router has a `ValidateMessage` instance +2. The return type is marked with `OnCheckUnit`, meaning that `()` is returned for any `checkTx` ABCI message. + +To generate a router for which every transaction has these properties, we used the `defaultCheckTx` type class method -Note the constraints on the module's effects `r`: +Note the constraints on `r`: ~~~ haskell ignore ... diff --git a/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Query.md b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Query.md index ecf78502..8f8d8bc1 100644 --- a/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Query.md +++ b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Query.md @@ -10,7 +10,7 @@ import Nameservice.Modules.Nameservice.Keeper (storeKey) import Nameservice.Modules.Nameservice.Types (Whois, Name) import Polysemy (Members) import Polysemy.Error (Error) -import Tendermint.SDK.BaseApp (RawStore, AppError, RouteT, QueryApi, storeQueryHandlers) +import Tendermint.SDK.BaseApp (RawStore, AppError, RouteQ, QueryApi, storeQueryHandlers) ~~~ The way to query application state is via the `query` message which uses a `url` like format. The SDK tries to abstract as much of this away as possible. For example, if you want to only serve state that you have registered with the store via the `IsKey` class, then things are very easy. If you need to make joins to serve requests, we support this as well and it's not hard, but we will skip this for now. @@ -31,11 +31,13 @@ To serve all the data registered with the `IsKey` class, we can use the `storeQu ~~~ haskell server :: Members [RawStore, Error AppError] r - => RouteT Api r + => RouteQ Api r server = storeQueryHandlers (Proxy @NameserviceContents) storeKey (Proxy :: Proxy r) ~~~ -Here `RouteT` is a type family that can build a server from the `Api` type to handle incoming requests. It is similar to how `servant` works, and is largely copy-pasted from that codebase. +Here `RouteT` is a type family that can build a server from the `Api` type to handle incoming requests. It is similar to how `servant` works, and is largely vendored from that codebase. -[Next: Module](Module.md) +Note that more advanced queries are possible other than just serving what is in storage. For example you might want to use joins to fulfill requests or use query parameters in the url. These are all possible, but we won't go into details here as they are not used in the app. + +[Next: Router](Router.md) diff --git a/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Router.md b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Router.md new file mode 100644 index 00000000..dda61f7b --- /dev/null +++ b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Router.md @@ -0,0 +1,120 @@ + +# Router + +## Tutorial.Nameservice.Router + +The Router is where you specifiy the handlers for the messages that the module accepts. The router is typed in a [servant](https://hackage.haskell.org/package/servant) style, using combinators and primitives to declare a very precise type for the router. + +~~~ haskell +module Tutorial.Nameservice.Router where + +import Nameservice.Modules.Nameservice.Keeper (NameserviceEffs, + buyName, deleteName, + setName) +import Nameservice.Modules.Nameservice.Messages (BuyName, DeleteName, + SetName) +import Nameservice.Modules.Token (TokenEffs) +import Polysemy (Members, Sem) +import Servant.API ((:<|>) (..)) +import Tendermint.SDK.BaseApp ((:~>), BaseAppEffs, + Return, + RouteContext (..), + RouteTx, + RoutingTx (..), + TxEffs, TypedMessage, + incCount, withTimer) +import Tendermint.SDK.Types.Message (Msg (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) + +~~~ + +## Typing the Router + +First we declare the type for our router + +~~~ haskell +type MessageApi = + TypedMessage BuyName :~> Return () + :<|> TypedMessage SetName :~> Return () + :<|> TypedMessage DeleteName :~> Return () +~~~ + +Lets break it down: + +- `(:<|>)` is the operator which denotes alternative, so our router is composed of 3 handlers in this case. +- `TypedMessage` is a combinator that speficies that message type we want to accept. We requre that whatever the message type is, it implements the `HasTypedMessage` class. +- `(:~>)` is a combinator that allows us to connect a message type with a response +- `Return` is used to specify the return type. + +Since there are two possible ABCI messages that the router has to accomodate, `checkTx` and `deliverTx`, the router may return different values depending on the ABCI message type. For example, it's possible that the `checkTx` does not fully mimic the transaction and simply returns `()`, while the `deliverTx` message returns a value of type `Whois`. Concretely you would write + +~~~ haskell ignore +type BuyNameHandler = TypeMessage BuyName :~> Return' 'OnCheckUnit Whois +~~~ + +or equivalently using the alias + +~~~ haskell ignore +type BuyNameHandler = TypeMessage BuyName :~> Return Whois +~~~ + + Alternatively, you could write the application so that each `checkTx` ABCI message is handled in the same way as the `deliverTx` message, e.g. the both return a value of type `Whois`. + +~~~ haskell ignore +type BuyNameHandler = TypeMessage BuyName :~> Return' 'OnCheckEval Whois +~~~ + + +In the case of our actual application, all the transactions return `()` for both `checkTx` and `deliverTx` + +## Implementing the Handlers + +Similar to the servant style, the types for the handlers must be computed from the type of the router. This requires that you understand what each of the combinators corresponds to, and again this ultimately depends on which `RouteContext` we're in, either `CheckTx` or `DeliverTx`. + +Rather than cover all possible cases, we just note that in the case of the Nameservice app we end up with the following server type for the `DeliverTx` context: + +~~~ haskell + +messageHandlers + :: Members BaseAppEffs r + => Members TokenEffs r + => Members NameserviceEffs r + => RouteTx MessageApi r 'DeliverTx +messageHandlers = buyNameH :<|> setNameH :<|> deleteNameH + +buyNameH + :: Members BaseAppEffs r + => Members TxEffs r + => Members TokenEffs r + => Members NameserviceEffs r + => RoutingTx BuyName + -> Sem r () +buyNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "buy_total" + withTimer "buy_duration_seconds" $ buyName msgData + +setNameH + :: Members BaseAppEffs r + => Members TxEffs r + => Members NameserviceEffs r + => RoutingTx SetName + -> Sem r () +setNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "set_total" + withTimer "set_duration_seconds" $ setName msgData + +deleteNameH + :: Members BaseAppEffs r + => Members TxEffs r + => Members TokenEffs r + => Members NameserviceEffs r + => RoutingTx DeleteName + -> Sem r () +deleteNameH (RoutingTx Tx{txMsg=Msg{msgData}}) = do + incCount "delete_total" + withTimer "delete_duration_seconds" $ deleteName msgData + + ~~~ + + +[Next: Module](Module.md) \ No newline at end of file diff --git a/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Types.md b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Types.md index 603cad91..b698a019 100644 --- a/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Types.md +++ b/hs-abci-examples/nameservice/tutorial/Tutorial/Nameservice/Types.md @@ -133,19 +133,11 @@ The [`cosmos-sdk`](https://github.com/cosmos/cosmos-sdk) assumes that you use `u In order to register the `Whois` type with the query service, you must implement the `Queryable` typeclass: ~~~ haskell ignore -class Queryable a where +class HasCodec a => Queryable a where type Name a :: Symbol - encodeQueryResult :: a -> Base64String - decodeQueryResult :: Base64String -> Either Text a - - default encodeQueryResult :: HasCodec a => a -> Base64String - encodeQueryResult = fromBytes . encode - - default decodeQueryResult :: HasCodec a => Base64String -> Either Text a - decodeQueryResult = decode . toByte ~~~ -What this means is that you need to supply codecs for the type to query, with the default using the `HasCodec` class. You also need to name the type, as this will match the leaf of the `url` used for querying. So for example, in the Nameservice app we have +This means that any item which is queryable needs to have codecs via the `HasCodec` class. You also need to name the type, as this will match the leaf of the `url` used for querying. So for example, in the Nameservice app we have ~~~ haskell instance BA.Queryable Whois where diff --git a/hs-abci-examples/simple-storage/package.yaml b/hs-abci-examples/simple-storage/package.yaml index a68c990b..38cddd95 100644 --- a/hs-abci-examples/simple-storage/package.yaml +++ b/hs-abci-examples/simple-storage/package.yaml @@ -129,9 +129,8 @@ tests: - data-default-class - hs-abci-sdk - simple-storage - - hs-abci-types - hs-abci-test-utils - hs-tendermint-client - hspec - - lens + - mtl - servant diff --git a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs b/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs index bfd694b4..35e529d6 100644 --- a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs +++ b/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage.hs @@ -1,32 +1,34 @@ module SimpleStorage.Modules.SimpleStorage ( SimpleStorageM - , Api + , QueryApi + , MessageApi , simpleStorageModule , module SimpleStorage.Modules.SimpleStorage.Keeper , module SimpleStorage.Modules.SimpleStorage.Message , module SimpleStorage.Modules.SimpleStorage.Types ) where +import Data.Proxy import Polysemy (Member, Members) import SimpleStorage.Modules.SimpleStorage.Keeper hiding (storeKey) import SimpleStorage.Modules.SimpleStorage.Message -import SimpleStorage.Modules.SimpleStorage.Query (Api, server) -import SimpleStorage.Modules.SimpleStorage.Router (router) +import SimpleStorage.Modules.SimpleStorage.Query (QueryApi, server) +import SimpleStorage.Modules.SimpleStorage.Router (MessageApi, + messageHandlers) import SimpleStorage.Modules.SimpleStorage.Types -import Tendermint.SDK.Application (Module (..), - defaultTxChecker) +import Tendermint.SDK.Application (Module (..)) import qualified Tendermint.SDK.BaseApp as BaseApp type SimpleStorageM r = - Module "simple_storage" SimpleStorageMessage () Api SimpleStorageEffs r + Module "simple_storage" MessageApi QueryApi SimpleStorageEffs r simpleStorageModule :: Member SimpleStorage r => Members BaseApp.BaseAppEffs r => SimpleStorageM r simpleStorageModule = Module - { moduleTxDeliverer = router - , moduleTxChecker = defaultTxChecker + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = BaseApp.defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r) , moduleQueryServer = server , moduleEval = eval } diff --git a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Message.hs b/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Message.hs index 0d99be75..fe54cc93 100644 --- a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Message.hs +++ b/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Message.hs @@ -1,14 +1,13 @@ module SimpleStorage.Modules.SimpleStorage.Message - ( SimpleStorageMessage(..) - , UpdateCountTx(..) + ( UpdateCountTx(..) )where import Control.Lens (from, iso, view, (&), - (.~), (^.)) -import Control.Lens.Wrapped (Wrapped (..), _Unwrapped') -import Data.Bifunctor (first) + (.~), (^.), _Wrapped') +import Control.Lens.Wrapped (Wrapped (..)) +import Data.Bifunctor (bimap) import Data.Int (Int32) -import qualified Data.ProtoLens as PL +import qualified Data.ProtoLens as P import Data.ProtoLens.Message (Message (..)) import Data.Serialize.Text () import Data.String.Conversions (cs) @@ -18,28 +17,18 @@ import GHC.Generics (Generic) import Proto.SimpleStorage.Messages as M import Proto.SimpleStorage.Messages_Fields as M import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Types.Message (Msg (..), +import Tendermint.SDK.Types.Message (HasMessageType (..), ValidateMessage (..)) -data SimpleStorageMessage = - UpdateCount UpdateCountTx - -instance ValidateMessage SimpleStorageMessage where - validateMessage m@Msg{msgData} = case msgData of - UpdateCount msg -> validateMessage m {msgData = msg} - -instance HasCodec SimpleStorageMessage where - decode = first cs . fmap (UpdateCount . view _Unwrapped') . PL.decodeMessage - encode = \case - UpdateCount a -> PL.encodeMessage $ a ^. from _Unwrapped' - --------------------------------------------------------------------------------- data UpdateCountTx = UpdateCountTx { updateCountTxUsername :: Text , updateCountTxCount :: Int32 } deriving (Show, Eq, Generic) +instance HasMessageType UpdateCountTx where + messageType _ = "update_count" + instance ValidateMessage UpdateCountTx where validateMessage _ = Success () @@ -56,3 +45,7 @@ instance Wrapped UpdateCountTx where UpdateCountTx { updateCountTxUsername = msg ^. M.username , updateCountTxCount = msg ^. M.count } + +instance HasCodec UpdateCountTx where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage diff --git a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Query.hs b/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Query.hs index 57d09fcb..788730b2 100644 --- a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Query.hs +++ b/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Query.hs @@ -1,6 +1,6 @@ module SimpleStorage.Modules.SimpleStorage.Query ( CountStoreContents - , Api + , QueryApi , server ) where @@ -14,11 +14,11 @@ import qualified Tendermint.SDK.BaseApp as BaseApp type CountStoreContents = '[(CountKey, Count)] -type Api = BaseApp.QueryApi CountStoreContents +type QueryApi = BaseApp.QueryApi CountStoreContents server :: Members [BaseApp.RawStore, Error BaseApp.AppError] r - => BaseApp.RouteT Api r + => BaseApp.RouteQ QueryApi r server = BaseApp.storeQueryHandlers (Proxy :: Proxy CountStoreContents) storeKey (Proxy :: Proxy r) diff --git a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Router.hs b/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Router.hs index 817363df..57a9e9a6 100644 --- a/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Router.hs +++ b/hs-abci-examples/simple-storage/src/SimpleStorage/Modules/SimpleStorage/Router.hs @@ -1,5 +1,6 @@ module SimpleStorage.Modules.SimpleStorage.Router - ( router + ( MessageApi + , messageHandlers ) where import Polysemy (Member, Members, @@ -8,19 +9,30 @@ import SimpleStorage.Modules.SimpleStorage.Keeper (SimpleStorage, updateCount) import SimpleStorage.Modules.SimpleStorage.Message import SimpleStorage.Modules.SimpleStorage.Types (Count (..)) -import Tendermint.SDK.BaseApp (TxEffs) +import Tendermint.SDK.BaseApp ((:~>), Return, + RouteContext (..), + RouteTx, + RoutingTx (..), + TxEffs, + TypedMessage) import Tendermint.SDK.Types.Message (Msg (..)) -import Tendermint.SDK.Types.Transaction (PreRoutedTx (..), - Tx (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) -router +type MessageApi = + TypedMessage UpdateCountTx :~> Return () + +messageHandlers + :: Member SimpleStorage r + => RouteTx MessageApi r 'DeliverTx +messageHandlers = updateCountH + +updateCountH :: Member SimpleStorage r => Members TxEffs r - => PreRoutedTx SimpleStorageMessage + => RoutingTx UpdateCountTx -> Sem r () -router (PreRoutedTx Tx{txMsg}) = +updateCountH (RoutingTx Tx{txMsg}) = let Msg{msgData} = txMsg - in case msgData of - UpdateCount UpdateCountTx{updateCountTxCount} -> - updateCount (Count updateCountTxCount) + UpdateCountTx{updateCountTxCount} = msgData + in updateCount (Count updateCountTxCount) diff --git a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs index cc31c2d4..401df1ec 100644 --- a/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs +++ b/hs-abci-examples/simple-storage/test/SimpleStorage/Test/E2ESpec.hs @@ -1,19 +1,34 @@ module SimpleStorage.Test.E2ESpec (spec) where -import Control.Lens ((^.)) -import qualified Data.ByteArray.Base64String as Base64 -import Data.Default.Class (def) +import Control.Monad.Reader (ReaderT, runReaderT) +import Data.Default.Class (def) import Data.Proxy -import qualified Network.ABCI.Types.Messages.Response as Resp -import qualified Network.Tendermint.Client as RPC -import Servant.API ((:>)) -import qualified SimpleStorage.Modules.SimpleStorage as SS -import Tendermint.SDK.BaseApp.Query (QueryArgs (..)) -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.Utils.Client (ClientResponse (..), - HasClient (..)) -import Tendermint.Utils.Request (runRPC) -import Tendermint.Utils.User (User (..), makeUser, mkSignedRawTransactionWithRoute) +import qualified Network.Tendermint.Client as RPC +import Servant.API ((:<|>) (..)) +import SimpleStorage.Application +import qualified SimpleStorage.Modules.SimpleStorage as SS +import Tendermint.SDK.Application.Module (AppQueryRouter (QApi), + AppTxRouter (TApi)) +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Query (QueryArgs (..), + QueryResult (..), + defaultQueryArgs) +import qualified Tendermint.SDK.Modules.Auth as Auth +import Tendermint.SDK.Types.Address (Address) +import Tendermint.Utils.Client (ClientConfig (..), + EmptyTxClient (..), + HasQueryClient (..), + HasTxClient (..), + QueryClientResponse (..), + TxClientResponse (..), + TxOpts (..), + defaultClientTxOpts) +import Tendermint.Utils.ClientUtils (assertQuery, assertTx, + ensureResponseCodes, + rpcConfig) +import Tendermint.Utils.User (User (..), + makeSignerFromUser, + makeUser) import Test.Hspec spec :: Spec @@ -21,43 +36,86 @@ spec = do describe "SimpleStorage E2E - via hs-tendermint-client" $ do it "Can query /health to make sure the node is alive" $ do - resp <- runRPC RPC.health + resp <- RPC.runTendermintM rpcConfig RPC.health resp `shouldBe` RPC.ResultHealth - --it "Can query the count and make sure its initialized to 0" $ do - -- let queryReq = QueryArgs - -- { queryArgsData = SS.CountKey - -- , queryArgsHeight = 0 - -- , queryArgsProve = False - -- } - -- ClientResponse{clientResponseData = Just foundCount} <- runQueryRunner $ getCount queryReq - -- foundCount `shouldBe` SS.Count 0 - it "Can submit a tx synchronously and make sure that the response code is 0 (success)" $ do - let txMsg = SS.UpdateCount $ SS.UpdateCountTx "irakli" 4 - tx <- mkSignedRawTransactionWithRoute "simple_storage" user1 txMsg - let txReq = RPC.RequestBroadcastTxCommit - { RPC.requestBroadcastTxCommitTx = Base64.fromBytes . encode $ tx - } - deliverResp <- fmap RPC.resultBroadcastTxCommitDeliverTx . runRPC $ RPC.broadcastTxCommit txReq - let deliverRespCode = deliverResp ^. Resp._deliverTxCode - deliverRespCode `shouldBe` 0 + let txOpts = TxOpts + { txOptsGas = 0 + , txOptsSigner = makeSignerFromUser user1 + } + tx = SS.UpdateCountTx + { SS.updateCountTxUsername = "charles" + , SS.updateCountTxCount = 4 + } + resp <- assertTx . runTxClientM $ updateCount txOpts tx + ensureResponseCodes (0,0) resp it "can make sure the synchronous tx transaction worked and the count is now 4" $ do - let queryReq = QueryArgs - { queryArgsData = SS.CountKey - , queryArgsHeight = 0 - , queryArgsProve = False - } - ClientResponse{clientResponseData = Just foundCount} <- runRPC $ getCount queryReq + resp <- assertQuery . RPC.runTendermintM rpcConfig $ + getCount defaultQueryArgs { queryArgsData = SS.CountKey } + let foundCount = queryResultData resp foundCount `shouldBe` SS.Count 4 -------------------------------------------------------------------------------- +-- Query Client +-------------------------------------------------------------------------------- + +getCount + :: QueryArgs SS.CountKey + -> RPC.TendermintM (QueryClientResponse SS.Count) -getCount :: QueryArgs SS.CountKey -> RPC.TendermintM (ClientResponse SS.Count) -getCount = - let apiP = Proxy :: Proxy ("simple_storage" :> SS.Api) - in genClient (Proxy :: Proxy RPC.TendermintM) apiP def +getAccount + :: QueryArgs Address + -> RPC.TendermintM (QueryClientResponse Auth.Account) + +getCount :<|> getAccount = + genClientQ (Proxy :: Proxy m) queryApiP def + where + queryApiP :: Proxy (QApi SimpleStorageModules) + queryApiP = Proxy + + +-------------------------------------------------------------------------------- +-- Tx Client +-------------------------------------------------------------------------------- + +txClientConfig :: ClientConfig +txClientConfig = + let getNonce addr = do + resp <- RPC.runTendermintM rpcConfig $ getAccount $ + defaultQueryArgs { queryArgsData = addr } + case resp of + QueryError e -> + if appErrorCode e == 2 + then pure 0 + else error $ "Unknown nonce error: " <> show (appErrorMessage e) + QueryResponse QueryResult{queryResultData} -> + pure $ Auth.accountNonce queryResultData + + in ClientConfig + { clientGetNonce = getNonce + , clientRPC = rpcConfig + } + +type TxClientM = ReaderT ClientConfig IO + +runTxClientM :: TxClientM a -> IO a +runTxClientM m = runReaderT m txClientConfig + +updateCount + :: TxOpts + -> SS.UpdateCountTx + -> TxClientM (TxClientResponse () ()) + +updateCount :<|> EmptyTxClient = + genClientT (Proxy @TxClientM) txApiP defaultClientTxOpts + where + txApiP :: Proxy (TApi SimpleStorageModules) + txApiP = Proxy + + +-------------------------------------------------------------------------------- user1 :: User user1 = makeUser "f65255094d7773ed8dd417badc9fc045c1f80fdc5b2d25172b031ce6933e039a" diff --git a/hs-abci-sdk/package.yaml b/hs-abci-sdk/package.yaml index d6760493..068fdfad 100644 --- a/hs-abci-sdk/package.yaml +++ b/hs-abci-sdk/package.yaml @@ -104,7 +104,7 @@ library: - Tendermint.SDK.BaseApp.Metrics - Tendermint.SDK.BaseApp.Metrics.Prometheus - Tendermint.SDK.BaseApp.Query - - Tendermint.SDK.BaseApp.Query.Class + - Tendermint.SDK.BaseApp.Query.Router - Tendermint.SDK.BaseApp.Query.Store - Tendermint.SDK.BaseApp.Query.Types - Tendermint.SDK.BaseApp.Router.Delayed @@ -115,6 +115,11 @@ library: - Tendermint.SDK.BaseApp.Store.RawStore - Tendermint.SDK.BaseApp.Store.Scope - Tendermint.SDK.BaseApp.Transaction + - Tendermint.SDK.BaseApp.Transaction.Checker + - Tendermint.SDK.BaseApp.Transaction.Effect + - Tendermint.SDK.BaseApp.Transaction.Modifier + - Tendermint.SDK.BaseApp.Transaction.Router + - Tendermint.SDK.BaseApp.Transaction.Types - Tendermint.SDK.Codec - Tendermint.SDK.Crypto - Tendermint.SDK.Modules.Auth @@ -173,3 +178,4 @@ tests: - servant - string-conversions - text + - validation diff --git a/hs-abci-sdk/protos/types/transaction.proto b/hs-abci-sdk/protos/types/transaction.proto index d7c19d4e..f069828b 100644 --- a/hs-abci-sdk/protos/types/transaction.proto +++ b/hs-abci-sdk/protos/types/transaction.proto @@ -2,9 +2,14 @@ syntax = "proto3"; package Transaction; message RawTransaction { - bytes data = 1; + TypedMessage data = 1; int64 gas = 2; bytes signature = 3; string route = 4; uint64 nonce = 5; +} + +message TypedMessage { + string type = 1; + bytes data = 2; } \ No newline at end of file diff --git a/hs-abci-sdk/src/Tendermint/SDK/Application.hs b/hs-abci-sdk/src/Tendermint/SDK/Application.hs index 2205f5e3..5f90a229 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Application.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Application.hs @@ -1,7 +1,6 @@ module Tendermint.SDK.Application ( Modules(..) , Module(..) - , defaultTxChecker , HandlersContext(..) , AnteHandler(..) , baseAppAnteHandler diff --git a/hs-abci-sdk/src/Tendermint/SDK/Application/AnteHandler.hs b/hs-abci-sdk/src/Tendermint/SDK/Application/AnteHandler.hs index 98f63600..443ffa46 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Application/AnteHandler.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Application/AnteHandler.hs @@ -4,18 +4,19 @@ module Tendermint.SDK.Application.AnteHandler , baseAppAnteHandler ) where -import Control.Monad (unless) +import Control.Monad (unless) import Polysemy -import Polysemy.Error (Error) -import qualified Tendermint.SDK.Application.Module as M -import Tendermint.SDK.BaseApp.Errors (AppError, SDKError (..), - throwSDKError) -import qualified Tendermint.SDK.Modules.Auth as A -import Tendermint.SDK.Types.Message (Msg (..)) -import Tendermint.SDK.Types.Transaction (PreRoutedTx (..), Tx (..)) +import Polysemy.Error (Error) +import Tendermint.SDK.BaseApp.Errors (AppError, SDKError (..), + throwSDKError) +import Tendermint.SDK.BaseApp.Transaction (RoutingTx (..), + TransactionApplication) +import qualified Tendermint.SDK.Modules.Auth as A +import Tendermint.SDK.Types.Message (Msg (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) -data AnteHandler r where - AnteHandler :: (forall msg. M.Router r msg -> M.Router r msg) -> AnteHandler r +data AnteHandler r = AnteHandler + ( TransactionApplication (Sem r) -> TransactionApplication (Sem r)) instance Semigroup (AnteHandler r) where (<>) (AnteHandler h1) (AnteHandler h2) = @@ -24,30 +25,33 @@ instance Semigroup (AnteHandler r) where instance Monoid (AnteHandler r) where mempty = AnteHandler id -applyAnteHandler :: AnteHandler r -> M.Router r msg -> M.Router r msg +applyAnteHandler + :: AnteHandler r + -> TransactionApplication (Sem r) + -> TransactionApplication (Sem r) applyAnteHandler (AnteHandler ah) = ($) ah nonceAnteHandler :: Members A.AuthEffs r => Member (Error AppError) r => AnteHandler r -nonceAnteHandler = AnteHandler $ \(M.Router router) -> - M.Router $ \tx@(PreRoutedTx Tx{..}) -> do - let Msg{msgAuthor} = txMsg - mAcnt <- A.getAccount msgAuthor - account <- case mAcnt of - Just a@A.Account{accountNonce} -> do - unless (accountNonce <= txNonce) $ - throwSDKError (NonceException accountNonce txNonce) - pure a - Nothing -> do - unless (txNonce == 0) $ - throwSDKError (NonceException 0 txNonce) - A.createAccount msgAuthor - result <- router tx - A.putAccount msgAuthor $ - account { A.accountNonce = A.accountNonce account + 1} - pure result +nonceAnteHandler = AnteHandler $ + \txApplication tx@(RoutingTx Tx{..}) -> do + let Msg{msgAuthor} = txMsg + mAcnt <- A.getAccount msgAuthor + account <- case mAcnt of + Just a@A.Account{accountNonce} -> do + unless (accountNonce <= txNonce) $ + throwSDKError (NonceException accountNonce txNonce) + pure a + Nothing -> do + unless (txNonce == 0) $ + throwSDKError (NonceException 0 txNonce) + A.createAccount msgAuthor + result <- txApplication tx + A.putAccount msgAuthor $ + account { A.accountNonce = A.accountNonce account + 1} + pure result baseAppAnteHandler :: Members A.AuthEffs r diff --git a/hs-abci-sdk/src/Tendermint/SDK/Application/Handlers.hs b/hs-abci-sdk/src/Tendermint/SDK/Application/Handlers.hs index ec6d707a..a14c3322 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Application/Handlers.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Application/Handlers.hs @@ -29,14 +29,13 @@ import Tendermint.SDK.BaseApp.Errors (AppError, queryAppError, throwSDKError, txResultAppError) -import Tendermint.SDK.BaseApp.Query (HasRouter) +import qualified Tendermint.SDK.BaseApp.Query as Q import Tendermint.SDK.BaseApp.Store (ConnectionScope (..)) import qualified Tendermint.SDK.BaseApp.Store as Store +import Tendermint.SDK.BaseApp.Transaction as T import Tendermint.SDK.Crypto (RecoverableSignatureSchema, SignatureSchema (..)) -import qualified Tendermint.SDK.Modules.Auth as A -import Tendermint.SDK.Types.Transaction (PreRoutedTx (..), - parseTx) +import Tendermint.SDK.Types.Transaction (parseTx) import Tendermint.SDK.Types.TxResult (checkTxTxResult, deliverTxTxResult) @@ -85,13 +84,15 @@ data HandlersContext alg ms r core = HandlersContext -- Common function between checkTx and deliverTx makeHandlers :: forall alg ms r core. - Members A.AuthEffs r - => Member (Error AppError) r + Member (Error AppError) r => RecoverableSignatureSchema alg => Message alg ~ Digest SHA256 - => M.TxRouter ms r - => M.QueryRouter ms r - => HasRouter (M.Api ms) r + => M.AppTxRouter ms r 'T.DeliverTx + => M.AppTxRouter ms r 'T.CheckTx + => M.AppQueryRouter ms r + => Q.HasQueryRouter (M.QApi ms) r + => T.HasTxRouter (M.TApi ms) r 'T.DeliverTx + => T.HasTxRouter (M.TApi ms) r 'T.CheckTx => Members CoreEffs core => M.Eval ms core => M.Effs ms core ~ r @@ -101,11 +102,17 @@ makeHandlers HandlersContext{..} = let compileToBaseApp :: forall a. Sem r a -> Sem (BA.BaseApp core) a compileToBaseApp = M.eval modules - routerWithAH context = applyAnteHandler anteHandler $ M.txRouter context modules - txRouter context bs = case parseTx signatureAlgP bs of + + queryRouter = compileToBaseApp . M.appQueryRouter modules + + txParser bs = case parseTx signatureAlgP bs of Left err -> throwSDKError $ ParseError err - Right tx -> compileToBaseApp $ M.runRouter (routerWithAH context) (PreRoutedTx tx) - queryRouter = compileToBaseApp . M.queryRouter modules + Right tx -> pure $ T.RoutingTx tx + + txRouter ctx bs = compileToBaseApp $ do + let router = applyAnteHandler anteHandler $ M.appTxRouter modules ctx + tx <- txParser bs + router tx query (RequestQuery q) = Store.applyScope $ catch @@ -122,7 +129,7 @@ makeHandlers HandlersContext{..} = checkTx (RequestCheckTx _checkTx) = Store.applyScope $ do res <- catch ( let txBytes = _checkTx ^. Req._checkTxTx . to Base64.toBytes - in txRouter M.CheckTxContext txBytes + in txRouter T.CheckTx txBytes ) (\(err :: AppError) -> return $ def & txResultAppError .~ err @@ -132,7 +139,7 @@ makeHandlers HandlersContext{..} = deliverTx (RequestDeliverTx _deliverTx) = Store.applyScope $ do res <- catch @AppError ( let txBytes = _deliverTx ^. Req._deliverTxTx . to Base64.toBytes - in txRouter M.DeliverTxContext txBytes + in txRouter T.DeliverTx txBytes ) (\(err :: AppError) -> return $ def & txResultAppError .~ err @@ -157,13 +164,15 @@ makeHandlers HandlersContext{..} = makeApp :: forall alg ms r core. - Members A.AuthEffs r - => Members [Error AppError, Embed IO] r + Members [Error AppError, Embed IO] r => RecoverableSignatureSchema alg => Message alg ~ Digest SHA256 - => M.TxRouter ms r - => M.QueryRouter ms r - => HasRouter (M.Api ms) r + => M.AppTxRouter ms r 'DeliverTx + => M.AppTxRouter ms r 'CheckTx + => M.AppQueryRouter ms r + => Q.HasQueryRouter (M.QApi ms) r + => T.HasTxRouter (M.TApi ms) r 'T.DeliverTx + => T.HasTxRouter (M.TApi ms) r 'T.CheckTx => Members CoreEffs core => M.Eval ms core => M.Effs ms core ~ r diff --git a/hs-abci-sdk/src/Tendermint/SDK/Application/Module.hs b/hs-abci-sdk/src/Tendermint/SDK/Application/Module.hs index 6cb0f3b0..444d6ee7 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Application/Module.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Application/Module.hs @@ -1,142 +1,97 @@ {-# LANGUAGE UndecidableInstances #-} module Tendermint.SDK.Application.Module ( Module(..) - , voidModuleMessages - , defaultTxChecker , Modules(..) - , QueryRouter(Api) - , queryRouter - , RoutingContext(..) - , Router(..) - , TxRouter - , txRouter - , voidRouter + , AppQueryRouter(..) + , appQueryRouter + , AppTxRouter(..) + , appTxRouter , Eval(..) ) where -import Control.Monad.IO.Class (liftIO) -import Data.ByteString (ByteString) import Data.Proxy -import Data.String.Conversions (cs) -import qualified Data.Validation as V -import Data.Void -import GHC.TypeLits (KnownSymbol, Symbol, - symbolVal) -import Polysemy (EffectRow, Embed, Member, - Members, Sem) -import Polysemy.Error (Error) +import GHC.TypeLits (Symbol) +import Polysemy (EffectRow, Members, Sem) import Servant.API ((:<|>) (..), (:>)) -import Tendermint.SDK.BaseApp ((:&), AppError, BaseApp, - BaseAppEffs, SDKError (..), - throwSDKError) +import Tendermint.SDK.BaseApp ((:&), BaseApp, BaseAppEffs) import qualified Tendermint.SDK.BaseApp.Query as Q import qualified Tendermint.SDK.BaseApp.Transaction as T -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Types.Message (Msg (..), - ValidateMessage (..), - formatMessageSemanticError) -import Tendermint.SDK.Types.Transaction (PreRoutedTx (..), Tx (..)) -import Tendermint.SDK.Types.TxResult (TxResult) - -data Module (name :: Symbol) msg val (api :: *) (s :: EffectRow) (r :: EffectRow) = Module - { moduleTxDeliverer :: PreRoutedTx msg -> Sem (T.TxEffs :& r) val - , moduleTxChecker :: PreRoutedTx msg -> Sem (T.TxEffs :& r) val - , moduleQueryServer :: Q.RouteT api r + +data Module (name :: Symbol) (h :: *) (q :: *) (s :: EffectRow) (r :: EffectRow) = Module + { moduleTxDeliverer :: T.RouteTx h r 'T.DeliverTx + , moduleTxChecker :: T.RouteTx h r 'T.CheckTx + , moduleQueryServer :: Q.RouteQ q r , moduleEval :: forall deps. Members BaseAppEffs deps => forall a. Sem (s :& deps) a -> Sem deps a } -voidModuleMessages :: Module name msg val api s r -> Module name Void Void api s r -voidModuleMessages m = - m { moduleTxDeliverer = voidRouter - , moduleTxChecker = voidRouter - } - -defaultTxChecker - :: Member (Error AppError) r - => ValidateMessage msg - => PreRoutedTx msg - -> Sem r () -defaultTxChecker (PreRoutedTx Tx{txMsg}) = - case validateMessage txMsg of - V.Failure err -> - throwSDKError . MessageValidation . map formatMessageSemanticError $ err - V.Success _ -> pure () - data Modules (ms :: [*]) r where NilModules :: Modules '[] r - (:+) :: Module name msg val api s r -> Modules ms r -> Modules (Module name msg val api s r ': ms) r + (:+) :: Module name h q s r -> Modules ms r -> Modules (Module name h q s r ': ms) r infixr 5 :+ -------------------------------------------------------------------------------- -queryRouter - :: QueryRouter ms r - => Q.HasRouter (Api ms) r +appQueryRouter + :: AppQueryRouter ms r + => Q.HasQueryRouter (QApi ms) r => Modules ms r -> Q.QueryApplication (Sem r) -queryRouter (ms :: Modules ms r) = Q.serve (Proxy :: Proxy (Api ms)) (Proxy :: Proxy r) (routeQuery ms) +appQueryRouter (ms :: Modules ms r) = + Q.serveQueryApplication (Proxy :: Proxy (QApi ms)) (Proxy :: Proxy r) (routeAppQuery ms) -class QueryRouter ms r where - type Api ms :: * - routeQuery :: Modules ms r -> Q.RouteT (Api ms) r +class AppQueryRouter ms r where + type QApi ms :: * + routeAppQuery :: Modules ms r -> Q.RouteQ (QApi ms) r -instance QueryRouter '[Module name msg val api s r] r where - type Api '[Module name msg val api s r] = name :> api - routeQuery (m :+ NilModules) = moduleQueryServer m +instance AppQueryRouter '[Module name h q s r] r where + type QApi '[Module name h q s r] = name :> q + routeAppQuery (m :+ NilModules) = moduleQueryServer m -instance QueryRouter (m' ': ms) r => QueryRouter (Module name msg val api s r ': m' ': ms) r where - type Api (Module name msg val api s r ': m' ': ms) = (name :> api) :<|> Api (m' ': ms) - routeQuery (m :+ rest) = moduleQueryServer m :<|> routeQuery rest +instance AppQueryRouter (m' ': ms) r => AppQueryRouter (Module name h q s r ': m' ': ms) r where + type QApi (Module name h q s r ': m' ': ms) = (name :> q) :<|> QApi (m' ': ms) + routeAppQuery (m :+ rest) = moduleQueryServer m :<|> routeAppQuery rest -------------------------------------------------------------------------------- -data RoutingContext = CheckTxContext | DeliverTxContext - -data Router r msg = Router { runRouter :: PreRoutedTx msg -> Sem r TxResult } - -txRouter - :: TxRouter ms r - => RoutingContext - -> Modules ms r - -> Router r ByteString -txRouter routeContext ms = Router $ \(PreRoutedTx tx) -> - routeTx routeContext ms tx - -class TxRouter ms r where - routeTx :: forall alg. RoutingContext -> Modules ms r -> Tx alg ByteString -> Sem r TxResult - -instance (Member (Error AppError) r) => TxRouter '[] r where - routeTx _ NilModules Tx{txRoute} = - throwSDKError $ UnmatchedRoute txRoute - -instance {-# OVERLAPPING #-} (Member (Error AppError) r, TxRouter ms r, KnownSymbol name) => TxRouter (Module name Void val api s r ': ms) r where - routeTx routeContext (_ :+ rest) tx@Tx{txRoute} - | symbolVal (Proxy :: Proxy name) == cs txRoute = throwSDKError $ UnmatchedRoute txRoute - | otherwise = routeTx routeContext rest tx - -instance {-# OVERLAPPABLE #-} (Member (Error AppError) r, TxRouter ms r, HasCodec msg, HasCodec val, Member (Embed IO) r, KnownSymbol name) => TxRouter (Module name msg val api s r ': ms) r where - routeTx routeContext (m :+ rest) tx@Tx{..} - | symbolVal (Proxy :: Proxy name) == cs txRoute = do - msg <- case decode $ msgData txMsg of - Left err -> throwSDKError $ ParseError err - Right (msg :: msg) -> return msg - let msg' = txMsg {msgData = msg} - tx' = PreRoutedTx $ tx {txMsg = msg'} - ctx <- liftIO $ T.newTransactionContext tx' - T.eval ctx $ case routeContext of - CheckTxContext -> moduleTxChecker m tx' - DeliverTxContext -> moduleTxDeliverer m tx' - | otherwise = routeTx routeContext rest tx - -voidRouter - :: forall a r. - PreRoutedTx Void - -> Sem r a -voidRouter (PreRoutedTx tx) = - let Tx{txMsg} = tx - Msg{msgData} = txMsg - in pure $ absurd msgData +appTxRouter + :: AppTxRouter ms r 'T.DeliverTx + => AppTxRouter ms r 'T.CheckTx + => T.HasTxRouter (TApi ms) r 'T.DeliverTx + => T.HasTxRouter (TApi ms) r 'T.CheckTx + => Modules ms r + -> T.RouteContext + -> T.TransactionApplication (Sem r) +appTxRouter (ms :: Modules ms r) ctx = + case ctx of + T.CheckTx -> + let checkTxP = Proxy :: Proxy 'T.CheckTx + in T.serveTxApplication (Proxy :: Proxy (TApi ms)) (Proxy :: Proxy r) + checkTxP (routeAppTx checkTxP ms) + T.DeliverTx -> + let deliverTxP = Proxy :: Proxy 'T.DeliverTx + in T.serveTxApplication (Proxy :: Proxy (TApi ms)) (Proxy :: Proxy r) + deliverTxP (routeAppTx deliverTxP ms) + +class AppTxRouter ms r (c :: T.RouteContext) where + type TApi ms :: * + routeAppTx :: Proxy c -> Modules ms r -> T.RouteTx (TApi ms) r c + +instance AppTxRouter '[Module name h q s r] r 'T.CheckTx where + type TApi '[Module name h q s r] = name :> h + routeAppTx _ (m :+ NilModules) = moduleTxChecker m + +instance AppTxRouter (m' ': ms) r 'T.CheckTx => AppTxRouter (Module name h q s r ': m' ': ms) r 'T.CheckTx where + type TApi (Module name h q s r ': m' ': ms) = (name :> h) :<|> TApi (m' ': ms) + routeAppTx pc (m :+ rest) = moduleTxChecker m :<|> routeAppTx pc rest + +instance AppTxRouter '[Module name h q s r] r 'T.DeliverTx where + type TApi '[Module name h q s r] = name :> h + routeAppTx _ (m :+ NilModules) = moduleTxDeliverer m + +instance AppTxRouter (m' ': ms) r 'T.DeliverTx => AppTxRouter (Module name h q s r ': m' ': ms) r 'T.DeliverTx where + type TApi (Module name h q s r ': m' ': ms) = (name :> h) :<|> TApi (m' ': ms) + routeAppTx pc (m :+ rest) = moduleTxDeliverer m :<|> routeAppTx pc rest -------------------------------------------------------------------------------- @@ -146,10 +101,10 @@ class Eval ms core where -> forall a. Sem (Effs ms core) a -> Sem (BaseApp core) a -instance Eval '[Module name msg val api s r] core where - type Effs '[Module name msg val api s r] core = s :& BaseApp core +instance Eval '[Module name h q s r] core where + type Effs '[Module name h q s r] core = s :& BaseApp core eval (m :+ NilModules) = moduleEval m -instance (Members BaseAppEffs (Effs (m' ': ms) core), Eval (m' ': ms) core) => Eval (Module name msg val api s r ': m' ': ms) core where - type Effs (Module name msg val api s r ': m' ': ms) core = s :& (Effs (m': ms)) core +instance (Members BaseAppEffs (Effs (m' ': ms) core), Eval (m' ': ms) core) => Eval (Module name h q s r ': m' ': ms) core where + type Effs (Module name h q s r ': m' ': ms) core = s :& (Effs (m': ms)) core eval (m :+ rest) = eval rest . moduleEval m diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs index c25795ca..282cf7bb 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs @@ -66,15 +66,29 @@ module Tendermint.SDK.BaseApp , HistogramName(..) -- * Transaction + , TransactionApplication + , RoutingTx(..) + , RouteContext(..) + , RouteTx + , Return + , (:~>) + , TypedMessage , TxEffs + , EmptyTxServer + , emptyTxServer + , serveTxApplication + , DefaultCheckTx(..) -- * Query , Queryable(..) , FromQueryData(..) , QueryApi - , RouteT + , RouteQ , QueryResult(..) , storeQueryHandlers + , serveQueryApplication + , EmptyQueryServer + , emptyQueryServer ) where diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Errors.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Errors.hs index c643f77a..e89659bc 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Errors.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Errors.hs @@ -23,7 +23,7 @@ data AppError = AppError { appErrorCode :: Word32 , appErrorCodespace :: Text , appErrorMessage :: Text - } deriving Show + } deriving (Eq, Show) instance Exception AppError diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query.hs index 18cd132b..b06dfcf7 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query.hs @@ -1,8 +1,9 @@ module Tendermint.SDK.BaseApp.Query - ( serve - , HasRouter(..) + ( serveQueryApplication + , HasQueryRouter(..) , StoreQueryHandlers(..) , module Tendermint.SDK.BaseApp.Query.Types + , emptyQueryServer ) where import Control.Lens ((&), (.~)) @@ -12,7 +13,8 @@ import qualified Network.ABCI.Types.Messages.Response as Response import Polysemy (Sem) import Tendermint.SDK.BaseApp.Errors (makeAppError, queryAppError) -import Tendermint.SDK.BaseApp.Query.Class (HasRouter (..)) +import Tendermint.SDK.BaseApp.Query.Router (HasQueryRouter (..), + emptyQueryServer) import Tendermint.SDK.BaseApp.Query.Store (StoreQueryHandlers (..)) import Tendermint.SDK.BaseApp.Query.Types import Tendermint.SDK.BaseApp.Router.Delayed (emptyDelayed) @@ -20,14 +22,14 @@ import Tendermint.SDK.BaseApp.Router.Router (runRouter) import Tendermint.SDK.BaseApp.Router.Types (Application, RouteResult (..)) -serve - :: HasRouter layout r +serveQueryApplication + :: HasQueryRouter layout r => Proxy layout -> Proxy r - -> RouteT layout r + -> RouteQ layout r -> QueryApplication (Sem r) -serve pl pr server = - toQueryApplication (runRouter (route pl pr (emptyDelayed (Route server))) ()) +serveQueryApplication pl pr server = + toQueryApplication (runRouter (routeQ pl pr (emptyDelayed (Route server))) ()) toQueryApplication :: Application (Sem r) QueryRequest Response.Query diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Class.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Class.hs deleted file mode 100644 index 697f9ff6..00000000 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Class.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -module Tendermint.SDK.BaseApp.Query.Class where - -import Control.Lens ((&), (.~)) -import Control.Monad (join) -import Data.ByteArray.Base64String (fromBytes) -import Data.Default.Class (def) -import Data.Proxy -import Data.String.Conversions (cs) -import Data.Text (Text) -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.ABCI.Types.Messages.Response as Response -import Network.HTTP.Types.URI (QueryText, - parseQueryText) -import Polysemy (Sem) -import Servant.API -import Servant.API.Modifiers (FoldLenient, - FoldRequired, - RequestArgument, - unfoldRequestArgument) -import Tendermint.SDK.BaseApp.Query.Types (FromQueryData (..), Leaf, - QA, QueryArgs (..), - QueryRequest (..), - QueryResult (..)) -import qualified Tendermint.SDK.BaseApp.Router as R -import Tendermint.SDK.Codec (HasCodec (..)) -import Web.HttpApiData (FromHttpApiData (..), - parseUrlPieceMaybe) - - --------------------------------------------------------------------------------- - --- | This class is used to construct a router given a 'layout' type. The layout --- | is constructed using the combinators that appear in the instances here, no other --- | Servant combinators are recognized. -class HasRouter layout r where - -- | A route handler. - type RouteT layout r :: * - -- | Transform a route handler into a 'Router'. - route :: Proxy layout -> Proxy r -> R.Delayed (Sem r) env QueryRequest (RouteT layout r) - -> R.Router env r QueryRequest Response.Query - -instance (HasRouter a r, HasRouter b r) => HasRouter (a :<|> b) r where - type RouteT (a :<|> b) r = RouteT a r :<|> RouteT b r - - route _ pr server = R.choice (route pa pr ((\ (a :<|> _) -> a) <$> server)) - (route pb pr ((\ (_ :<|> b) -> b) <$> server)) - where pa = Proxy :: Proxy a - pb = Proxy :: Proxy b - -instance (HasRouter sublayout r, KnownSymbol path) => HasRouter (path :> sublayout) r where - - type RouteT (path :> sublayout) r = RouteT sublayout r - - route _ pr subserver = - R.pathRouter (cs (symbolVal proxyPath)) (route (Proxy :: Proxy sublayout) pr subserver) - where proxyPath = Proxy :: Proxy path - -instance ( HasRouter sublayout r, KnownSymbol sym, FromHttpApiData a - , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) - ) => HasRouter (QueryParam' mods sym a :> sublayout) r where - - type RouteT (QueryParam' mods sym a :> sublayout) r = RequestArgument mods a -> RouteT sublayout r - - route _ pr subserver = - let querytext :: QueryRequest -> Network.HTTP.Types.URI.QueryText - querytext q = parseQueryText . cs $ queryRequestParamString q - paramname = cs $ symbolVal (Proxy :: Proxy sym) - parseParam q = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev - where - mev :: Maybe (Either Text a) - mev = fmap parseQueryParam $ join $ lookup paramname $ querytext q - errReq = R.delayedFail $ R.InvalidRequest ("Query parameter " <> cs paramname <> " is required.") - errSt e = R.delayedFail $ R.InvalidRequest ("Error parsing query param " <> cs paramname <> " " <> cs e <> ".") - delayed = R.addParameter subserver $ R.withRequest parseParam - in route (Proxy :: Proxy sublayout) pr delayed - -instance (FromHttpApiData a, HasRouter sublayout r) => HasRouter (Capture' mods capture a :> sublayout) r where - - type RouteT (Capture' mods capture a :> sublayout) r = a -> RouteT sublayout r - - route _ pr subserver = - R.CaptureRouter $ - route (Proxy :: Proxy sublayout) - pr - (R.addCapture subserver $ \ txt -> case parseUrlPieceMaybe txt of - Nothing -> R.delayedFail R.PathNotFound - Just v -> return v - ) - -instance HasCodec a => HasRouter (Leaf a) r where - - type RouteT (Leaf a) r = Sem r (QueryResult a) - route _ _ = methodRouter - -instance (FromQueryData a, HasRouter sublayout r) - => HasRouter (QA a :> sublayout) r where - - type RouteT (QA a :> sublayout) r = QueryArgs a -> RouteT sublayout r - - route _ pr subserver = - let parseQueryArgs QueryRequest{..} = case fromQueryData queryRequestData of - Left e -> R.delayedFail $ R.InvalidRequest ("Error parsing query data, " <> cs e <> ".") - Right a -> pure QueryArgs - { queryArgsData = a - , queryArgsHeight = queryRequestHeight - , queryArgsProve = queryRequestProve - } - delayed = R.addBody subserver $ R.withRequest parseQueryArgs - in route (Proxy :: Proxy sublayout) pr delayed - --------------------------------------------------------------------------------- - -methodRouter - :: HasCodec b - => R.Delayed (Sem r) env req (Sem r (QueryResult b)) - -> R.Router env r req Response.Query -methodRouter action = R.leafRouter route' - where - route' env query = R.runAction action env query $ \QueryResult{..} -> - R.Route $ def & Response._queryIndex .~ queryResultIndex - & Response._queryKey .~ queryResultKey - & Response._queryValue .~ fromBytes (encode queryResultData) - & Response._queryProof .~ queryResultProof - & Response._queryHeight .~ queryResultHeight diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Router.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Router.hs new file mode 100644 index 00000000..917f35de --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Router.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE UndecidableInstances #-} +module Tendermint.SDK.BaseApp.Query.Router + ( HasQueryRouter(..) + , emptyQueryServer + , methodRouter + ) where + +import Control.Lens ((&), (.~)) +import Control.Monad (join) +import Data.ByteArray.Base64String (fromBytes) +import Data.Default.Class (def) +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.ABCI.Types.Messages.FieldTypes (WrappedVal (..)) +import Network.ABCI.Types.Messages.Response as Response +import Network.HTTP.Types.URI (QueryText, + parseQueryText) +import Polysemy (Sem) +import Servant.API +import Servant.API.Modifiers (FoldLenient, + FoldRequired, + RequestArgument, + unfoldRequestArgument) +import Tendermint.SDK.BaseApp.Query.Types (EmptyQueryServer (..), + FromQueryData (..), + Leaf, QA, + QueryArgs (..), + QueryRequest (..), + QueryResult (..)) +import qualified Tendermint.SDK.BaseApp.Router as R +import Tendermint.SDK.Codec (HasCodec (..)) +import Web.HttpApiData (FromHttpApiData (..), + parseUrlPieceMaybe) + + +-------------------------------------------------------------------------------- + +-- | This class is used to construct a router given a 'layout' type. The layout +-- | is constructed using the combinators that appear in the instances here, no other +-- | Servant combinators are recognized. +class HasQueryRouter layout r where + -- | A routeQ handler. + type RouteQ layout r :: * + -- | Transform a routeQ handler into a 'Router'. + routeQ :: Proxy layout -> Proxy r -> R.Delayed (Sem r) env QueryRequest (RouteQ layout r) + -> R.Router env r QueryRequest Response.Query + +instance (HasQueryRouter a r, HasQueryRouter b r) => HasQueryRouter (a :<|> b) r where + type RouteQ (a :<|> b) r = RouteQ a r :<|> RouteQ b r + + routeQ _ pr server = R.choice (routeQ pa pr ((\ (a :<|> _) -> a) <$> server)) + (routeQ pb pr ((\ (_ :<|> b) -> b) <$> server)) + where pa = Proxy :: Proxy a + pb = Proxy :: Proxy b + +instance (HasQueryRouter sublayout r, KnownSymbol path) => HasQueryRouter (path :> sublayout) r where + + type RouteQ (path :> sublayout) r = RouteQ sublayout r + + routeQ _ pr subserver = + R.pathRouter (cs (symbolVal proxyPath)) (routeQ (Proxy :: Proxy sublayout) pr subserver) + where proxyPath = Proxy :: Proxy path + +instance ( HasQueryRouter sublayout r, KnownSymbol sym, FromHttpApiData a + , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + ) => HasQueryRouter (QueryParam' mods sym a :> sublayout) r where + + type RouteQ (QueryParam' mods sym a :> sublayout) r = RequestArgument mods a -> RouteQ sublayout r + + routeQ _ pr subserver = + let querytext :: QueryRequest -> Network.HTTP.Types.URI.QueryText + querytext q = parseQueryText . cs $ queryRequestParamString q + paramname = cs $ symbolVal (Proxy :: Proxy sym) + parseParam q = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev + where + mev :: Maybe (Either Text a) + mev = fmap parseQueryParam $ join $ lookup paramname $ querytext q + errReq = R.delayedFail $ R.InvalidRequest ("Query parameter " <> cs paramname <> " is required.") + errSt e = R.delayedFail $ R.InvalidRequest ("Error parsing query param " <> cs paramname <> " " <> cs e <> ".") + delayed = R.addParameter subserver $ R.withRequest parseParam + in routeQ (Proxy :: Proxy sublayout) pr delayed + +instance (FromHttpApiData a, HasQueryRouter sublayout r) => HasQueryRouter (Capture' mods capture a :> sublayout) r where + + type RouteQ (Capture' mods capture a :> sublayout) r = a -> RouteQ sublayout r + + routeQ _ pr subserver = + R.CaptureRouter $ + routeQ (Proxy :: Proxy sublayout) + pr + (R.addCapture subserver $ \ txt -> case parseUrlPieceMaybe txt of + Nothing -> R.delayedFail R.PathNotFound + Just v -> return v + ) + +instance HasCodec a => HasQueryRouter (Leaf a) r where + + type RouteQ (Leaf a) r = Sem r (QueryResult a) + routeQ _ _ = methodRouter + +instance (FromQueryData a, HasQueryRouter sublayout r) + => HasQueryRouter (QA a :> sublayout) r where + + type RouteQ (QA a :> sublayout) r = QueryArgs a -> RouteQ sublayout r + + routeQ _ pr subserver = + let parseQueryArgs QueryRequest{..} = case fromQueryData queryRequestData of + Left e -> R.delayedFail $ R.InvalidRequest ("Error parsing query data, " <> cs e <> ".") + Right a -> pure QueryArgs + { queryArgsData = a + , queryArgsHeight = queryRequestHeight + , queryArgsProve = queryRequestProve + } + delayed = R.addBody subserver $ R.withRequest parseQueryArgs + in routeQ (Proxy :: Proxy sublayout) pr delayed + +emptyQueryServer :: RouteQ EmptyQueryServer r +emptyQueryServer = EmptyQueryServer + +instance HasQueryRouter EmptyQueryServer r where + type RouteQ EmptyQueryServer r = EmptyQueryServer + routeQ _ _ _ = R.StaticRouter mempty mempty + +-------------------------------------------------------------------------------- + +methodRouter + :: HasCodec b + => R.Delayed (Sem r) env req (Sem r (QueryResult b)) + -> R.Router env r req Response.Query +methodRouter action = R.leafRouter route' + where + route' env query = R.runAction action env query $ \QueryResult{..} -> + R.Route $ def & Response._queryIndex .~ WrappedVal queryResultIndex + & Response._queryKey .~ queryResultKey + & Response._queryValue .~ fromBytes (encode queryResultData) + & Response._queryProof .~ queryResultProof + & Response._queryHeight .~ WrappedVal queryResultHeight diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Store.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Store.hs index 3b76b751..a3e39af1 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Store.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Store.hs @@ -2,32 +2,33 @@ module Tendermint.SDK.BaseApp.Query.Store where -import Control.Lens (to, (^.)) -import Data.ByteArray.Base64String (fromBytes) +import Control.Lens (to, (^.)) +import Data.ByteArray.Base64String (fromBytes) import Data.Proxy -import Data.String.Conversions (cs) -import GHC.TypeLits (KnownSymbol, Symbol, - symbolVal) -import Polysemy (Members, Sem) -import Polysemy.Error (Error, throw) -import Servant.API ((:<|>) (..), (:>)) -import Tendermint.SDK.BaseApp.Errors (AppError, makeAppError) -import Tendermint.SDK.BaseApp.Query.Class -import Tendermint.SDK.BaseApp.Query.Types (Leaf, QA, QueryArgs (..), - QueryResult (..), - Queryable (..)) -import Tendermint.SDK.BaseApp.Router (RouterError (..), - pathRouter) -import Tendermint.SDK.BaseApp.Store (IsKey (..), RawKey (..), - RawStore, StoreKey, get) -import Tendermint.SDK.Codec (HasCodec) +import Data.String.Conversions (cs) +import GHC.TypeLits (KnownSymbol, Symbol, + symbolVal) +import Polysemy (Members, Sem) +import Polysemy.Error (Error, throw) +import Servant.API ((:<|>) (..), (:>)) +import Tendermint.SDK.BaseApp.Errors (AppError, makeAppError) +import Tendermint.SDK.BaseApp.Query.Router (HasQueryRouter (..), + methodRouter) +import Tendermint.SDK.BaseApp.Query.Types (Leaf, QA, QueryArgs (..), + QueryResult (..), + Queryable (..)) +import Tendermint.SDK.BaseApp.Router (RouterError (..), + pathRouter) +import Tendermint.SDK.BaseApp.Store (IsKey (..), RawKey (..), + RawStore, StoreKey, get) +import Tendermint.SDK.Codec (HasCodec) data StoreLeaf a -instance (Queryable a, KnownSymbol (Name a)) => HasRouter (StoreLeaf a) r where +instance (Queryable a, KnownSymbol (Name a)) => HasQueryRouter (StoreLeaf a) r where - type RouteT (StoreLeaf a) r = Sem r (QueryResult a) - route _ _ = pathRouter (cs (symbolVal proxyPath)) . methodRouter + type RouteQ (StoreLeaf a) r = Sem r (QueryResult a) + routeQ _ _ = pathRouter (cs (symbolVal proxyPath)) . methodRouter where proxyPath = Proxy :: Proxy (Name a) class StoreQueryHandler a (ns :: Symbol) h where @@ -56,7 +57,7 @@ instance class StoreQueryHandlers (kvs :: [*]) (ns :: Symbol) r where type QueryApi kvs :: * - storeQueryHandlers :: Proxy kvs -> StoreKey ns -> Proxy r -> RouteT (QueryApi kvs) r + storeQueryHandlers :: Proxy kvs -> StoreKey ns -> Proxy r -> RouteQ (QueryApi kvs) r instance ( IsKey k ns diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Types.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Types.hs index 96dfa1f1..6e2cf6d1 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Types.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Query/Types.hs @@ -60,20 +60,20 @@ data QueryArgs a = QueryArgs } deriving Functor -- wrap data with default query fields -defaultQueryWithData :: a -> QueryArgs a -defaultQueryWithData x = QueryArgs - { queryArgsData = x - , queryArgsHeight = 0 +defaultQueryArgs :: QueryArgs () +defaultQueryArgs = QueryArgs + { queryArgsData = () + , queryArgsHeight = -1 , queryArgsProve = False } data QueryResult a = QueryResult { queryResultData :: a - , queryResultIndex :: WrappedVal Int64 + , queryResultIndex :: Int64 , queryResultKey :: Base64String , queryResultProof :: Maybe Proof - , queryResultHeight :: WrappedVal Int64 - } deriving Functor + , queryResultHeight :: Int64 + } deriving (Eq, Show, Functor) -------------------------------------------------------------------------------- @@ -93,3 +93,5 @@ class FromQueryData a where fromQueryData bs = Right (toBytes bs ^. from rawKey) instance FromQueryData Address + +data EmptyQueryServer = EmptyQueryServer diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction.hs index 6e5008bf..be9a9507 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction.hs @@ -1,74 +1,59 @@ module Tendermint.SDK.BaseApp.Transaction - ( TxEffs - , TransactionContext(..) - , newTransactionContext - , eval + ( serveTxApplication + , serveDefaultTxChecker + -- * Re-Exports + , module Tendermint.SDK.BaseApp.Transaction.Types + , HasTxRouter(..) + , emptyTxServer + , DefaultCheckTx(..) + , TxEffs ) where -import Control.Lens ((&), (.~)) -import Control.Monad.IO.Class (liftIO) -import qualified Data.ByteArray.Base64String as Base64 -import Data.Default.Class (def) -import Data.IORef (IORef, newIORef, readIORef) -import Polysemy (Embed, Member, Sem, - raiseUnder) -import Polysemy.Error (Error, runError) -import Polysemy.Output (Output, - runOutputMonoidAssocR) -import Polysemy.State (State, runStateIORef) -import Tendermint.SDK.BaseApp.Errors (AppError, txResultAppError) -import qualified Tendermint.SDK.BaseApp.Events as E -import qualified Tendermint.SDK.BaseApp.Gas as G -import Tendermint.SDK.Codec (HasCodec (encode)) -import Tendermint.SDK.Types.Effects ((:&)) -import Tendermint.SDK.Types.Transaction (PreRoutedTx (..), Tx (..)) -import Tendermint.SDK.Types.TxResult (TxResult, txResultData, - txResultEvents, - txResultGasUsed, - txResultGasWanted) +import Control.Lens ((&), (.~)) +import Data.Proxy +import Polysemy (Sem) +import Tendermint.SDK.BaseApp.Errors (makeAppError, + txResultAppError) +import Tendermint.SDK.BaseApp.Router (Application, + RouteResult (..), + emptyDelayed, + runRouter) +import Tendermint.SDK.BaseApp.Transaction.Checker (DefaultCheckTx (..)) +import Tendermint.SDK.BaseApp.Transaction.Effect (TxEffs) +import Tendermint.SDK.BaseApp.Transaction.Router +import Tendermint.SDK.BaseApp.Transaction.Types +import Tendermint.SDK.Types.TxResult (TxResult) -type TxEffs = - [ Output E.Event - , G.GasMeter - , Error AppError - ] +import Data.ByteString (ByteString) +import Data.Default.Class (def) -data TransactionContext = TransactionContext - { gas :: IORef G.GasAmount - } +serveTxApplication + :: HasTxRouter layout r c + => Proxy layout + -> Proxy r + -> Proxy (c :: RouteContext) + -> RouteTx layout r c + -> TransactionApplication (Sem r) +serveTxApplication pl pr pc server = + toTxApplication (runRouter (routeTx pl pr pc (emptyDelayed (Route server))) ()) -newTransactionContext - :: PreRoutedTx msg - -> IO TransactionContext -newTransactionContext (PreRoutedTx Tx{txGas}) = do - initialGas <- newIORef $ G.GasAmount txGas - pure TransactionContext - { gas = initialGas - } +toTxApplication + :: Application (Sem r) (RoutingTx ByteString) TxResult + -> TransactionApplication (Sem r) +toTxApplication ra tx = do + res <- ra tx + case res of + Fail e -> pure $ def & txResultAppError .~ makeAppError e + FailFatal e -> pure $ def & txResultAppError .~ makeAppError e + Route a -> pure a -eval - :: forall r a. - HasCodec a - => Member (Embed IO) r - => TransactionContext - -> Sem (TxEffs :& r) a - -> Sem r TxResult -eval TransactionContext{..} action = do - initialGas <- liftIO $ readIORef gas - eRes <- - runError . - runStateIORef gas . - G.eval . - raiseUnder @(State G.GasAmount) $ - runOutputMonoidAssocR (pure @[]) action - gasRemaining <- liftIO $ readIORef gas - let gasUsed = initialGas - gasRemaining - baseResponse = - def & txResultGasWanted .~ G.unGasAmount initialGas - & txResultGasUsed .~ G.unGasAmount gasUsed - return $ case eRes of - Left e -> - baseResponse & txResultAppError .~ e - Right (events, a) -> - baseResponse & txResultEvents .~ events - & txResultData .~ Base64.fromBytes (encode a) + +serveDefaultTxChecker + :: HasTxRouter layout r 'CheckTx + => DefaultCheckTx layout r + => RouteTx layout r 'CheckTx ~ DefaultCheckTxT layout r + => Proxy layout + -> Proxy r + -> TransactionApplication (Sem r) +serveDefaultTxChecker pl pr = + serveTxApplication pl pr (Proxy :: Proxy 'CheckTx) (defaultCheckTx pl pr) diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Checker.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Checker.hs new file mode 100644 index 00000000..f1859567 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Checker.hs @@ -0,0 +1,51 @@ +module Tendermint.SDK.BaseApp.Transaction.Checker + ( DefaultCheckTx(..) + ) where + +import Data.Proxy +import qualified Data.Validation as V +import Polysemy (EffectRow, Member, + Sem) +import Polysemy.Error (Error) +import Servant.API ((:<|>) (..), (:>)) +import Tendermint.SDK.BaseApp.Errors (AppError, + SDKError (..), + throwSDKError) +import Tendermint.SDK.BaseApp.Transaction.Types +import Tendermint.SDK.Types.Message (ValidateMessage (..), formatMessageSemanticError) + +defaultCheckTxHandler + :: Member (Error AppError) r + => ValidateMessage msg + => RoutingTx msg + -> Sem r () +defaultCheckTxHandler(RoutingTx Tx{txMsg}) = + case validateMessage txMsg of + V.Failure err -> + throwSDKError . MessageValidation . map formatMessageSemanticError $ err + V.Success _ -> pure () + +class DefaultCheckTx api (r :: EffectRow) where + type DefaultCheckTxT api r :: * + defaultCheckTx :: Proxy api -> Proxy r -> DefaultCheckTxT api r + +instance (DefaultCheckTx a r, DefaultCheckTx b r) => DefaultCheckTx (a :<|> b) r where + type DefaultCheckTxT (a :<|> b) r = DefaultCheckTxT a r :<|> DefaultCheckTxT b r + + defaultCheckTx _ pr = + defaultCheckTx (Proxy :: Proxy a) pr :<|> defaultCheckTx (Proxy :: Proxy b) pr + +instance DefaultCheckTx rest r => DefaultCheckTx (path :> rest) r where + type DefaultCheckTxT (path :> rest) r = DefaultCheckTxT rest r + + defaultCheckTx _ = defaultCheckTx (Proxy :: Proxy rest) + +instance (Member (Error AppError) r, ValidateMessage msg) => DefaultCheckTx (TypedMessage msg :~> Return a) r where + type DefaultCheckTxT (TypedMessage msg :~> Return a) r = RoutingTx msg -> Sem r () + + defaultCheckTx _ _ = defaultCheckTxHandler + +instance DefaultCheckTx EmptyTxServer r where + type DefaultCheckTxT EmptyTxServer r = EmptyTxServer + + defaultCheckTx _ _ = EmptyTxServer diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Effect.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Effect.hs new file mode 100644 index 00000000..0f068ba7 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Effect.hs @@ -0,0 +1,78 @@ +module Tendermint.SDK.BaseApp.Transaction.Effect + ( TxEffs + , TransactionContext(..) + , newTransactionContext + , eval + ) where + +import Control.Lens ((&), (.~)) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteArray.Base64String as Base64 +import Data.Default.Class (def) +import Data.IORef (IORef, newIORef, + readIORef) +import Polysemy (Embed, Member, Sem, + raiseUnder) +import Polysemy.Error (Error, runError) +import Polysemy.Output (Output, + runOutputMonoidAssocR) +import Polysemy.State (State, runStateIORef) +import Tendermint.SDK.BaseApp.Errors (AppError, + txResultAppError) +import qualified Tendermint.SDK.BaseApp.Events as E +import qualified Tendermint.SDK.BaseApp.Gas as G +import Tendermint.SDK.BaseApp.Transaction.Types (RoutingTx (..), + Tx (..)) +import Tendermint.SDK.Codec (HasCodec (encode)) +import Tendermint.SDK.Types.Effects ((:&)) +import Tendermint.SDK.Types.TxResult (TxResult, + txResultData, + txResultEvents, + txResultGasUsed, + txResultGasWanted) + +type TxEffs = + [ Output E.Event + , G.GasMeter + , Error AppError + ] + +data TransactionContext = TransactionContext + { gas :: IORef G.GasAmount + } + +newTransactionContext + :: RoutingTx msg + -> IO TransactionContext +newTransactionContext (RoutingTx Tx{txGas}) = do + initialGas <- newIORef $ G.GasAmount txGas + pure TransactionContext + { gas = initialGas + } + +eval + :: forall r a. + HasCodec a + => Member (Embed IO) r + => TransactionContext + -> Sem (TxEffs :& r) a + -> Sem r TxResult +eval TransactionContext{..} action = do + initialGas <- liftIO $ readIORef gas + eRes <- + runError . + runStateIORef gas . + G.eval . + raiseUnder @(State G.GasAmount) $ + runOutputMonoidAssocR (pure @[]) action + gasRemaining <- liftIO $ readIORef gas + let gasUsed = initialGas - gasRemaining + baseResponse = + def & txResultGasWanted .~ G.unGasAmount initialGas + & txResultGasUsed .~ G.unGasAmount gasUsed + return $ case eRes of + Left e -> + baseResponse & txResultAppError .~ e + Right (events, a) -> + baseResponse & txResultEvents .~ events + & txResultData .~ Base64.fromBytes (encode a) diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Modifier.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Modifier.hs new file mode 100644 index 00000000..5bf84a80 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Modifier.hs @@ -0,0 +1,11 @@ +module Tendermint.SDK.BaseApp.Transaction.Modifier + ( OnCheck(..) + , OnCheckReturn + ) where + +import Tendermint.SDK.BaseApp.Transaction.Types + +type family OnCheckReturn (ctx :: RouteContext) (oc :: OnCheck) a where + OnCheckReturn 'CheckTx 'OnCheckEval a = a + OnCheckReturn 'CheckTx 'OnCheckUnit a = () + OnCheckReturn 'DeliverTx _ a = a diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Router.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Router.hs new file mode 100644 index 00000000..e91a00a0 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Router.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE UndecidableInstances #-} +module Tendermint.SDK.BaseApp.Transaction.Router + ( HasTxRouter(..) + , emptyTxServer + ) where + +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import Data.Proxy +import Data.String.Conversions (cs) +import GHC.TypeLits (KnownSymbol, + symbolVal) +import Polysemy (Embed, Member, + Sem) +import Servant.API +import qualified Tendermint.SDK.BaseApp.Router as R +import Tendermint.SDK.BaseApp.Transaction.Effect (TxEffs, eval, newTransactionContext) +import Tendermint.SDK.BaseApp.Transaction.Modifier +import Tendermint.SDK.BaseApp.Transaction.Types +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Effects ((:&)) +import Tendermint.SDK.Types.Message (HasMessageType (..), + Msg (..)) +import Tendermint.SDK.Types.TxResult (TxResult) + +-------------------------------------------------------------------------------- + +class HasTxRouter layout r (c :: RouteContext) where + type RouteTx layout r c :: * + routeTx + :: Proxy layout + -> Proxy r + -> Proxy c + -> R.Delayed (Sem r) env (RoutingTx ByteString) (RouteTx layout r c) + -> R.Router env r (RoutingTx ByteString) TxResult + +instance (HasTxRouter a r c, HasTxRouter b r c) => HasTxRouter (a :<|> b) r c where + type RouteTx (a :<|> b) r c = RouteTx a r c :<|> RouteTx b r c + + routeTx _ pr pc server = + R.choice (routeTx pa pr pc ((\ (a :<|> _) -> a) <$> server)) + (routeTx pb pr pc ((\ (_ :<|> b) -> b) <$> server)) + where pa = Proxy :: Proxy a + pb = Proxy :: Proxy b + +instance (HasTxRouter sublayout r c, KnownSymbol path) => HasTxRouter (path :> sublayout) r c where + + type RouteTx (path :> sublayout) r c = RouteTx sublayout r c + + routeTx _ pr pc subserver = + R.pathRouter (cs (symbolVal proxyPath)) (routeTx (Proxy :: Proxy sublayout) pr pc subserver) + where proxyPath = Proxy :: Proxy path + +methodRouter + :: HasCodec a + => Member (Embed IO) r + => R.Delayed (Sem r) env (RoutingTx msg) (Sem (TxEffs :& r) a) + -> R.Router env r (RoutingTx msg) TxResult +methodRouter action = R.leafRouter route' + where + route' env tx = do + ctx <- liftIO $ newTransactionContext tx + let action' = eval ctx <$> action + R.runAction action' env tx R.Route + +instance ( HasMessageType msg, HasCodec msg, HasCodec (OnCheckReturn c oc a), Member (Embed IO) r) => HasTxRouter (TypedMessage msg :~> Return' oc a) r c where + + type RouteTx (TypedMessage msg :~> Return' oc a) r c = RoutingTx msg -> Sem (TxEffs :& r) (OnCheckReturn c oc a) + + routeTx _ _ _ subserver = + let f (RoutingTx tx@Tx{txMsg}) = + if msgType txMsg == mt + then case decode $ msgData txMsg of + Left e -> R.delayedFail $ + R.InvalidRequest ("Failed to parse message of type " <> mt <> ": " <> e <> ".") + Right a -> pure . RoutingTx $ tx {txMsg = txMsg {msgData = a}} + else R.delayedFail R.PathNotFound + in methodRouter $ + R.addBody subserver $ R.withRequest f + where mt = messageType (Proxy :: Proxy msg) + +emptyTxServer :: RouteTx EmptyTxServer r c +emptyTxServer = EmptyTxServer + +instance HasTxRouter EmptyTxServer r c where + type RouteTx EmptyTxServer r c = EmptyTxServer + routeTx _ _ _ _ = R.StaticRouter mempty mempty diff --git a/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Types.hs b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Types.hs new file mode 100644 index 00000000..160e2308 --- /dev/null +++ b/hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Types.hs @@ -0,0 +1,37 @@ +module Tendermint.SDK.BaseApp.Transaction.Types + ( module Tendermint.SDK.BaseApp.Transaction.Types + -- * Re-Exports + , Tx(..) + ) where + +import Control.Lens (lens) +import Data.ByteString (ByteString) +import Tendermint.SDK.BaseApp.Router (HasPath (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) +import Tendermint.SDK.Types.TxResult (TxResult) + +data msg :~> a + +data TypedMessage msg + +data OnCheck = OnCheckEval | OnCheckUnit + +data Return' (c :: OnCheck) a + +type Return = Return' 'OnCheckUnit + +data RouteContext = CheckTx | DeliverTx deriving (Eq, Show) + +type TransactionApplication m = RoutingTx ByteString -> m TxResult + +data EmptyTxServer = EmptyTxServer + +data RoutingTx msg where + RoutingTx :: Tx alg msg -> RoutingTx msg + +instance Functor RoutingTx where + fmap f (RoutingTx tx) = RoutingTx $ fmap f tx + +instance HasPath (RoutingTx msg) where + path = lens (\(RoutingTx tx) -> txRoute tx) + (\(RoutingTx tx) r -> RoutingTx tx {txRoute = r}) diff --git a/hs-abci-sdk/src/Tendermint/SDK/Crypto.hs b/hs-abci-sdk/src/Tendermint/SDK/Crypto.hs index 40461f20..0a1e779a 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Crypto.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Crypto.hs @@ -39,6 +39,7 @@ class SignatureSchema alg where makePubKey :: Proxy alg -> B.ByteString -> Maybe (PubKey alg) makeSignature :: Proxy alg -> B.ByteString -> Maybe (Signature alg) + derivePubKey :: Proxy alg -> PrivateKey alg -> PubKey alg addressFromPubKey :: Proxy alg -> PubKey alg -> Address -- | Class allowing for signing and recovering signatures for messages. @@ -47,7 +48,7 @@ class SignatureSchema alg => RecoverableSignatureSchema alg where signRecoverableMessage :: Proxy alg -> PrivateKey alg -> Message alg -> RecoverableSignature alg recover :: Proxy alg -> RecoverableSignature alg -> Message alg -> Maybe (PubKey alg) - + serializeRecoverableSignature :: Proxy alg -> RecoverableSignature alg -> B.ByteString makeRecoverableSignature :: Proxy alg -> B.ByteString -> Maybe (RecoverableSignature alg) data Secp256k1 @@ -69,6 +70,7 @@ instance SignatureSchema Secp256k1 where makePubKey _ = Secp256k1.importPubKey makeSignature _ = Secp256k1.importSig -- For lack of a better idea, we're just going to use the Ethereum style here + derivePubKey _ = Secp256k1.derivePubKey addressFromPubKey _ = addressFromBytes . B.drop 12 . convert . hashWith Keccak_256 . Secp256k1.exportPubKey False @@ -77,6 +79,11 @@ instance RecoverableSignatureSchema Secp256k1 where signRecoverableMessage _ priv dig = Secp256k1.signRecMsg priv (msgFromSHA256 dig) recover _ sig dig = Secp256k1.recover sig (msgFromSHA256 dig) + serializeRecoverableSignature _ sig = + let csr = Secp256k1.exportCompactRecSig sig + in Short.fromShort (Secp256k1.getCompactRecSigR csr) <> + Short.fromShort (Secp256k1.getCompactRecSigS csr) <> + B.pack [Secp256k1.getCompactRecSigV csr] makeRecoverableSignature _ bs = let (r,rest) = B.splitAt 32 bs (s,v) = B.splitAt 32 rest diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth.hs index 0cb7d980..060e901f 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth.hs @@ -16,22 +16,22 @@ module Tendermint.SDK.Modules.Auth , module Tendermint.SDK.Modules.Auth.Types ) where -import Data.Void import Polysemy (Members) -import Tendermint.SDK.Application.Module (Module (..), voidRouter) -import Tendermint.SDK.BaseApp (BaseAppEffs) +import Tendermint.SDK.Application.Module (Module (..)) +import Tendermint.SDK.BaseApp (BaseAppEffs, EmptyTxServer, + emptyTxServer) import Tendermint.SDK.Modules.Auth.Keeper import Tendermint.SDK.Modules.Auth.Query import Tendermint.SDK.Modules.Auth.Types -type AuthM r = Module AuthModule Void Void Api AuthEffs r +type AuthM r = Module AuthModule EmptyTxServer Api AuthEffs r authModule :: Members BaseAppEffs r => AuthM r authModule = Module - { moduleTxDeliverer = voidRouter - , moduleTxChecker = voidRouter + { moduleTxDeliverer = emptyTxServer + , moduleTxChecker = emptyTxServer , moduleQueryServer = server , moduleEval = eval } diff --git a/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Query.hs b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Query.hs index 197bcf35..8b40e4d9 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Query.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Modules/Auth/Query.hs @@ -21,6 +21,6 @@ type Api = BaseApp.QueryApi AuthContents server :: Members [BaseApp.RawStore, Error BaseApp.AppError] r - => BaseApp.RouteT Api r + => BaseApp.RouteQ Api r server = BaseApp.storeQueryHandlers (Proxy :: Proxy AuthContents) storeKey (Proxy :: Proxy r) diff --git a/hs-abci-sdk/src/Tendermint/SDK/Types/Message.hs b/hs-abci-sdk/src/Tendermint/SDK/Types/Message.hs index a80127f1..bdd203b5 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Types/Message.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Types/Message.hs @@ -1,21 +1,56 @@ module Tendermint.SDK.Types.Message where -import Control.Lens (( # )) -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Validation as V -import qualified Proto3.Wire.Decode as Wire -import Tendermint.SDK.Types.Address (Address) +import Control.Lens (Wrapped (..), from, iso, view, + ( # ), (&), (.~), (^.)) +import Data.Bifunctor (bimap) +import Data.ByteString (ByteString) +import qualified Data.ProtoLens as P +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Validation as V +import qualified Proto.Types.Transaction as T +import qualified Proto.Types.Transaction_Fields as T +import qualified Proto3.Wire.Decode as Wire +import Tendermint.SDK.Codec (HasCodec (..)) +import Tendermint.SDK.Types.Address (Address) -- | The basic message format embedded in any transaction. data Msg msg = Msg { msgAuthor :: Address , msgData :: msg + , msgType :: Text } instance Functor Msg where fmap f msg@Msg{msgData} = msg {msgData = f msgData} +class HasMessageType msg where + messageType :: Proxy msg -> Text + +data TypedMessage = TypedMessage + { typedMsgData :: ByteString + , typedMsgType :: Text + } + +instance Wrapped TypedMessage where + type Unwrapped TypedMessage = T.TypedMessage + + _Wrapped' = iso t f + where + t TypedMessage {..} = + P.defMessage + & T.data' .~ typedMsgData + & T.type' .~ typedMsgType + f message = TypedMessage + { typedMsgData = message ^. T.data' + , typedMsgType = message ^. T.type' + } + +instance HasCodec TypedMessage where + encode = P.encodeMessage . view _Wrapped' + decode = bimap cs (view $ from _Wrapped') . P.decodeMessage + -- | This is a general error type, primarily accomodating protobuf messages being parsed -- | by either the [proto3-wire](https://hackage.haskell.org/package/proto3-wire) -- | or the [proto-lens](https://hackage.haskell.org/package/proto-lens) libraries. diff --git a/hs-abci-sdk/src/Tendermint/SDK/Types/Transaction.hs b/hs-abci-sdk/src/Tendermint/SDK/Types/Transaction.hs index babe57f4..4c255815 100644 --- a/hs-abci-sdk/src/Tendermint/SDK/Types/Transaction.hs +++ b/hs-abci-sdk/src/Tendermint/SDK/Types/Transaction.hs @@ -2,7 +2,7 @@ module Tendermint.SDK.Types.Transaction where import Control.Error (note) import Control.Lens (Wrapped (..), from, iso, view, - (&), (.~), (^.)) + (&), (.~), (^.), _Unwrapped') import Crypto.Hash (Digest, hashWith) import Crypto.Hash.Algorithms (SHA256 (..)) import Data.Bifunctor (bimap) @@ -20,7 +20,8 @@ import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Crypto (MakeDigest (..), RecoverableSignatureSchema (..), SignatureSchema (..)) -import Tendermint.SDK.Types.Message (Msg (..)) +import Tendermint.SDK.Types.Message (Msg (..), TypedMessage (..)) + -- Our standard transaction type parameterized by the signature schema 'alg' -- and an underlying message type 'msg'. data Tx alg msg = Tx @@ -43,7 +44,7 @@ instance Functor (Tx alg) where -- | Raw transaction type coming in over the wire data RawTransaction = RawTransaction - { rawTransactionData :: ByteString + { rawTransactionData :: TypedMessage -- ^ the encoded message via protobuf encoding , rawTransactionGas :: Int64 , rawTransactionRoute :: Text @@ -59,13 +60,13 @@ instance Wrapped RawTransaction where where t RawTransaction {..} = P.defMessage - & T.data' .~ rawTransactionData + & T.data' .~ (rawTransactionData ^. _Wrapped') & T.gas .~ rawTransactionGas - & T.route .~ cs rawTransactionRoute + & T.route .~ rawTransactionRoute & T.signature .~ rawTransactionSignature & T.nonce .~ rawTransactionNonce f message = RawTransaction - { rawTransactionData = message ^. T.data' + { rawTransactionData = message ^. T.data' . _Unwrapped' , rawTransactionGas = message ^. T.gas , rawTransactionRoute = message ^. T.route , rawTransactionSignature = message ^. T.signature @@ -109,8 +110,9 @@ parseTx p bs = do signerPubKey <- note "Signature recovery failed." $ recover p recSig signBytes return $ Tx { txMsg = Msg - { msgData = rawTransactionData + { msgData = typedMsgData rawTransactionData , msgAuthor = addressFromPubKey p signerPubKey + , msgType = typedMsgType rawTransactionData } , txRoute = cs rawTransactionRoute , txGas = rawTransactionGas @@ -119,9 +121,3 @@ parseTx p bs = do , txSigner = signerPubKey , txNonce = rawTransactionNonce } - -data PreRoutedTx msg where - PreRoutedTx :: Tx alg msg -> PreRoutedTx msg - -instance Functor PreRoutedTx where - fmap f (PreRoutedTx tx) = PreRoutedTx $ fmap f tx diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/CryptoSpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/CryptoSpec.hs index 139a46d2..2d2cbaff 100644 --- a/hs-abci-sdk/test/Tendermint/SDK/Test/CryptoSpec.hs +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/CryptoSpec.hs @@ -11,6 +11,7 @@ import Data.Proxy import Data.String (fromString) import Tendermint.SDK.Codec (HasCodec (..)) import Tendermint.SDK.Crypto (Secp256k1) +import Tendermint.SDK.Types.Message import Tendermint.SDK.Types.Transaction import Test.Hspec @@ -18,7 +19,7 @@ spec :: Spec spec = describe "Crypto Tests" $ do it "Can sign a transaction and recover the signature" $ do let rawTxWithoutSig = RawTransaction - { rawTransactionData = "abcd" + { rawTransactionData = TypedMessage "abcd" "foo_msg" , rawTransactionSignature = "" , rawTransactionRoute= "dog" , rawTransactionGas = 10 diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/QuerySpec.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/QuerySpec.hs index ce9191b0..e9b0dc25 100644 --- a/hs-abci-sdk/test/Tendermint/SDK/Test/QuerySpec.hs +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/QuerySpec.hs @@ -8,12 +8,10 @@ import qualified Tendermint.SDK.Application as App import qualified Tendermint.SDK.Application.Module as M import qualified Tendermint.SDK.BaseApp as BA import qualified Tendermint.SDK.BaseApp.Logger.Katip as KL -import qualified Tendermint.SDK.BaseApp.Transaction as T import Tendermint.SDK.Codec (HasCodec (..)) import qualified Tendermint.SDK.Test.SimpleStorage as SS import Tendermint.SDK.Types.Message (Msg (..)) -import Tendermint.SDK.Types.Transaction (PreRoutedTx (..), - Tx (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) import Test.Hspec type Effs = SS.SimpleStorage ': BA.BaseApp BA.CoreEffs @@ -23,24 +21,24 @@ spec = beforeAll (BA.makeContext (KL.InitialLogNamespace "test" "spec") Nothing) describe "Query tests" $ do let modules :: App.Modules '[SS.SimpleStorageM Effs] Effs modules = SS.simpleStorageModule App.:+ App.NilModules - ssServer = M.queryRouter modules - handler = App.moduleTxDeliverer SS.simpleStorageModule + ssServer = M.appQueryRouter modules + handler = M.appTxRouter modules BA.DeliverTx it "Can make a new count and query it with a multiplier" $ \ctx -> do let increaseCountMsg = Msg { msgAuthor = undefined - , msgData = SS.UpdateCount $ SS.UpdateCountTx 1 + , msgType = "update_count" + , msgData = encode $ SS.UpdateCountTx 1 } - tx = PreRoutedTx $ Tx + tx = BA.RoutingTx $ Tx { txMsg = increaseCountMsg - , txRoute = undefined + , txRoute = "simple_storage" , txGas = 0 , txSignature = undefined , txSignBytes = undefined , txSigner = undefined , txNonce = undefined } - txContext <- T.newTransactionContext tx - _ <- SS.evalToIO ctx . T.eval txContext $ handler tx + _ <- SS.evalToIO ctx $ handler tx let q = Req.Query -- TODO -- this shouldn't require / count { queryPath = "/simple_storage/manipulated/1?factor=4" diff --git a/hs-abci-sdk/test/Tendermint/SDK/Test/SimpleStorage.hs b/hs-abci-sdk/test/Tendermint/SDK/Test/SimpleStorage.hs index 454c892c..ae20c0fa 100644 --- a/hs-abci-sdk/test/Tendermint/SDK/Test/SimpleStorage.hs +++ b/hs-abci-sdk/test/Tendermint/SDK/Test/SimpleStorage.hs @@ -1,8 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Tendermint.SDK.Test.SimpleStorage - ( SimpleStorageMessage(..) - , SimpleStorageM + ( SimpleStorageM , SimpleStorage , UpdateCountTx(..) , simpleStorageModule @@ -21,8 +20,8 @@ import Data.Maybe (fromJust) import Data.Proxy import qualified Data.Serialize as Serialize import Data.Serialize.Text () -import qualified Data.Serialize.Text () import Data.String.Conversions (cs) +import Data.Validation (Validation (..)) import GHC.Generics (Generic) import Polysemy import Polysemy.Error (Error) @@ -30,8 +29,10 @@ import Servant.API import Tendermint.SDK.Application (Module (..)) import qualified Tendermint.SDK.BaseApp as BaseApp import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Types.Message (Msg (..)) -import Tendermint.SDK.Types.Transaction (PreRoutedTx (..), Tx (..)) +import Tendermint.SDK.Types.Message (HasMessageType (..), + Msg (..), + ValidateMessage (..)) +import Tendermint.SDK.Types.Transaction (Tx (..)) -------------------------------------------------------------------------------- -- Types @@ -63,13 +64,22 @@ instance BaseApp.Queryable Count where -- Message Types -------------------------------------------------------------------------------- -data SimpleStorageMessage = - UpdateCount UpdateCountTx - data UpdateCountTx = UpdateCountTx { updateCountTxCount :: Int32 } deriving (Show, Eq, Generic) +instance Serialize.Serialize UpdateCountTx + +instance HasMessageType UpdateCountTx where + messageType _ = "update_count" + +instance HasCodec UpdateCountTx where + encode = Serialize.encode + decode = first cs . Serialize.decode + +instance ValidateMessage UpdateCountTx where + validateMessage _ = Success () + -------------------------------------------------------------------------------- -- Keeper -------------------------------------------------------------------------------- @@ -104,16 +114,23 @@ eval = interpret (\case -- Router -------------------------------------------------------------------------------- -router +type MessageApi = + BaseApp.TypedMessage UpdateCountTx BaseApp.:~> BaseApp.Return () + +messageHandlers + :: Member SimpleStorage r + => BaseApp.RouteTx MessageApi r 'BaseApp.DeliverTx +messageHandlers = updateCountH + +updateCountH :: Member SimpleStorage r => Members BaseApp.TxEffs r - => PreRoutedTx SimpleStorageMessage + => BaseApp.RoutingTx UpdateCountTx -> Sem r () -router (PreRoutedTx Tx{txMsg}) = +updateCountH (BaseApp.RoutingTx Tx{txMsg}) = let Msg{msgData} = txMsg - in case msgData of - UpdateCount UpdateCountTx{updateCountTxCount} -> - updateCount (Count updateCountTxCount) + UpdateCountTx{updateCountTxCount} = msgData + in updateCount (Count updateCountTxCount) -------------------------------------------------------------------------------- -- Server @@ -144,12 +161,12 @@ getMultipliedCount subtractor multiplier = do , queryResultHeight = 0 } -type Api = GetMultipliedCount :<|> BaseApp.QueryApi CountStoreContents +type QueryApi = GetMultipliedCount :<|> BaseApp.QueryApi CountStoreContents server :: forall r. Members [SimpleStorage, BaseApp.RawStore, Error BaseApp.AppError] r - => BaseApp.RouteT Api r + => BaseApp.RouteQ QueryApi r server = let storeHandlers = BaseApp.storeQueryHandlers (Proxy :: Proxy CountStoreContents) storeKey (Proxy :: Proxy r) @@ -160,15 +177,15 @@ server = -------------------------------------------------------------------------------- type SimpleStorageM r = - Module "simple_storage" SimpleStorageMessage () Api SimpleStorageEffs r + Module "simple_storage" MessageApi QueryApi SimpleStorageEffs r simpleStorageModule :: Member SimpleStorage r => Members BaseApp.BaseAppEffs r => SimpleStorageM r simpleStorageModule = Module - { moduleTxDeliverer = router - , moduleTxChecker = router + { moduleTxDeliverer = messageHandlers + , moduleTxChecker = BaseApp.defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r) , moduleQueryServer = server , moduleEval = eval } diff --git a/hs-abci-test-utils/package.yaml b/hs-abci-test-utils/package.yaml index 0e90e704..b3486172 100644 --- a/hs-abci-test-utils/package.yaml +++ b/hs-abci-test-utils/package.yaml @@ -31,6 +31,7 @@ default-extensions: - RecordWildCards - ScopedTypeVariables - TypeOperators + - FlexibleContexts library: source-dirs: src @@ -46,9 +47,8 @@ library: - aeson-pretty - base >= 4.7 && < 5 - bytestring - - data-default-class + - cryptonite - errors - - hspec - http-api-data - lens - mtl diff --git a/hs-abci-test-utils/src/Tendermint/Utils/Client.hs b/hs-abci-test-utils/src/Tendermint/Utils/Client.hs index 0a2b77a7..fcc871e1 100644 --- a/hs-abci-test-utils/src/Tendermint/Utils/Client.hs +++ b/hs-abci-test-utils/src/Tendermint/Utils/Client.hs @@ -1,144 +1,25 @@ -{-# LANGUAGE UndecidableInstances #-} - module Tendermint.Utils.Client - ( RunClient(..) - , HasClient(..) - , ClientResponse(..) - ) where - -import Control.Lens (to, (^.)) -import Control.Monad.Reader (ReaderT) -import qualified Data.ByteArray.Base64String as Base64 -import qualified Data.ByteArray.HexString as Hex -import Data.ByteString (ByteString) -import Data.Proxy -import Data.String.Conversions (cs) -import Data.Text (Text, intercalate) -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.ABCI.Types.Messages.FieldTypes (WrappedVal (..)) -import qualified Network.ABCI.Types.Messages.Request as Req -import qualified Network.ABCI.Types.Messages.Response as Resp -import qualified Network.Tendermint.Client as RPC -import Servant.API -import Servant.API.Modifiers -import Tendermint.SDK.BaseApp.Query.Store (StoreLeaf) -import Tendermint.SDK.BaseApp.Query.Types (Leaf, QA, - QueryArgs (..), - Queryable (..)) -import Tendermint.SDK.BaseApp.Store (RawKey (..)) -import Tendermint.SDK.Codec (HasCodec (decode)) -import Web.Internal.HttpApiData (ToHttpApiData (..)) - -class Monad m => RunClient m where - -- | How to make a request. - runQuery :: Req.Query -> m Resp.Query - -instance RunClient (ReaderT RPC.Config IO) where - runQuery Req.Query{..} = - let rpcQ = RPC.RequestABCIQuery - { RPC.requestABCIQueryPath = Just queryPath - , RPC.requestABCIQueryData = Hex.fromBytes @ByteString . Base64.toBytes $ queryData - , RPC.requestABCIQueryHeight = Just $ queryHeight - , RPC.requestABCIQueryProve = queryProve - } - in RPC.resultABCIQueryResponse <$> RPC.abciQuery rpcQ - -type QueryStringList = [(Text, Text)] - -class HasClient m layout where - - type ClientT (m :: * -> *) layout :: * - genClient :: Proxy m -> Proxy layout -> (Req.Query, QueryStringList) -> ClientT m layout - -instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where - type ClientT m (a :<|> b) = ClientT m a :<|> ClientT m b - genClient pm _ (q,qs) = genClient pm (Proxy @a) (q,qs) :<|> genClient pm (Proxy @b) (q,qs) - -instance (KnownSymbol path, HasClient m a) => HasClient m (path :> a) where - type ClientT m (path :> a) = ClientT m a - genClient pm _ (q,qs) = genClient pm (Proxy @a) - (q {Req.queryPath = Req.queryPath q <> "/" <> cs (symbolVal (Proxy @path))}, qs) - -appendToQueryString - :: Text -- ^ param name - -> Maybe Text -- ^ param value - -> QueryStringList - -> QueryStringList -appendToQueryString pname pvalue qs = - maybe qs (\v -> (pname, v) : qs) pvalue - -instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods)) - => HasClient m (QueryParam' mods sym a :> api) where + ( RunQueryClient(..) + , HasQueryClient(..) + , QueryClientResponse(..) + , EmptyQueryClient(..) + + , HasTxClient(..) + , RunTxClient(..) + , EmptyTxClient(..) + , TxClientResponse(..) + , SynchronousResponse(..) + , TxResponse(..) + , ClientConfig(..) + , defaultClientTxOpts + + , Signer(..) + , TxOpts(..) + , makeSignerFromKey - type ClientT m (QueryParam' mods sym a :> api) = RequiredArgument mods a -> ClientT m api - - -- if mparam = Nothing, we don't add it to the query string - genClient pm Proxy (q,qs) mparam = - genClient pm (Proxy :: Proxy api) $ foldRequiredArgument - (Proxy :: Proxy mods) add (maybe (q,qs) add) mparam - where - add :: a -> (Req.Query, QueryStringList) - add param = (q, appendToQueryString pname (Just $ toQueryParam param) qs) - - pname :: Text - pname = cs $ symbolVal (Proxy :: Proxy sym) - -instance (RawKey k, HasClient m a) => HasClient m (QA k :> a) where - type ClientT m (QA k :> a) = QueryArgs k -> ClientT m a - genClient pm _ (q,qs) QueryArgs{..} = genClient pm (Proxy @a) - (q { Req.queryData = queryArgsData ^. rawKey . to Base64.fromBytes - , Req.queryHeight = WrappedVal queryArgsHeight - , Req.queryProve = queryArgsProve - }, qs) - -instance (ToHttpApiData a, HasClient m api) => HasClient m (Capture' mods capture a :> api) where - - type ClientT m (Capture' mods capture a :> api) = a -> ClientT m api - - genClient pm _ (q,qs) val = - let p = toUrlPiece val - q' = q { Req.queryPath = Req.queryPath q <> "/" <> p } - in genClient pm (Proxy :: Proxy api) (q', qs) - --- | Data is Nothing iff Raw includes a non-0 response value -data ClientResponse a = ClientResponse - { clientResponseData :: Maybe a - , clientResponseRaw :: Resp.Query - } - -addQueryParamsToPath - :: QueryStringList - -> Text - -> Text -addQueryParamsToPath qs path = - let qParams = intercalate "&" $ map (\(n,v) -> n <> "=" <> v) qs - in case qs of - [] -> path - _ -> path <> "?" <> qParams - -instance (HasCodec a, RunClient m) => HasClient m (Leaf a) where - type ClientT m (Leaf a) = m (ClientResponse a) - genClient _ _ = leafGenClient - -leafGenClient - :: HasCodec a - => RunClient m - => (Req.Query, QueryStringList) - -> m (ClientResponse a) -leafGenClient (q,qs) = do - let reqPath = addQueryParamsToPath qs $ Req.queryPath q - r@Resp.Query{..} <- runQuery q { Req.queryPath = reqPath } - -- anything other than 0 code is a failure: https://tendermint.readthedocs.io/en/latest/abci-spec.html - -- and will result in queryValue decoding to a "empty/default" object - return $ case queryCode of - 0 -> case decode $ Base64.toBytes queryValue of - Left err -> error $ "Impossible parse error: " <> cs err - Right a -> ClientResponse (Just a) r - _ -> ClientResponse Nothing r + ) where -instance (RunClient m, Queryable a, name ~ Name a, KnownSymbol name ) => HasClient m (StoreLeaf a) where - type ClientT m (StoreLeaf a) = m (ClientResponse a) - genClient _ _ (q,qs) = - let leaf = symbolVal (Proxy @(Name a)) - q' = q { Req.queryPath = Req.queryPath q <> "/" <> cs leaf } - in leafGenClient (q', qs) +import Tendermint.Utils.QueryClient.Class +import Tendermint.Utils.QueryClient.Types +import Tendermint.Utils.TxClient.Class +import Tendermint.Utils.TxClient.Types diff --git a/hs-abci-test-utils/src/Tendermint/Utils/ClientUtils.hs b/hs-abci-test-utils/src/Tendermint/Utils/ClientUtils.hs new file mode 100644 index 00000000..2b053047 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/ClientUtils.hs @@ -0,0 +1,131 @@ +module Tendermint.Utils.ClientUtils where + +import Control.Monad (unless) +import Data.Aeson (ToJSON) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Either (partitionEithers) +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word32) +import Network.ABCI.Types.Messages.FieldTypes (Event (..)) +import qualified Network.Tendermint.Client as RPC +import Tendermint.SDK.BaseApp.Errors (AppError (..)) +import Tendermint.SDK.BaseApp.Events (ToEvent (..)) +import Tendermint.SDK.BaseApp.Query (QueryResult (..)) +import Tendermint.Utils.Client (QueryClientResponse (..), + SynchronousResponse (..), + TxClientResponse (..), + TxResponse (..)) +import Tendermint.Utils.Events (FromEvent (..)) + +-------------------------------------------------------------------------------- +-- | Tx helpers +-------------------------------------------------------------------------------- + +assertTx + :: Monad m + => m (TxClientResponse a b) + -> m (SynchronousResponse a b) +assertTx m = do + resp <- m + case resp of + Response r -> pure r + RPCError err -> fail $ "Expected Response, got RPCError " <> show err + ParseError ctx err -> fail $ "Expected Response, got ParseError in context " <> show ctx + <> ": " <> show err + +-- get the logged events from a deliver response, +deliverTxEvents + :: Monad m + => FromEvent e + => Proxy e + -> SynchronousResponse a b + -> m ([Text],[e]) +deliverTxEvents pE SynchronousResponse{deliverTxResponse} = + case deliverTxResponse of + TxResponse {txResponseEvents} -> + let eventName = cs $ makeEventType pE + es = filter ((== eventName) . eventType) txResponseEvents + in return . partitionEithers . map fromEvent $ es + TxError appError -> fail (show appError) + +-- check for a specific check response code +ensureCheckResponseCode + :: Monad m + => Word32 + -> SynchronousResponse a b + -> m () +ensureCheckResponseCode code SynchronousResponse{checkTxResponse} = + case checkTxResponse of + TxResponse _ _ -> + unless (code == 0) $ + fail $ "Couldn't match found checkTx response code 0 with expected code " <> show code <> "." + TxError appError -> + let errCode = appErrorCode appError + in unless (errCode == code) $ + fail $ "Couldn't match found checkTx response code " <> show errCode <> + " with expected code " <> show code <> "." + +-- check for a specific check response code +ensureDeliverResponseCode + :: Monad m + => Word32 + -> SynchronousResponse a b + -> m () +ensureDeliverResponseCode code SynchronousResponse{deliverTxResponse} = + case deliverTxResponse of + TxResponse _ _ -> + unless (code == 0) $ + fail $ "Couldn't match found deliverTx response code 0 with expected code " <> show code <> "." + TxError appError -> + let errCode = appErrorCode appError + in unless (errCode == code) $ + fail $ "Couldn't match found deliverTx response code " <> show errCode <> + " with expected code " <> show code <> "." + +ensureResponseCodes + :: Monad m + => (Word32, Word32) + -> SynchronousResponse a b + -> m () +ensureResponseCodes (checkCode, deliverCode) resp = do + ensureCheckResponseCode checkCode resp + ensureDeliverResponseCode deliverCode resp + +-------------------------------------------------------------------------------- +-- | Query helpers +-------------------------------------------------------------------------------- + +assertQuery + :: Monad m + => m (QueryClientResponse a) + -> m (QueryResult a) +assertQuery m = do + resp <- m + case resp of + QueryResponse r -> pure r + QueryError err -> fail $ show err + +ensureQueryResponseCode + :: Monad m + => Word32 + -> QueryClientResponse a + -> m () +ensureQueryResponseCode code resp = case resp of + QueryResponse _ -> + unless (code == 0) $ + fail $ "Couldn't match found query response code 0 with expected code " <> show code <> "." + QueryError AppError{appErrorCode} -> + unless (appErrorCode == code) $ + fail $ "Couldn't match found query response code " <> show appErrorCode <> + " with expected code " <> show code <> "." + +-------------------------------------------------------------------------------- + +rpcConfig :: RPC.Config +rpcConfig = + let RPC.Config baseReq _ _ = RPC.defaultConfig "localhost" 26657 + prettyPrint :: forall b. ToJSON b => String -> b -> IO () + prettyPrint prefix a = putStrLn $ prefix <> "\n" <> (cs . encodePretty $ a) + in RPC.Config baseReq (prettyPrint "RPC Request") (prettyPrint "RPC Response") diff --git a/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Class.hs b/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Class.hs new file mode 100644 index 00000000..d4687e32 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Class.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE UndecidableInstances #-} +module Tendermint.Utils.QueryClient.Class where + +import Control.Lens (to, (^.)) +import Control.Monad.Reader (ReaderT) +import qualified Data.ByteArray.Base64String as Base64 +import qualified Data.ByteArray.HexString as Hex +import Data.ByteString (ByteString) +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Text (Text, intercalate) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.ABCI.Types.Messages.FieldTypes (WrappedVal (..)) +import qualified Network.ABCI.Types.Messages.Request as Req +import qualified Network.ABCI.Types.Messages.Response as Resp +import qualified Network.Tendermint.Client as RPC +import Servant.API +import Servant.API.Modifiers +import Tendermint.SDK.BaseApp.Errors (queryAppError) +import Tendermint.SDK.BaseApp.Query.Store (StoreLeaf) +import Tendermint.SDK.BaseApp.Query.Types (Leaf, QA, + QueryArgs (..), + QueryResult (..), + Queryable (..)) +import Tendermint.SDK.BaseApp.Store (RawKey (..)) +import Tendermint.SDK.Codec (HasCodec (decode)) +import Tendermint.Utils.QueryClient.Types +import Web.Internal.HttpApiData (ToHttpApiData (..)) + +class Monad m => RunQueryClient m where + -- | How to make a request. + runQuery :: Req.Query -> m Resp.Query + +instance RunQueryClient (ReaderT RPC.Config IO) where + runQuery Req.Query{..} = + let rpcQ = RPC.RequestABCIQuery + { RPC.requestABCIQueryPath = Just queryPath + , RPC.requestABCIQueryData = Hex.fromBytes @ByteString . Base64.toBytes $ queryData + , RPC.requestABCIQueryHeight = Just $ queryHeight + , RPC.requestABCIQueryProve = queryProve + } + in RPC.resultABCIQueryResponse <$> RPC.abciQuery rpcQ + +type QueryStringList = [(Text, Text)] + +class HasQueryClient m layout where + + type ClientQ (m :: * -> *) layout :: * + genClientQ :: Proxy m -> Proxy layout -> (Req.Query, QueryStringList) -> ClientQ m layout + +instance (HasQueryClient m a, HasQueryClient m b) => HasQueryClient m (a :<|> b) where + type ClientQ m (a :<|> b) = ClientQ m a :<|> ClientQ m b + genClientQ pm _ (q,qs) = genClientQ pm (Proxy @a) (q,qs) :<|> genClientQ pm (Proxy @b) (q,qs) + +instance (KnownSymbol path, HasQueryClient m a) => HasQueryClient m (path :> a) where + type ClientQ m (path :> a) = ClientQ m a + genClientQ pm _ (q,qs) = genClientQ pm (Proxy @a) + (q {Req.queryPath = Req.queryPath q <> "/" <> cs (symbolVal (Proxy @path))}, qs) + +appendToQueryString + :: Text -- ^ param name + -> Maybe Text -- ^ param value + -> QueryStringList + -> QueryStringList +appendToQueryString pname pvalue qs = + maybe qs (\v -> (pname, v) : qs) pvalue + +instance (KnownSymbol sym, ToHttpApiData a, HasQueryClient m api, SBoolI (FoldRequired mods)) + => HasQueryClient m (QueryParam' mods sym a :> api) where + + type ClientQ m (QueryParam' mods sym a :> api) = RequiredArgument mods a -> ClientQ m api + + -- if mparam = Nothing, we don't add it to the query string + genClientQ pm Proxy (q,qs) mparam = + genClientQ pm (Proxy :: Proxy api) $ foldRequiredArgument + (Proxy :: Proxy mods) add (maybe (q,qs) add) mparam + where + add :: a -> (Req.Query, QueryStringList) + add param = (q, appendToQueryString pname (Just $ toQueryParam param) qs) + + pname :: Text + pname = cs $ symbolVal (Proxy :: Proxy sym) + +instance (RawKey k, HasQueryClient m a) => HasQueryClient m (QA k :> a) where + type ClientQ m (QA k :> a) = QueryArgs k -> ClientQ m a + genClientQ pm _ (q,qs) QueryArgs{..} = genClientQ pm (Proxy @a) + (q { Req.queryData = queryArgsData ^. rawKey . to Base64.fromBytes + , Req.queryHeight = WrappedVal queryArgsHeight + , Req.queryProve = queryArgsProve + }, qs) + +instance (ToHttpApiData a, HasQueryClient m api) => HasQueryClient m (Capture' mods capture a :> api) where + + type ClientQ m (Capture' mods capture a :> api) = a -> ClientQ m api + + genClientQ pm _ (q,qs) val = + let p = toUrlPiece val + q' = q { Req.queryPath = Req.queryPath q <> "/" <> p } + in genClientQ pm (Proxy :: Proxy api) (q', qs) + +addQueryParamsToPath + :: QueryStringList + -> Text + -> Text +addQueryParamsToPath qs path = + let qParams = intercalate "&" $ map (\(n,v) -> n <> "=" <> v) qs + in case qs of + [] -> path + _ -> path <> "?" <> qParams + +instance (HasCodec a, RunQueryClient m) => HasQueryClient m (Leaf a) where + type ClientQ m (Leaf a) = m (QueryClientResponse a) + genClientQ _ _ = leafGenClient + +leafGenClient + :: HasCodec a + => RunQueryClient m + => (Req.Query, QueryStringList) + -> m (QueryClientResponse a) +leafGenClient (q,qs) = do + let reqPath = addQueryParamsToPath qs $ Req.queryPath q + r@Resp.Query{..} <- runQuery q { Req.queryPath = reqPath } + -- anything other than 0 code is a failure: https://tendermint.readthedocs.io/en/latest/abci-spec.html + -- and will result in queryValue decoding to a "empty/default" object + return $ case queryCode of + 0 -> case decode $ Base64.toBytes queryValue of + Left err -> error $ "Impossible parse error: " <> cs err + Right a -> QueryResponse $ QueryResult + { queryResultData = a + , queryResultIndex = unWrappedVal queryIndex + , queryResultHeight = unWrappedVal queryHeight + , queryResultProof = queryProof + , queryResultKey = queryKey + } + _ -> QueryError $ r ^. queryAppError + +instance (RunQueryClient m, Queryable a, name ~ Name a, KnownSymbol name ) => HasQueryClient m (StoreLeaf a) where + type ClientQ m (StoreLeaf a) = m (QueryClientResponse a) + genClientQ _ _ (q,qs) = + let leaf = symbolVal (Proxy @(Name a)) + q' = q { Req.queryPath = Req.queryPath q <> "/" <> cs leaf } + in leafGenClient (q', qs) + +-- | Singleton type representing a client for an empty API. +data EmptyQueryClient = EmptyQueryClient deriving (Eq, Show, Bounded, Enum) + +instance HasQueryClient m EmptyQueryClient where + type ClientQ m EmptyQueryClient = EmptyQueryClient + + genClientQ _ _ _ = EmptyQueryClient diff --git a/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Types.hs b/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Types.hs new file mode 100644 index 00000000..ff65cf63 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/QueryClient/Types.hs @@ -0,0 +1,10 @@ +module Tendermint.Utils.QueryClient.Types where + +import Tendermint.SDK.BaseApp.Errors (AppError) +import Tendermint.SDK.BaseApp.Query.Types (QueryResult) + +-- | Data is Nothing iff Raw includes a non-0 response value +data QueryClientResponse a = + QueryResponse (QueryResult a) + | QueryError AppError + deriving (Eq, Show) diff --git a/hs-abci-test-utils/src/Tendermint/Utils/Request.hs b/hs-abci-test-utils/src/Tendermint/Utils/Request.hs deleted file mode 100644 index b2e61461..00000000 --- a/hs-abci-test-utils/src/Tendermint/Utils/Request.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Tendermint.Utils.Request where - -import Control.Lens ((^.)) -import Data.Aeson (ToJSON) -import Data.Aeson.Encode.Pretty (encodePretty) -import qualified Data.ByteArray.Base64String as Base64 -import Data.Maybe (fromJust) -import Data.String.Conversions (cs) -import Data.Word (Word32) -import qualified Network.ABCI.Types.Messages.Response as Response -import qualified Network.Tendermint.Client as RPC -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Types.Transaction (RawTransaction (..)) -import Tendermint.Utils.Client (ClientResponse (..)) -import Test.Hspec - -runRPC :: forall a. RPC.TendermintM a -> IO a -runRPC = RPC.runTendermintM rpcConfig - where - rpcConfig :: RPC.Config - rpcConfig = - let RPC.Config baseReq _ _ = RPC.defaultConfig "localhost" 26657 - prettyPrint :: forall b. ToJSON b => String -> b -> IO () - prettyPrint prefix a = putStrLn $ prefix <> "\n" <> (cs . encodePretty $ a) - in RPC.Config baseReq (prettyPrint "RPC Request") (prettyPrint "RPC Response") - --- executes a query and ensures a 0 response code -getQueryResponseSuccess :: RPC.TendermintM (ClientResponse a) -> IO a -getQueryResponseSuccess query = do - ClientResponse{clientResponseData,clientResponseRaw} <- runRPC query - let responseCode = clientResponseRaw ^. Response._queryCode - responseCode `shouldBe` 0 - return . fromJust $ clientResponseData - --- executes a request, then returns the checkTx response -getCheckTxResponse :: RawTransaction -> IO Response.CheckTx -getCheckTxResponse rawTx = do - let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } - fmap RPC.resultBroadcastTxCommitCheckTx . runRPC $ - RPC.broadcastTxCommit txReq - --- executes a request, then returns the deliverTx response -getDeliverTxResponse :: RawTransaction -> IO Response.DeliverTx -getDeliverTxResponse rawTx = do - let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } - fmap RPC.resultBroadcastTxCommitDeliverTx . runRPC $ - RPC.broadcastTxCommit txReq - --- executes a request, check deliver and response codes -ensureCheckAndDeliverResponseCodes :: (Word32, Word32) -> RawTransaction -> IO () -ensureCheckAndDeliverResponseCodes codes rawTx = do - let txReq = RPC.RequestBroadcastTxCommit { RPC.requestBroadcastTxCommitTx = encodeRawTx rawTx } - resp <- runRPC $ RPC.broadcastTxCommit txReq - let checkResp = RPC.resultBroadcastTxCommitCheckTx resp - deliverResp = RPC.resultBroadcastTxCommitDeliverTx resp - codes `shouldBe` (checkResp ^. Response._checkTxCode, deliverResp ^. Response._deliverTxCode) - -encodeRawTx :: RawTransaction -> Base64.Base64String -encodeRawTx = Base64.fromBytes . encode diff --git a/hs-abci-test-utils/src/Tendermint/Utils/Response.hs b/hs-abci-test-utils/src/Tendermint/Utils/Response.hs deleted file mode 100644 index 21aad542..00000000 --- a/hs-abci-test-utils/src/Tendermint/Utils/Response.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Tendermint.Utils.Response where - -import Control.Lens ((^.)) -import Data.Either (partitionEithers) -import Data.Text (Text) -import Data.Word (Word32) -import Network.ABCI.Types.Messages.FieldTypes (Event (..)) -import qualified Network.ABCI.Types.Messages.Response as Response -import Tendermint.Utils.Events (FromEvent (..)) -import Test.Hspec - --- get the logged events from a deliver response, -deliverTxEvents :: FromEvent e => Response.DeliverTx -> Text -> IO ([Text],[e]) -deliverTxEvents deliverResp eventName = do - let deliverEvents = deliverResp ^. Response._deliverTxEvents - filtered = filter ((== eventName) . eventType) deliverEvents - return . partitionEithers . map fromEvent $ filtered - --- ensures there are no errors when parsing event logs and contains the expectedEvent -ensureEventLogged :: (Eq e, Show e, FromEvent e) => Response.DeliverTx -> Text -> e -> IO () -ensureEventLogged deliverResp eventName expectedEvent = do - (errs, events) <- deliverTxEvents deliverResp eventName - errs `shouldBe` mempty - events `shouldSatisfy` elem expectedEvent - --- check for a specific check response code -ensureCheckResponseCode :: Response.CheckTx -> Word32 -> IO () -ensureCheckResponseCode checkResp code = do - let checkRespCode = checkResp ^. Response._checkTxCode - checkRespCode `shouldBe` code - --- check for a specific deliver response code -ensureDeliverResponseCode :: Response.DeliverTx -> Word32 -> IO () -ensureDeliverResponseCode deliverResp code = do - let deliverRespCode = deliverResp ^. Response._deliverTxCode - deliverRespCode `shouldBe` code diff --git a/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Class.hs b/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Class.hs new file mode 100644 index 00000000..55054eb5 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Class.hs @@ -0,0 +1,113 @@ +{-# 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 + -- | How to make a request. + 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 + + +-- | Singleton type representing a client for an empty API. +data EmptyTxClient = EmptyTxClient deriving (Eq, Show, Bounded, Enum) + +instance HasTxClient m T.EmptyTxServer where + type ClientT m T.EmptyTxServer = EmptyTxClient + + genClientT _ _ _ = EmptyTxClient diff --git a/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Types.hs b/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Types.hs new file mode 100644 index 00000000..24d67ec6 --- /dev/null +++ b/hs-abci-test-utils/src/Tendermint/Utils/TxClient/Types.hs @@ -0,0 +1,97 @@ +module Tendermint.Utils.TxClient.Types where + +import Control.Lens ((^.)) +import Crypto.Hash (Digest) +import Crypto.Hash.Algorithms (SHA256) +import Data.Bifunctor (first) +import qualified Data.ByteArray.Base64String as Base64 +import Data.Int (Int64) +import Data.Proxy +import Data.Text (Text) +import Network.ABCI.Types.Messages.FieldTypes (Event) +import qualified Network.ABCI.Types.Messages.Response as Response +import qualified Network.Tendermint.Client as RPC +import Tendermint.SDK.BaseApp.Errors (AppError, + txResultAppError) +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.Crypto (RecoverableSignatureSchema (..), + SignatureSchema (..)) +import Tendermint.SDK.Types.Address (Address) +import Tendermint.SDK.Types.Transaction (RawTransaction (..), + signRawTransaction) +import Tendermint.SDK.Types.TxResult (checkTxTxResult, + deliverTxTxResult) + +data TxOpts = TxOpts + { txOptsGas :: Int64 + , txOptsSigner :: Signer + } + +data Signer = Signer + { signerAddress :: Address + , signerSign :: RawTransaction -> RawTransaction + } + +makeSignerFromKey + :: RecoverableSignatureSchema alg + => Message alg ~ Digest SHA256 + => Proxy alg + -> PrivateKey alg + -> Signer +makeSignerFromKey pa privKey = Signer (addressFromPubKey pa . derivePubKey pa $ privKey) $ \r -> + let sig = serializeRecoverableSignature pa $ + signRawTransaction pa privKey $ r {rawTransactionSignature = ""} + in r {rawTransactionSignature = sig} + +data TxResponse a = + TxResponse + { txResponseResult :: a + , txResponseEvents :: [Event] + } + | TxError AppError + deriving (Eq, Show) + +data SynchronousResponse c d = SynchronousResponse + { checkTxResponse :: TxResponse c + , deliverTxResponse :: TxResponse d + } deriving (Eq, Show) + +data TxClientResponse c d = + RPCError Text + | ParseError T.RouteContext Text + | Response (SynchronousResponse c d) + deriving (Eq, Show) + +parseRPCResponse + :: HasCodec a + => HasCodec (T.OnCheckReturn 'T.CheckTx oc a) + => Proxy a + -> Proxy (oc :: T.OnCheck) + -> RPC.ResultBroadcastTxCommit + -> TxClientResponse (T.OnCheckReturn 'T.CheckTx oc a) a +parseRPCResponse _ _ RPC.ResultBroadcastTxCommit{..} = + let + makeCheckResp r@Response.CheckTx{..} = case checkTxCode of + 0 -> do + resp <- decode $ Base64.toBytes checkTxData + pure $ TxResponse resp $ checkTxEvents + _ -> Right . TxError $ r ^. checkTxTxResult . txResultAppError + + makeDeliverResp r@Response.DeliverTx{..} = case deliverTxCode of + 0 -> do + resp <- decode $ Base64.toBytes deliverTxData + pure $ TxResponse resp $ deliverTxEvents + _ -> Right . TxError $ r ^. deliverTxTxResult . txResultAppError + + eResponses = do + checkResp <- first (ParseError T.CheckTx) $ + makeCheckResp resultBroadcastTxCommitCheckTx + deliverResp <- first (ParseError T.DeliverTx) $ + makeDeliverResp resultBroadcastTxCommitDeliverTx + pure (checkResp, deliverResp) + + in case eResponses of + Left e -> e + Right (check, deliver) -> Response $ SynchronousResponse check deliver diff --git a/hs-abci-test-utils/src/Tendermint/Utils/User.hs b/hs-abci-test-utils/src/Tendermint/Utils/User.hs index 43578759..89f178b9 100644 --- a/hs-abci-test-utils/src/Tendermint/Utils/User.hs +++ b/hs-abci-test-utils/src/Tendermint/Utils/User.hs @@ -1,32 +1,13 @@ module Tendermint.Utils.User where -import Crypto.Secp256k1 (CompactRecSig (..), SecKey, - derivePubKey, - exportCompactRecSig, secKey) -import qualified Data.ByteArray.HexString as Hex -import Data.ByteString (ByteString, snoc) -import qualified Data.ByteString as BS -import Data.ByteString.Short (fromShort) -import Data.Default.Class (def) -import Data.Maybe (fromJust) +import Crypto.Secp256k1 (SecKey, derivePubKey, secKey) +import qualified Data.ByteArray.HexString as Hex +import Data.Maybe (fromJust) import Data.Proxy -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Word (Word64) -import qualified Network.Tendermint.Client as RPC -import Servant.API ((:>)) -import Tendermint.SDK.BaseApp.Query (QueryArgs (..), - defaultQueryWithData) -import Tendermint.SDK.Codec (HasCodec (..)) -import Tendermint.SDK.Crypto (Secp256k1, addressFromPubKey) -import Tendermint.SDK.Modules.Auth (Account (..)) -import qualified Tendermint.SDK.Modules.Auth as Auth -import Tendermint.SDK.Types.Address (Address (..)) -import Tendermint.SDK.Types.Transaction (RawTransaction (..), - signRawTransaction) -import Tendermint.Utils.Client (ClientResponse (..), - HasClient (..)) -import Tendermint.Utils.Request (runRPC) +import Data.String (fromString) +import Tendermint.SDK.Crypto (Secp256k1, addressFromPubKey) +import Tendermint.SDK.Types.Address (Address (..)) +import Tendermint.Utils.TxClient.Types (Signer, makeSignerFromKey) data User = User { userPrivKey :: SecKey @@ -40,36 +21,8 @@ makeUser privKeyStr = address = addressFromPubKey (Proxy @Secp256k1) pubKey in User privateKey address -algProxy :: Proxy Secp256k1 -algProxy = Proxy - -getAccount :: QueryArgs Address -> RPC.TendermintM (ClientResponse Account) -getAccount = - let apiP = Proxy :: Proxy ("auth" :> Auth.Api) - in genClient (Proxy :: Proxy RPC.TendermintM) apiP def - -getAccountNonce :: Address -> IO Word64 -getAccountNonce userAddress = do - let query = getAccount $ defaultQueryWithData userAddress - ClientResponse{clientResponseData} <- runRPC query - case clientResponseData of - -- unitialized account = 0 nonce - Nothing -> return 0 - Just Account {accountNonce} -> return accountNonce - --- sign a trx with a user's private key and add the user's account nonce -mkSignedRawTransactionWithRoute :: HasCodec a => BS.ByteString -> User -> a -> IO RawTransaction -mkSignedRawTransactionWithRoute route User{userAddress, userPrivKey} msg = do - nonce <- getAccountNonce userAddress - let unsigned = RawTransaction { rawTransactionData = encode msg - , rawTransactionRoute = cs route - , rawTransactionSignature = "" - , rawTransactionGas = 0 - , rawTransactionNonce = nonce - } - sig = signRawTransaction algProxy userPrivKey unsigned - sign rt = rt { rawTransactionSignature = encodeCompactRecSig $ exportCompactRecSig sig } - return . sign $ unsigned - -encodeCompactRecSig :: CompactRecSig -> ByteString -encodeCompactRecSig (CompactRecSig r s v) = snoc (fromShort r <> fromShort s) v +makeSignerFromUser + :: User + -> Signer +makeSignerFromUser User{userPrivKey} = + makeSignerFromKey (Proxy @Secp256k1) userPrivKey