Module router refactor (#200)

* Transaction router module

* message type field added , typed message added to protobuf

* added transaction router class

* made router class for transactions, instances

* finished transaction voodoo, wip putting it into module stuff

* empty server

* sdk compiles

* simple storage comiles

* rename PreRoutedTx

* nameservice

* all e2e tests compile

* added TypedMessage to protobuf file

* added separate query and server empty serve

* added serialize method to crypto sig

* Added tx client class and signer stuff

* last instance compiles

* client runner instance

* split out modules

* clients compiling, need to update test utils

* updated client utils

* simple storage tests compile

* fix case when account isn't present

* wip nameservice tests

* more ergonomic query result types

* nameservice tests compile

* hlint

* remove burn signature

* updated test for response code

* try to fix test

* tutorial wip

* tutorial compiles

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

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,36 +27,38 @@ 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
 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
   => Members TokenEffs r
   => 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
   }

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

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)

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