module Network.ABCI.Server.App
  ( App(..)
  , runApp
  , transformApp
  , withProto
  , Middleware
  , MessageType(..)
  , demoteRequestType
  , msgTypeKey
  , Request(..)
  , hashRequest
  , Response(..)
  , LPByteStrings(..)
  , decodeLengthPrefix
  , encodeLengthPrefix
  ) where

import           Control.Lens                         ((?~), (^.))
import           Control.Lens.Wrapped                 (Wrapped (..),
                                                       _Unwrapped')
import           Control.Monad                        ((>=>))
import           Data.Aeson                           (FromJSON (..),
                                                       ToJSON (..), Value (..),
                                                       object, withObject, (.:),
                                                       (.=))
import           Data.Aeson.Types                     (Parser)
import           Data.Bifunctor                       (first)
import qualified Data.ByteString                      as BS
import           Data.Function                        ((&))
import           Data.Kind                            (Type)
import qualified Data.ProtoLens                       as PL
import           Data.ProtoLens.Encoding.Bytes        (getVarInt, putVarInt,
                                                       runBuilder, runParser,
                                                       signedInt64ToWord,
                                                       wordToSignedInt64)
import           Data.String.Conversions              (cs)
import           Data.Text                            (Text)
import           Network.ABCI.Server.App.DecodeError  (DecodeError)
import qualified Network.ABCI.Server.App.DecodeError  as DecodeError
import qualified Network.ABCI.Types.Messages.Request  as Request
import qualified Network.ABCI.Types.Messages.Response as Response

import           Crypto.Hash                          (hashWith)
import           Crypto.Hash.Algorithms               (SHA256 (..))
import           Data.ByteArray                       (convert)
import qualified Data.ByteArray.HexString             as Hex
import           Data.Default.Class                   (Default (..))
import           Data.ProtoLens.Message               (Message (defMessage))
import           Data.ProtoLens.Prism                 (( # ))
import qualified Proto.Types                          as PT
import qualified Proto.Types_Fields                   as PT

-- | Used to parametrize Request and Response types
data MessageType
  = MTEcho
  | MTFlush
  | MTInfo
  | MTSetOption
  | MTInitChain
  | MTQuery
  | MTBeginBlock
  | MTCheckTx
  | MTDeliverTx
  | MTEndBlock
  | MTCommit
  deriving (MessageType -> MessageType -> Bool
(MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool) -> Eq MessageType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageType -> MessageType -> Bool
$c/= :: MessageType -> MessageType -> Bool
== :: MessageType -> MessageType -> Bool
$c== :: MessageType -> MessageType -> Bool
Eq, Eq MessageType
Eq MessageType =>
(MessageType -> MessageType -> Ordering)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> MessageType)
-> (MessageType -> MessageType -> MessageType)
-> Ord MessageType
MessageType -> MessageType -> Bool
MessageType -> MessageType -> Ordering
MessageType -> MessageType -> MessageType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MessageType -> MessageType -> MessageType
$cmin :: MessageType -> MessageType -> MessageType
max :: MessageType -> MessageType -> MessageType
$cmax :: MessageType -> MessageType -> MessageType
>= :: MessageType -> MessageType -> Bool
$c>= :: MessageType -> MessageType -> Bool
> :: MessageType -> MessageType -> Bool
$c> :: MessageType -> MessageType -> Bool
<= :: MessageType -> MessageType -> Bool
$c<= :: MessageType -> MessageType -> Bool
< :: MessageType -> MessageType -> Bool
$c< :: MessageType -> MessageType -> Bool
compare :: MessageType -> MessageType -> Ordering
$ccompare :: MessageType -> MessageType -> Ordering
$cp1Ord :: Eq MessageType
Ord, Int -> MessageType
MessageType -> Int
MessageType -> [MessageType]
MessageType -> MessageType
MessageType -> MessageType -> [MessageType]
MessageType -> MessageType -> MessageType -> [MessageType]
(MessageType -> MessageType)
-> (MessageType -> MessageType)
-> (Int -> MessageType)
-> (MessageType -> Int)
-> (MessageType -> [MessageType])
-> (MessageType -> MessageType -> [MessageType])
-> (MessageType -> MessageType -> [MessageType])
-> (MessageType -> MessageType -> MessageType -> [MessageType])
-> Enum MessageType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: MessageType -> MessageType -> MessageType -> [MessageType]
$cenumFromThenTo :: MessageType -> MessageType -> MessageType -> [MessageType]
enumFromTo :: MessageType -> MessageType -> [MessageType]
$cenumFromTo :: MessageType -> MessageType -> [MessageType]
enumFromThen :: MessageType -> MessageType -> [MessageType]
$cenumFromThen :: MessageType -> MessageType -> [MessageType]
enumFrom :: MessageType -> [MessageType]
$cenumFrom :: MessageType -> [MessageType]
fromEnum :: MessageType -> Int
$cfromEnum :: MessageType -> Int
toEnum :: Int -> MessageType
$ctoEnum :: Int -> MessageType
pred :: MessageType -> MessageType
$cpred :: MessageType -> MessageType
succ :: MessageType -> MessageType
$csucc :: MessageType -> MessageType
Enum)

msgTypeKey :: MessageType -> String
msgTypeKey :: MessageType -> String
msgTypeKey m :: MessageType
m = case MessageType
m of
  MTEcho       -> "echo"
  MTFlush      -> "flush"
  MTInfo       -> "info"
  MTSetOption  -> "setOption"
  MTInitChain  -> "initChain"
  MTQuery      -> "query"
  MTBeginBlock -> "beginBlock"
  MTCheckTx    -> "checkTx"
  MTDeliverTx  -> "deliverTx"
  MTEndBlock   -> "endBlock"
  MTCommit     -> "commit"

demoteRequestType :: forall (t :: MessageType). Request t -> MessageType
demoteRequestType :: Request t -> MessageType
demoteRequestType req :: Request t
req = case Request t
req of
  RequestEcho _       -> MessageType
MTEcho
  RequestInfo _       -> MessageType
MTInfo
  RequestSetOption _  -> MessageType
MTSetOption
  RequestQuery _      -> MessageType
MTQuery
  RequestCheckTx _    -> MessageType
MTCheckTx
  RequestFlush _      -> MessageType
MTFlush
  RequestInitChain _  -> MessageType
MTInitChain
  RequestBeginBlock _ -> MessageType
MTBeginBlock
  RequestDeliverTx _  -> MessageType
MTDeliverTx
  RequestEndBlock _   -> MessageType
MTEndBlock
  RequestCommit _     -> MessageType
MTCommit

reqParseJSON :: forall t inner. FromJSON inner => MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON :: MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON msgType :: MessageType
msgType ctr :: inner -> Request t
ctr = String
-> (Object -> Parser (Request t)) -> Value -> Parser (Request t)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject ("req:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
expectedType) ((Object -> Parser (Request t)) -> Value -> Parser (Request t))
-> (Object -> Parser (Request t)) -> Value -> Parser (Request t)
forall a b. (a -> b) -> a -> b
$ \v :: Object
v -> do
  String
actualType <- Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: "type"
  if String
actualType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
expectedType
    then inner -> Request t
ctr (inner -> Request t) -> Parser inner -> Parser (Request t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser inner
forall a. FromJSON a => Object -> Text -> Parser a
.: "message"
    else String -> Parser (Request t)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Request t)) -> String -> Parser (Request t)
forall a b. (a -> b) -> a -> b
$ "expected `type` to equal: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
expectedType String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ", but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
actualType
  where
    expectedType :: String
expectedType = MessageType -> String
msgTypeKey MessageType
msgType

resParseJSON :: FromJSON inner => MessageType -> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON :: MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON msgType :: MessageType
msgType ctr :: inner -> Response t
ctr = String
-> (Object -> Parser (Response t)) -> Value -> Parser (Response t)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject ("res:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
expectedType) ((Object -> Parser (Response t)) -> Value -> Parser (Response t))
-> (Object -> Parser (Response t)) -> Value -> Parser (Response t)
forall a b. (a -> b) -> a -> b
$ \v :: Object
v -> do
  String
actualType <- Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: "type"
  if String
actualType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "exception"
    then Exception -> Response t
forall (m :: MessageType). Exception -> Response m
ResponseException (Exception -> Response t)
-> Parser Exception -> Parser (Response t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Exception
forall a. FromJSON a => Object -> Text -> Parser a
.: "message"
  else if String
actualType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
expectedType
    then inner -> Response t
ctr (inner -> Response t) -> Parser inner -> Parser (Response t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser inner
forall a. FromJSON a => Object -> Text -> Parser a
.: "message"
    else String -> Parser (Response t)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Response t)) -> String -> Parser (Response t)
forall a b. (a -> b) -> a -> b
$ "expected `type` to equal: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
expectedType String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ", but got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
actualType
  where
    expectedType :: String
expectedType = MessageType -> String
msgTypeKey MessageType
msgType

reqResToJSON :: ToJSON inner => MessageType -> inner -> Value
reqResToJSON :: MessageType -> inner -> Value
reqResToJSON msgType :: MessageType
msgType message :: inner
message = Text -> inner -> Value
forall inner. ToJSON inner => Text -> inner -> Value
reqResToJSON' (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ MessageType -> String
msgTypeKey MessageType
msgType) inner
message

reqResToJSON' :: ToJSON inner => Text -> inner -> Value
reqResToJSON' :: Text -> inner -> Value
reqResToJSON' msgType :: Text
msgType message :: inner
message = [Pair] -> Value
object
  [ "type" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text -> Value
String Text
msgType, "message" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= inner -> Value
forall a. ToJSON a => a -> Value
toJSON inner
message]

--------------------------------------------------------------------------------
-- Request
--------------------------------------------------------------------------------

-- Note: that there are 3 type of connection made by tendermint to the ABCI application:
-- * Info/Query Connection, sends only: Echo, Info and SetOption requests
-- * Mempool Connection, sends only: CheckTx and Flush requests
-- * Consensus Connection, InitChain,: BeginBlock, DeliverTx, EndBlock and  Commit requests
-- https://github.com/tendermint/tendermint/blob/v0.32.2/proxy/app_conn.go#L11-L41
data Request (m :: MessageType) :: Type where
  -- Info/Query Connection
  RequestEcho :: Request.Echo -> Request 'MTEcho
  RequestInfo :: Request.Info -> Request 'MTInfo
  RequestSetOption :: Request.SetOption -> Request 'MTSetOption
  RequestQuery :: Request.Query -> Request 'MTQuery
  -- Mempool Connection
  RequestCheckTx :: Request.CheckTx -> Request 'MTCheckTx
  RequestFlush :: Request.Flush -> Request 'MTFlush
  -- Consensus Connection
  RequestInitChain :: Request.InitChain -> Request 'MTInitChain
  RequestBeginBlock :: Request.BeginBlock -> Request 'MTBeginBlock
  RequestDeliverTx :: Request.DeliverTx -> Request 'MTDeliverTx
  RequestEndBlock :: Request.EndBlock -> Request 'MTEndBlock
  RequestCommit :: Request.Commit -> Request 'MTCommit

instance ToJSON (Request (t :: MessageType)) where
  toJSON :: Request t -> Value
toJSON (RequestEcho v :: Echo
v)       = MessageType -> Echo -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTEcho Echo
v
  toJSON (RequestInfo v :: Info
v)       = MessageType -> Info -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTInfo Info
v
  toJSON (RequestSetOption v :: SetOption
v)  = MessageType -> SetOption -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTSetOption SetOption
v
  toJSON (RequestQuery v :: Query
v)      = MessageType -> Query -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTQuery Query
v
  toJSON (RequestCheckTx v :: CheckTx
v)    = MessageType -> CheckTx -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTCheckTx CheckTx
v
  toJSON (RequestFlush v :: Flush
v)      = MessageType -> Flush -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTFlush Flush
v
  toJSON (RequestInitChain v :: InitChain
v)  = MessageType -> InitChain -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTInitChain InitChain
v
  toJSON (RequestBeginBlock v :: BeginBlock
v) = MessageType -> BeginBlock -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTBeginBlock BeginBlock
v
  toJSON (RequestDeliverTx v :: DeliverTx
v)  = MessageType -> DeliverTx -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTDeliverTx DeliverTx
v
  toJSON (RequestEndBlock v :: EndBlock
v)   = MessageType -> EndBlock -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTEndBlock EndBlock
v
  toJSON (RequestCommit v :: Commit
v)     = MessageType -> Commit -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTCommit Commit
v


instance FromJSON (Request 'MTEcho) where parseJSON :: Value -> Parser (Request 'MTEcho)
parseJSON = MessageType
-> (Echo -> Request 'MTEcho) -> Value -> Parser (Request 'MTEcho)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTEcho Echo -> Request 'MTEcho
RequestEcho
instance FromJSON (Request 'MTInfo) where parseJSON :: Value -> Parser (Request 'MTInfo)
parseJSON = MessageType
-> (Info -> Request 'MTInfo) -> Value -> Parser (Request 'MTInfo)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTInfo Info -> Request 'MTInfo
RequestInfo
instance FromJSON (Request 'MTSetOption) where parseJSON :: Value -> Parser (Request 'MTSetOption)
parseJSON = MessageType
-> (SetOption -> Request 'MTSetOption)
-> Value
-> Parser (Request 'MTSetOption)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTSetOption SetOption -> Request 'MTSetOption
RequestSetOption
instance FromJSON (Request 'MTQuery) where parseJSON :: Value -> Parser (Request 'MTQuery)
parseJSON = MessageType
-> (Query -> Request 'MTQuery)
-> Value
-> Parser (Request 'MTQuery)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTQuery Query -> Request 'MTQuery
RequestQuery
instance FromJSON (Request 'MTCheckTx) where parseJSON :: Value -> Parser (Request 'MTCheckTx)
parseJSON = MessageType
-> (CheckTx -> Request 'MTCheckTx)
-> Value
-> Parser (Request 'MTCheckTx)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTCheckTx CheckTx -> Request 'MTCheckTx
RequestCheckTx
instance FromJSON (Request 'MTFlush) where parseJSON :: Value -> Parser (Request 'MTFlush)
parseJSON = MessageType
-> (Flush -> Request 'MTFlush)
-> Value
-> Parser (Request 'MTFlush)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTFlush Flush -> Request 'MTFlush
RequestFlush
instance FromJSON (Request 'MTInitChain) where parseJSON :: Value -> Parser (Request 'MTInitChain)
parseJSON = MessageType
-> (InitChain -> Request 'MTInitChain)
-> Value
-> Parser (Request 'MTInitChain)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTInitChain InitChain -> Request 'MTInitChain
RequestInitChain
instance FromJSON (Request 'MTBeginBlock) where parseJSON :: Value -> Parser (Request 'MTBeginBlock)
parseJSON = MessageType
-> (BeginBlock -> Request 'MTBeginBlock)
-> Value
-> Parser (Request 'MTBeginBlock)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTBeginBlock BeginBlock -> Request 'MTBeginBlock
RequestBeginBlock
instance FromJSON (Request 'MTDeliverTx) where parseJSON :: Value -> Parser (Request 'MTDeliverTx)
parseJSON = MessageType
-> (DeliverTx -> Request 'MTDeliverTx)
-> Value
-> Parser (Request 'MTDeliverTx)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTDeliverTx DeliverTx -> Request 'MTDeliverTx
RequestDeliverTx
instance FromJSON (Request 'MTEndBlock) where parseJSON :: Value -> Parser (Request 'MTEndBlock)
parseJSON = MessageType
-> (EndBlock -> Request 'MTEndBlock)
-> Value
-> Parser (Request 'MTEndBlock)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTEndBlock EndBlock -> Request 'MTEndBlock
RequestEndBlock
instance FromJSON (Request 'MTCommit) where parseJSON :: Value -> Parser (Request 'MTCommit)
parseJSON = MessageType
-> (Commit -> Request 'MTCommit)
-> Value
-> Parser (Request 'MTCommit)
forall (t :: MessageType) inner.
FromJSON inner =>
MessageType -> (inner -> Request t) -> Value -> Parser (Request t)
reqParseJSON MessageType
MTCommit Commit -> Request 'MTCommit
RequestCommit

hashRequest
  :: forall (t :: MessageType).
     Request t
  -> Hex.HexString
hashRequest :: Request t -> HexString
hashRequest req :: Request t
req =
  let ByteString
requestBytes :: BS.ByteString = case Request t
req of
        RequestEcho v :: Echo
v       -> RequestEcho -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestEcho -> ByteString) -> RequestEcho -> ByteString
forall a b. (a -> b) -> a -> b
$ Echo
v Echo -> Getting RequestEcho Echo RequestEcho -> RequestEcho
forall s a. s -> Getting a s a -> a
^. Getting RequestEcho Echo RequestEcho
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestFlush v :: Flush
v      -> RequestFlush -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestFlush -> ByteString) -> RequestFlush -> ByteString
forall a b. (a -> b) -> a -> b
$ Flush
v Flush -> Getting RequestFlush Flush RequestFlush -> RequestFlush
forall s a. s -> Getting a s a -> a
^. Getting RequestFlush Flush RequestFlush
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestInfo v :: Info
v       -> RequestInfo -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestInfo -> ByteString) -> RequestInfo -> ByteString
forall a b. (a -> b) -> a -> b
$ Info
v Info -> Getting RequestInfo Info RequestInfo -> RequestInfo
forall s a. s -> Getting a s a -> a
^. Getting RequestInfo Info RequestInfo
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestSetOption v :: SetOption
v  -> RequestSetOption -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestSetOption -> ByteString) -> RequestSetOption -> ByteString
forall a b. (a -> b) -> a -> b
$ SetOption
v SetOption
-> Getting RequestSetOption SetOption RequestSetOption
-> RequestSetOption
forall s a. s -> Getting a s a -> a
^. Getting RequestSetOption SetOption RequestSetOption
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestInitChain v :: InitChain
v  -> RequestInitChain -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestInitChain -> ByteString) -> RequestInitChain -> ByteString
forall a b. (a -> b) -> a -> b
$ InitChain
v InitChain
-> Getting RequestInitChain InitChain RequestInitChain
-> RequestInitChain
forall s a. s -> Getting a s a -> a
^. Getting RequestInitChain InitChain RequestInitChain
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestQuery v :: Query
v      -> RequestQuery -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestQuery -> ByteString) -> RequestQuery -> ByteString
forall a b. (a -> b) -> a -> b
$ Query
v Query -> Getting RequestQuery Query RequestQuery -> RequestQuery
forall s a. s -> Getting a s a -> a
^. Getting RequestQuery Query RequestQuery
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestBeginBlock v :: BeginBlock
v -> RequestBeginBlock -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestBeginBlock -> ByteString)
-> RequestBeginBlock -> ByteString
forall a b. (a -> b) -> a -> b
$ BeginBlock
v BeginBlock
-> Getting RequestBeginBlock BeginBlock RequestBeginBlock
-> RequestBeginBlock
forall s a. s -> Getting a s a -> a
^. Getting RequestBeginBlock BeginBlock RequestBeginBlock
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestCheckTx v :: CheckTx
v    -> RequestCheckTx -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestCheckTx -> ByteString) -> RequestCheckTx -> ByteString
forall a b. (a -> b) -> a -> b
$ CheckTx
v CheckTx
-> Getting RequestCheckTx CheckTx RequestCheckTx -> RequestCheckTx
forall s a. s -> Getting a s a -> a
^. Getting RequestCheckTx CheckTx RequestCheckTx
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestDeliverTx v :: DeliverTx
v  -> RequestDeliverTx -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestDeliverTx -> ByteString) -> RequestDeliverTx -> ByteString
forall a b. (a -> b) -> a -> b
$ DeliverTx
v DeliverTx
-> Getting RequestDeliverTx DeliverTx RequestDeliverTx
-> RequestDeliverTx
forall s a. s -> Getting a s a -> a
^. Getting RequestDeliverTx DeliverTx RequestDeliverTx
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestEndBlock v :: EndBlock
v   -> RequestEndBlock -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestEndBlock -> ByteString) -> RequestEndBlock -> ByteString
forall a b. (a -> b) -> a -> b
$ EndBlock
v EndBlock
-> Getting RequestEndBlock EndBlock RequestEndBlock
-> RequestEndBlock
forall s a. s -> Getting a s a -> a
^. Getting RequestEndBlock EndBlock RequestEndBlock
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
        RequestCommit v :: Commit
v     -> RequestCommit -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage (RequestCommit -> ByteString) -> RequestCommit -> ByteString
forall a b. (a -> b) -> a -> b
$ Commit
v Commit
-> Getting RequestCommit Commit RequestCommit -> RequestCommit
forall s a. s -> Getting a s a -> a
^. Getting RequestCommit Commit RequestCommit
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped'
  in ByteArrayAccess ByteString => ByteString -> HexString
forall ba. ByteArrayAccess ba => ba -> HexString
Hex.fromBytes @BS.ByteString (ByteString -> HexString)
-> (Digest SHA256 -> ByteString) -> Digest SHA256 -> HexString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Digest SHA256 -> HexString) -> Digest SHA256 -> HexString
forall a b. (a -> b) -> a -> b
$ SHA256 -> ByteString -> Digest SHA256
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256 ByteString
requestBytes

withProto
  :: (forall (t :: MessageType). Request t -> a)
  -> PT.Request'Value
  -> a
withProto :: (forall (t :: MessageType). Request t -> a) -> Request'Value -> a
withProto f :: forall (t :: MessageType). Request t -> a
f value :: Request'Value
value = case Request'Value
value of
  PT.Request'Echo echo :: RequestEcho
echo -> Request 'MTEcho -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTEcho -> a) -> Request 'MTEcho -> a
forall a b. (a -> b) -> a -> b
$ Echo -> Request 'MTEcho
RequestEcho (Echo -> Request 'MTEcho) -> Echo -> Request 'MTEcho
forall a b. (a -> b) -> a -> b
$ RequestEcho
echo RequestEcho -> Getting Echo RequestEcho Echo -> Echo
forall s a. s -> Getting a s a -> a
^. Getting Echo RequestEcho Echo
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'Flush flush :: RequestFlush
flush -> Request 'MTFlush -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTFlush -> a) -> Request 'MTFlush -> a
forall a b. (a -> b) -> a -> b
$ Flush -> Request 'MTFlush
RequestFlush (Flush -> Request 'MTFlush) -> Flush -> Request 'MTFlush
forall a b. (a -> b) -> a -> b
$ RequestFlush
flush RequestFlush -> Getting Flush RequestFlush Flush -> Flush
forall s a. s -> Getting a s a -> a
^. Getting Flush RequestFlush Flush
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'Info info :: RequestInfo
info -> Request 'MTInfo -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTInfo -> a) -> Request 'MTInfo -> a
forall a b. (a -> b) -> a -> b
$ Info -> Request 'MTInfo
RequestInfo (Info -> Request 'MTInfo) -> Info -> Request 'MTInfo
forall a b. (a -> b) -> a -> b
$ RequestInfo
info RequestInfo -> Getting Info RequestInfo Info -> Info
forall s a. s -> Getting a s a -> a
^. Getting Info RequestInfo Info
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'SetOption setOption :: RequestSetOption
setOption -> Request 'MTSetOption -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTSetOption -> a) -> Request 'MTSetOption -> a
forall a b. (a -> b) -> a -> b
$ SetOption -> Request 'MTSetOption
RequestSetOption (SetOption -> Request 'MTSetOption)
-> SetOption -> Request 'MTSetOption
forall a b. (a -> b) -> a -> b
$ RequestSetOption
setOption RequestSetOption
-> Getting SetOption RequestSetOption SetOption -> SetOption
forall s a. s -> Getting a s a -> a
^. Getting SetOption RequestSetOption SetOption
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'InitChain initChain :: RequestInitChain
initChain -> Request 'MTInitChain -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTInitChain -> a) -> Request 'MTInitChain -> a
forall a b. (a -> b) -> a -> b
$ InitChain -> Request 'MTInitChain
RequestInitChain (InitChain -> Request 'MTInitChain)
-> InitChain -> Request 'MTInitChain
forall a b. (a -> b) -> a -> b
$ RequestInitChain
initChain RequestInitChain
-> Getting InitChain RequestInitChain InitChain -> InitChain
forall s a. s -> Getting a s a -> a
^. Getting InitChain RequestInitChain InitChain
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'Query query :: RequestQuery
query -> Request 'MTQuery -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTQuery -> a) -> Request 'MTQuery -> a
forall a b. (a -> b) -> a -> b
$ Query -> Request 'MTQuery
RequestQuery (Query -> Request 'MTQuery) -> Query -> Request 'MTQuery
forall a b. (a -> b) -> a -> b
$ RequestQuery
query RequestQuery -> Getting Query RequestQuery Query -> Query
forall s a. s -> Getting a s a -> a
^. Getting Query RequestQuery Query
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'BeginBlock beginBlock :: RequestBeginBlock
beginBlock -> Request 'MTBeginBlock -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTBeginBlock -> a) -> Request 'MTBeginBlock -> a
forall a b. (a -> b) -> a -> b
$ BeginBlock -> Request 'MTBeginBlock
RequestBeginBlock (BeginBlock -> Request 'MTBeginBlock)
-> BeginBlock -> Request 'MTBeginBlock
forall a b. (a -> b) -> a -> b
$ RequestBeginBlock
beginBlock RequestBeginBlock
-> Getting BeginBlock RequestBeginBlock BeginBlock -> BeginBlock
forall s a. s -> Getting a s a -> a
^. Getting BeginBlock RequestBeginBlock BeginBlock
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'CheckTx checkTx :: RequestCheckTx
checkTx -> Request 'MTCheckTx -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTCheckTx -> a) -> Request 'MTCheckTx -> a
forall a b. (a -> b) -> a -> b
$ CheckTx -> Request 'MTCheckTx
RequestCheckTx (CheckTx -> Request 'MTCheckTx) -> CheckTx -> Request 'MTCheckTx
forall a b. (a -> b) -> a -> b
$ RequestCheckTx
checkTx RequestCheckTx -> Getting CheckTx RequestCheckTx CheckTx -> CheckTx
forall s a. s -> Getting a s a -> a
^. Getting CheckTx RequestCheckTx CheckTx
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'DeliverTx deliverTx :: RequestDeliverTx
deliverTx -> Request 'MTDeliverTx -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTDeliverTx -> a) -> Request 'MTDeliverTx -> a
forall a b. (a -> b) -> a -> b
$ DeliverTx -> Request 'MTDeliverTx
RequestDeliverTx (DeliverTx -> Request 'MTDeliverTx)
-> DeliverTx -> Request 'MTDeliverTx
forall a b. (a -> b) -> a -> b
$ RequestDeliverTx
deliverTx RequestDeliverTx
-> Getting DeliverTx RequestDeliverTx DeliverTx -> DeliverTx
forall s a. s -> Getting a s a -> a
^. Getting DeliverTx RequestDeliverTx DeliverTx
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'EndBlock endBlock :: RequestEndBlock
endBlock -> Request 'MTEndBlock -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTEndBlock -> a) -> Request 'MTEndBlock -> a
forall a b. (a -> b) -> a -> b
$ EndBlock -> Request 'MTEndBlock
RequestEndBlock (EndBlock -> Request 'MTEndBlock)
-> EndBlock -> Request 'MTEndBlock
forall a b. (a -> b) -> a -> b
$ RequestEndBlock
endBlock RequestEndBlock
-> Getting EndBlock RequestEndBlock EndBlock -> EndBlock
forall s a. s -> Getting a s a -> a
^. Getting EndBlock RequestEndBlock EndBlock
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'
  PT.Request'Commit commit :: RequestCommit
commit -> Request 'MTCommit -> a
forall (t :: MessageType). Request t -> a
f (Request 'MTCommit -> a) -> Request 'MTCommit -> a
forall a b. (a -> b) -> a -> b
$ Commit -> Request 'MTCommit
RequestCommit (Commit -> Request 'MTCommit) -> Commit -> Request 'MTCommit
forall a b. (a -> b) -> a -> b
$ RequestCommit
commit RequestCommit -> Getting Commit RequestCommit Commit -> Commit
forall s a. s -> Getting a s a -> a
^. Getting Commit RequestCommit Commit
forall s. Wrapped s => Iso' (Unwrapped s) s
_Unwrapped'

--------------------------------------------------------------------------------
-- Response
--------------------------------------------------------------------------------

data Response (m :: MessageType) :: Type where
  ResponseEcho :: Response.Echo -> Response 'MTEcho
  ResponseFlush :: Response.Flush -> Response 'MTFlush
  ResponseInfo :: Response.Info -> Response 'MTInfo
  ResponseSetOption :: Response.SetOption -> Response 'MTSetOption
  ResponseInitChain :: Response.InitChain -> Response 'MTInitChain
  ResponseQuery :: Response.Query -> Response 'MTQuery
  ResponseBeginBlock :: Response.BeginBlock -> Response 'MTBeginBlock
  ResponseCheckTx :: Response.CheckTx -> Response 'MTCheckTx
  ResponseDeliverTx :: Response.DeliverTx -> Response 'MTDeliverTx
  ResponseEndBlock :: Response.EndBlock -> Response 'MTEndBlock
  ResponseCommit :: Response.Commit -> Response 'MTCommit
  ResponseException :: forall (m :: MessageType) . Response.Exception -> Response m

instance ToJSON (Response (t :: MessageType)) where
  toJSON :: Response t -> Value
toJSON (ResponseEcho v :: Echo
v)       = MessageType -> Echo -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTEcho Echo
v
  toJSON (ResponseFlush v :: Flush
v)      = MessageType -> Flush -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTFlush Flush
v
  toJSON (ResponseInfo v :: Info
v)       = MessageType -> Info -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTInfo Info
v
  toJSON (ResponseSetOption v :: SetOption
v)  = MessageType -> SetOption -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTSetOption SetOption
v
  toJSON (ResponseInitChain v :: InitChain
v)  = MessageType -> InitChain -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTInitChain InitChain
v
  toJSON (ResponseQuery v :: Query
v)      = MessageType -> Query -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTQuery Query
v
  toJSON (ResponseBeginBlock v :: BeginBlock
v) = MessageType -> BeginBlock -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTBeginBlock BeginBlock
v
  toJSON (ResponseCheckTx v :: CheckTx
v)    = MessageType -> CheckTx -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTCheckTx CheckTx
v
  toJSON (ResponseDeliverTx v :: DeliverTx
v)  = MessageType -> DeliverTx -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTDeliverTx DeliverTx
v
  toJSON (ResponseEndBlock v :: EndBlock
v)   = MessageType -> EndBlock -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTEndBlock EndBlock
v
  toJSON (ResponseCommit v :: Commit
v)     = MessageType -> Commit -> Value
forall inner. ToJSON inner => MessageType -> inner -> Value
reqResToJSON MessageType
MTCommit Commit
v
  toJSON (ResponseException v :: Exception
v)  = Text -> Exception -> Value
forall inner. ToJSON inner => Text -> inner -> Value
reqResToJSON' "exception" Exception
v

instance FromJSON (Response 'MTEcho) where parseJSON :: Value -> Parser (Response 'MTEcho)
parseJSON = MessageType
-> (Echo -> Response 'MTEcho) -> Value -> Parser (Response 'MTEcho)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTEcho Echo -> Response 'MTEcho
ResponseEcho
instance FromJSON (Response 'MTFlush) where parseJSON :: Value -> Parser (Response 'MTFlush)
parseJSON = MessageType
-> (Flush -> Response 'MTFlush)
-> Value
-> Parser (Response 'MTFlush)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTFlush Flush -> Response 'MTFlush
ResponseFlush
instance FromJSON (Response 'MTInfo) where parseJSON :: Value -> Parser (Response 'MTInfo)
parseJSON = MessageType
-> (Info -> Response 'MTInfo) -> Value -> Parser (Response 'MTInfo)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTInfo Info -> Response 'MTInfo
ResponseInfo
instance FromJSON (Response 'MTSetOption) where parseJSON :: Value -> Parser (Response 'MTSetOption)
parseJSON = MessageType
-> (SetOption -> Response 'MTSetOption)
-> Value
-> Parser (Response 'MTSetOption)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTSetOption SetOption -> Response 'MTSetOption
ResponseSetOption
instance FromJSON (Response 'MTInitChain) where parseJSON :: Value -> Parser (Response 'MTInitChain)
parseJSON = MessageType
-> (InitChain -> Response 'MTInitChain)
-> Value
-> Parser (Response 'MTInitChain)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTInitChain InitChain -> Response 'MTInitChain
ResponseInitChain
instance FromJSON (Response 'MTQuery) where parseJSON :: Value -> Parser (Response 'MTQuery)
parseJSON = MessageType
-> (Query -> Response 'MTQuery)
-> Value
-> Parser (Response 'MTQuery)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTQuery Query -> Response 'MTQuery
ResponseQuery
instance FromJSON (Response 'MTBeginBlock) where parseJSON :: Value -> Parser (Response 'MTBeginBlock)
parseJSON = MessageType
-> (BeginBlock -> Response 'MTBeginBlock)
-> Value
-> Parser (Response 'MTBeginBlock)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTBeginBlock BeginBlock -> Response 'MTBeginBlock
ResponseBeginBlock
instance FromJSON (Response 'MTCheckTx) where parseJSON :: Value -> Parser (Response 'MTCheckTx)
parseJSON = MessageType
-> (CheckTx -> Response 'MTCheckTx)
-> Value
-> Parser (Response 'MTCheckTx)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTCheckTx CheckTx -> Response 'MTCheckTx
ResponseCheckTx
instance FromJSON (Response 'MTDeliverTx) where parseJSON :: Value -> Parser (Response 'MTDeliverTx)
parseJSON = MessageType
-> (DeliverTx -> Response 'MTDeliverTx)
-> Value
-> Parser (Response 'MTDeliverTx)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTDeliverTx DeliverTx -> Response 'MTDeliverTx
ResponseDeliverTx
instance FromJSON (Response 'MTEndBlock) where parseJSON :: Value -> Parser (Response 'MTEndBlock)
parseJSON = MessageType
-> (EndBlock -> Response 'MTEndBlock)
-> Value
-> Parser (Response 'MTEndBlock)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTEndBlock EndBlock -> Response 'MTEndBlock
ResponseEndBlock
instance FromJSON (Response 'MTCommit) where parseJSON :: Value -> Parser (Response 'MTCommit)
parseJSON = MessageType
-> (Commit -> Response 'MTCommit)
-> Value
-> Parser (Response 'MTCommit)
forall inner (t :: MessageType).
FromJSON inner =>
MessageType
-> (inner -> Response t) -> Value -> Parser (Response t)
resParseJSON MessageType
MTCommit Commit -> Response 'MTCommit
ResponseCommit

instance Default (Response 'MTEcho) where def :: Response 'MTEcho
def = Echo -> Response 'MTEcho
ResponseEcho Echo
forall a. Default a => a
def
instance Default (Response 'MTFlush) where def :: Response 'MTFlush
def = Flush -> Response 'MTFlush
ResponseFlush Flush
forall a. Default a => a
def
instance Default (Response 'MTInfo) where def :: Response 'MTInfo
def = Info -> Response 'MTInfo
ResponseInfo Info
forall a. Default a => a
def
instance Default (Response 'MTSetOption) where def :: Response 'MTSetOption
def = SetOption -> Response 'MTSetOption
ResponseSetOption SetOption
forall a. Default a => a
def
instance Default (Response 'MTInitChain) where def :: Response 'MTInitChain
def = InitChain -> Response 'MTInitChain
ResponseInitChain InitChain
forall a. Default a => a
def
instance Default (Response 'MTQuery) where def :: Response 'MTQuery
def = Query -> Response 'MTQuery
ResponseQuery Query
forall a. Default a => a
def
instance Default (Response 'MTBeginBlock) where def :: Response 'MTBeginBlock
def = BeginBlock -> Response 'MTBeginBlock
ResponseBeginBlock BeginBlock
forall a. Default a => a
def
instance Default (Response 'MTCheckTx) where def :: Response 'MTCheckTx
def = CheckTx -> Response 'MTCheckTx
ResponseCheckTx CheckTx
forall a. Default a => a
def
instance Default (Response 'MTDeliverTx) where def :: Response 'MTDeliverTx
def = DeliverTx -> Response 'MTDeliverTx
ResponseDeliverTx DeliverTx
forall a. Default a => a
def
instance Default (Response 'MTEndBlock) where def :: Response 'MTEndBlock
def = EndBlock -> Response 'MTEndBlock
ResponseEndBlock EndBlock
forall a. Default a => a
def
instance Default (Response 'MTCommit) where def :: Response 'MTCommit
def = Commit -> Response 'MTCommit
ResponseCommit Commit
forall a. Default a => a
def

-- | Translates type-safe 'Response' GADT to the unsafe
--   auto-generated 'Proto.Response'
toProto :: Response t -> PT.Response
toProto :: Response t -> Response
toProto r :: Response t
r = case Response t
r of
  ResponseEcho msg :: Echo
msg       -> AReview Response'Value (Unwrapped Echo) -> Echo -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped Echo)
Prism' Response'Value ResponseEcho
PT._Response'Echo Echo
msg
  ResponseFlush msg :: Flush
msg      -> AReview Response'Value (Unwrapped Flush) -> Flush -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped Flush)
Prism' Response'Value ResponseFlush
PT._Response'Flush Flush
msg
  ResponseInfo msg :: Info
msg       -> AReview Response'Value (Unwrapped Info) -> Info -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped Info)
Prism' Response'Value ResponseInfo
PT._Response'Info Info
msg
  ResponseSetOption msg :: SetOption
msg  -> AReview Response'Value (Unwrapped SetOption)
-> SetOption -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped SetOption)
Prism' Response'Value ResponseSetOption
PT._Response'SetOption SetOption
msg
  ResponseInitChain msg :: InitChain
msg  -> AReview Response'Value (Unwrapped InitChain)
-> InitChain -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped InitChain)
Prism' Response'Value ResponseInitChain
PT._Response'InitChain InitChain
msg
  ResponseQuery msg :: Query
msg      -> AReview Response'Value (Unwrapped Query) -> Query -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped Query)
Prism' Response'Value ResponseQuery
PT._Response'Query Query
msg
  ResponseBeginBlock msg :: BeginBlock
msg -> AReview Response'Value (Unwrapped BeginBlock)
-> BeginBlock -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped BeginBlock)
Prism' Response'Value ResponseBeginBlock
PT._Response'BeginBlock BeginBlock
msg
  ResponseCheckTx msg :: CheckTx
msg    -> AReview Response'Value (Unwrapped CheckTx) -> CheckTx -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped CheckTx)
Prism' Response'Value ResponseCheckTx
PT._Response'CheckTx CheckTx
msg
  ResponseDeliverTx msg :: DeliverTx
msg  -> AReview Response'Value (Unwrapped DeliverTx)
-> DeliverTx -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped DeliverTx)
Prism' Response'Value ResponseDeliverTx
PT._Response'DeliverTx DeliverTx
msg
  ResponseEndBlock msg :: EndBlock
msg   -> AReview Response'Value (Unwrapped EndBlock) -> EndBlock -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped EndBlock)
Prism' Response'Value ResponseEndBlock
PT._Response'EndBlock EndBlock
msg
  ResponseCommit msg :: Commit
msg     -> AReview Response'Value (Unwrapped Commit) -> Commit -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped Commit)
Prism' Response'Value ResponseCommit
PT._Response'Commit Commit
msg
  ResponseException msg :: Exception
msg  -> AReview Response'Value (Unwrapped Exception)
-> Exception -> Response
forall b b s.
(Message b, HasField b "maybe'value" (Maybe b), Wrapped s) =>
AReview b (Unwrapped s) -> s -> b
wrap AReview Response'Value (Unwrapped Exception)
Prism' Response'Value ResponseException
PT._Response'Exception Exception
msg
  where
    wrap :: AReview b (Unwrapped s) -> s -> b
wrap v :: AReview b (Unwrapped s)
v msg :: s
msg = b
forall msg. Message msg => msg
defMessage b -> (b -> b) -> b
forall a b. a -> (a -> b) -> b
& LensLike' Identity b (Maybe b)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'value" a) =>
LensLike' f s a
PT.maybe'value LensLike' Identity b (Maybe b) -> b -> b -> b
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ AReview b (Unwrapped s)
v AReview b (Unwrapped s) -> Unwrapped s -> b
forall t b. AReview t b -> b -> t
# (s
msg s -> Getting (Unwrapped s) s (Unwrapped s) -> Unwrapped s
forall s a. s -> Getting a s a -> a
^. Getting (Unwrapped s) s (Unwrapped s)
forall s. Wrapped s => Iso' s (Unwrapped s)
_Wrapped')


-- | Application type that represents a well typed application, i.e. a
-- function from a typed `Request` to a typed `Response`.
newtype App m = App
  { App m -> forall (t :: MessageType). Request t -> m (Response t)
unApp :: forall (t :: MessageType). Request t -> m (Response t) }

-- | Middleware is a component that sits between the server and application.
-- It can do such tasks as logging or response caching. What follows is the general
-- definition of middleware, though a middleware author should feel free to modify this.
type Middleware m = App m -> App m

-- | Transform an application from running in a custom monad to running in `IO`.
transformApp :: (forall (t :: MessageType). m (Response t) -> g (Response t)) -> App m -> App g
transformApp :: (forall (t :: MessageType). m (Response t) -> g (Response t))
-> App m -> App g
transformApp nat :: forall (t :: MessageType). m (Response t) -> g (Response t)
nat (App f :: forall (t :: MessageType). Request t -> m (Response t)
f) = (forall (t :: MessageType). Request t -> g (Response t)) -> App g
forall (m :: * -> *).
(forall (t :: MessageType). Request t -> m (Response t)) -> App m
App ((forall (t :: MessageType). Request t -> g (Response t)) -> App g)
-> (forall (t :: MessageType). Request t -> g (Response t))
-> App g
forall a b. (a -> b) -> a -> b
$ m (Response t) -> g (Response t)
forall (t :: MessageType). m (Response t) -> g (Response t)
nat (m (Response t) -> g (Response t))
-> (Request t -> m (Response t)) -> Request t -> g (Response t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request t -> m (Response t)
forall (t :: MessageType). Request t -> m (Response t)
f

-- | Compiles `App` down to `AppBS`
runApp :: forall m. Applicative m => App m -> LPByteStrings -> m LPByteStrings
runApp :: App m -> LPByteStrings -> m LPByteStrings
runApp (App app :: forall (t :: MessageType). Request t -> m (Response t)
app) bs :: LPByteStrings
bs =
  LPByteStrings
bs
    LPByteStrings
-> (LPByteStrings -> Either DecodeError [Request'Value])
-> Either DecodeError [Request'Value]
forall a b. a -> (a -> b) -> b
& (LPByteStrings -> Either DecodeError [ByteString]
decodeLengthPrefix (LPByteStrings -> Either DecodeError [ByteString])
-> ([ByteString] -> Either DecodeError [Request'Value])
-> LPByteStrings
-> Either DecodeError [Request'Value]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [ByteString] -> Either DecodeError [Request'Value]
decodeRequests)
    Either DecodeError [Request'Value]
-> (Either DecodeError [Request'Value] -> m [Response])
-> m [Response]
forall a b. a -> (a -> b) -> b
& (DecodeError -> m [Response])
-> ([Request'Value] -> m [Response])
-> Either DecodeError [Request'Value]
-> m [Response]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Response] -> m [Response]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Response] -> m [Response])
-> (DecodeError -> [Response]) -> DecodeError -> m [Response]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeError -> [Response]
onError) ((Request'Value -> m Response) -> [Request'Value] -> m [Response]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Request'Value -> m Response
onResponse)
    m [Response]
-> (m [Response] -> m LPByteStrings) -> m LPByteStrings
forall a b. a -> (a -> b) -> b
& ([Response] -> LPByteStrings) -> m [Response] -> m LPByteStrings
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([ByteString] -> LPByteStrings
encodeLengthPrefix ([ByteString] -> LPByteStrings)
-> ([Response] -> [ByteString]) -> [Response] -> LPByteStrings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Response] -> [ByteString]
encodeResponses)
  where
    onError :: DecodeError -> [PT.Response]
    onError :: DecodeError -> [Response]
onError err :: DecodeError
err = [Response Any -> Response
forall (t :: MessageType). Response t -> Response
toProto (Response Any -> Response) -> Response Any -> Response
forall a b. (a -> b) -> a -> b
$ Exception -> Response Any
forall (m :: MessageType). Exception -> Response m
ResponseException (Exception -> Response Any) -> Exception -> Response Any
forall a b. (a -> b) -> a -> b
$ Text -> Exception
Response.Exception (Text -> Exception) -> Text -> Exception
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DecodeError -> String
DecodeError.print DecodeError
err]

    onResponse :: PT.Request'Value -> m PT.Response
    onResponse :: Request'Value -> m Response
onResponse = (forall (t :: MessageType). Request t -> m Response)
-> Request'Value -> m Response
forall a.
(forall (t :: MessageType). Request t -> a) -> Request'Value -> a
withProto ((forall (t :: MessageType). Request t -> m Response)
 -> Request'Value -> m Response)
-> (forall (t :: MessageType). Request t -> m Response)
-> Request'Value
-> m Response
forall a b. (a -> b) -> a -> b
$ (Response t -> Response) -> m (Response t) -> m Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response t -> Response
forall (t :: MessageType). Response t -> Response
toProto (m (Response t) -> m Response)
-> (Request t -> m (Response t)) -> Request t -> m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request t -> m (Response t)
forall (t :: MessageType). Request t -> m (Response t)
app

    -- | Encodes responses to bytestrings
    encodeResponses :: [PT.Response] -> [BS.ByteString]
    encodeResponses :: [Response] -> [ByteString]
encodeResponses = (Response -> ByteString) -> [Response] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Response -> ByteString
forall msg. Message msg => msg -> ByteString
PL.encodeMessage

    -- | Decodes bytestrings into requests
    decodeRequests :: [BS.ByteString] -> Either DecodeError [PT.Request'Value]
    decodeRequests :: [ByteString] -> Either DecodeError [Request'Value]
decodeRequests = (ByteString -> Either DecodeError Request'Value)
-> [ByteString] -> Either DecodeError [Request'Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ByteString -> Either DecodeError Request'Value)
 -> [ByteString] -> Either DecodeError [Request'Value])
-> (ByteString -> Either DecodeError Request'Value)
-> [ByteString]
-> Either DecodeError [Request'Value]
forall a b. (a -> b) -> a -> b
$ \packet :: ByteString
packet -> case ByteString -> Either String Request
forall msg. Message msg => ByteString -> Either String msg
PL.decodeMessage ByteString
packet of
      Left parseError :: String
parseError -> DecodeError -> Either DecodeError Request'Value
forall a b. a -> Either a b
Left (DecodeError -> Either DecodeError Request'Value)
-> DecodeError -> Either DecodeError Request'Value
forall a b. (a -> b) -> a -> b
$ ByteString -> String -> DecodeError
DecodeError.CanNotDecodeRequest ByteString
packet String
parseError
      Right (Request
request :: PT.Request) -> case Request
request Request
-> Getting (Maybe Request'Value) Request (Maybe Request'Value)
-> Maybe Request'Value
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Request'Value) Request (Maybe Request'Value)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'value" a) =>
LensLike' f s a
PT.maybe'value of
        Nothing -> DecodeError -> Either DecodeError Request'Value
forall a b. a -> Either a b
Left (DecodeError -> Either DecodeError Request'Value)
-> DecodeError -> Either DecodeError Request'Value
forall a b. (a -> b) -> a -> b
$ ByteString -> FieldSet -> DecodeError
DecodeError.NoValueInRequest ByteString
packet (Request
request Request -> Getting FieldSet Request FieldSet -> FieldSet
forall s a. s -> Getting a s a -> a
^. Getting FieldSet Request FieldSet
forall msg. Message msg => Lens' msg FieldSet
PL.unknownFields)
        Just value :: Request'Value
value -> Request'Value -> Either DecodeError Request'Value
forall a b. b -> Either a b
Right (Request'Value -> Either DecodeError Request'Value)
-> Request'Value -> Either DecodeError Request'Value
forall a b. (a -> b) -> a -> b
$ Request'Value
value


-- | ByteString which contains multiple length prefixed ByteStrings
newtype LPByteStrings = LPByteStrings { LPByteStrings -> ByteString
unLPByteStrings :: BS.ByteString } deriving (Eq LPByteStrings
Eq LPByteStrings =>
(LPByteStrings -> LPByteStrings -> Ordering)
-> (LPByteStrings -> LPByteStrings -> Bool)
-> (LPByteStrings -> LPByteStrings -> Bool)
-> (LPByteStrings -> LPByteStrings -> Bool)
-> (LPByteStrings -> LPByteStrings -> Bool)
-> (LPByteStrings -> LPByteStrings -> LPByteStrings)
-> (LPByteStrings -> LPByteStrings -> LPByteStrings)
-> Ord LPByteStrings
LPByteStrings -> LPByteStrings -> Bool
LPByteStrings -> LPByteStrings -> Ordering
LPByteStrings -> LPByteStrings -> LPByteStrings
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LPByteStrings -> LPByteStrings -> LPByteStrings
$cmin :: LPByteStrings -> LPByteStrings -> LPByteStrings
max :: LPByteStrings -> LPByteStrings -> LPByteStrings
$cmax :: LPByteStrings -> LPByteStrings -> LPByteStrings
>= :: LPByteStrings -> LPByteStrings -> Bool
$c>= :: LPByteStrings -> LPByteStrings -> Bool
> :: LPByteStrings -> LPByteStrings -> Bool
$c> :: LPByteStrings -> LPByteStrings -> Bool
<= :: LPByteStrings -> LPByteStrings -> Bool
$c<= :: LPByteStrings -> LPByteStrings -> Bool
< :: LPByteStrings -> LPByteStrings -> Bool
$c< :: LPByteStrings -> LPByteStrings -> Bool
compare :: LPByteStrings -> LPByteStrings -> Ordering
$ccompare :: LPByteStrings -> LPByteStrings -> Ordering
$cp1Ord :: Eq LPByteStrings
Ord,LPByteStrings -> LPByteStrings -> Bool
(LPByteStrings -> LPByteStrings -> Bool)
-> (LPByteStrings -> LPByteStrings -> Bool) -> Eq LPByteStrings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LPByteStrings -> LPByteStrings -> Bool
$c/= :: LPByteStrings -> LPByteStrings -> Bool
== :: LPByteStrings -> LPByteStrings -> Bool
$c== :: LPByteStrings -> LPByteStrings -> Bool
Eq)

-- | Encodes ByteStrings into varlength-prefixed ByteString
encodeLengthPrefix :: [BS.ByteString] -> LPByteStrings
encodeLengthPrefix :: [ByteString] -> LPByteStrings
encodeLengthPrefix = ByteString -> LPByteStrings
LPByteStrings (ByteString -> LPByteStrings)
-> ([ByteString] -> ByteString) -> [ByteString] -> LPByteStrings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> ByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> ByteString
encoder
  where
    encoder :: ByteString -> ByteString
encoder bytes :: ByteString
bytes =
      let
        headerN :: Word64
headerN = Int64 -> Word64
signedInt64ToWord (Int64 -> Word64) -> (ByteString -> Int64) -> ByteString -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> (ByteString -> Int) -> ByteString -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length (ByteString -> Word64) -> ByteString -> Word64
forall a b. (a -> b) -> a -> b
$ ByteString
bytes
        header :: ByteString
header = Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> Builder
putVarInt Word64
headerN
      in
        ByteString
header ByteString -> ByteString -> ByteString
`BS.append` ByteString
bytes

-- | Decodes varlength-prefixed ByteString into ByteStrings
decodeLengthPrefix :: LPByteStrings -> Either DecodeError [BS.ByteString]
decodeLengthPrefix :: LPByteStrings -> Either DecodeError [ByteString]
decodeLengthPrefix (LPByteStrings bs :: ByteString
bs)
  | ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall a. Monoid a => a
mempty = [ByteString] -> Either DecodeError [ByteString]
forall a b. b -> Either a b
Right []
  | Bool
otherwise = do
      Word64
n <- (String -> DecodeError)
-> Either String Word64 -> Either DecodeError Word64
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString -> String -> DecodeError
DecodeError.ProtoLensParseError ByteString
bs) (Either String Word64 -> Either DecodeError Word64)
-> Either String Word64 -> Either DecodeError Word64
forall a b. (a -> b) -> a -> b
$ Parser Word64 -> ByteString -> Either String Word64
forall a. Parser a -> ByteString -> Either String a
runParser Parser Word64
getVarInt ByteString
bs
      let lengthHeader :: ByteString
lengthHeader = Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> Builder
putVarInt Word64
n
      ByteString
messageBytesWithTail <- case ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
lengthHeader ByteString
bs of
        Nothing -> DecodeError -> Either DecodeError ByteString
forall a b. a -> Either a b
Left (DecodeError -> Either DecodeError ByteString)
-> DecodeError -> Either DecodeError ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> DecodeError
DecodeError.InvalidPrefix ByteString
lengthHeader ByteString
bs
        Just a :: ByteString
a  -> ByteString -> Either DecodeError ByteString
forall a b. b -> Either a b
Right ByteString
a
      let (messageBytes :: ByteString
messageBytes, remainder :: ByteString
remainder) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64 -> Int64
wordToSignedInt64 Word64
n) ByteString
messageBytesWithTail
      (ByteString
messageBytes ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ) ([ByteString] -> [ByteString])
-> Either DecodeError [ByteString]
-> Either DecodeError [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LPByteStrings -> Either DecodeError [ByteString]
decodeLengthPrefix (ByteString -> LPByteStrings
LPByteStrings ByteString
remainder)