{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

#if MIN_VERSION_servant_server(0,18,0)
{-# LANGUAGE UndecidableInstances  #-}
#endif

{-# OPTIONS_GHC -fno-warn-orphans #-}

{- |
Module: Servant.Server.JsonRpc

This module provides support for writing handlers for JSON-RPC endpoints

> type Mul = JsonRpc "mul" (Int, Int) String Int
> mulHandler :: (Int, Int) -> Handler (Either (JsonRpcErr String) Int)
> mulHandler = _

> type Add = JsonRpc "add" (Int, Int) String Int
> addHandler :: (Int, Int) -> Handler (Either (JsonRpcErr String) Int)
> addHandler = _

> type API = Add :<|> Mul
> server :: Application
> server = serve (Proxy @(RawJsonRpc API)) $ addHandler :<|> mulHandler
-}
module Servant.Server.JsonRpc (
  serveJsonRpc,
  RouteJsonRpc (..),
  module Servant.JsonRpc,
  PossibleContent,
  PossibleJsonRpcResponse,
) where

import Data.Aeson (FromJSON (..), ToJSON (..), Value)
import Data.Aeson.Types (parseEither)
import Data.Bifunctor (bimap)
import Data.Kind (Type)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import Servant.API (
  NoContent (..),
  Post,
  ReqBody,
  (:<|>) (..),
  (:>),
  JSON,
 )
import Servant.API.ContentTypes (AllCTRender (..))

#if MIN_VERSION_servant_server(0,18,0)
import Servant.Server (
  DefaultErrorFormatters,
  ErrorFormatters,
  Handler,
  HasContextEntry,
  HasServer (..),
  type (.++),
 )
#elif MIN_VERSION_servant_server(0,14,0)
import Servant.Server (Handler, HasServer (..))
#endif

import Servant.JsonRpc

{- | Since we collapse an entire JSON RPC api down to a single Servant
  endpoint, we need a type that /can/ return content but might not.
-}
data PossibleContent a = SomeContent a | EmptyContent

instance (ToJSON a) => AllCTRender '[JSONRPC] (PossibleContent a) where
  handleAcceptH :: Proxy '[JSONRPC]
-> AcceptHeader
-> PossibleContent a
-> Maybe (ByteString, ByteString)
handleAcceptH Proxy '[JSONRPC]
px AcceptHeader
h = \case
    SomeContent a
x -> Proxy '[JSONRPC]
-> AcceptHeader -> a -> Maybe (ByteString, ByteString)
forall (list :: [*]) a.
AllCTRender list a =>
Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
handleAcceptH Proxy '[JSONRPC]
px AcceptHeader
h a
x
    PossibleContent a
EmptyContent -> Proxy '[JSONRPC]
-> AcceptHeader -> NoContent -> Maybe (ByteString, ByteString)
forall (list :: [*]) a.
AllCTRender list a =>
Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
handleAcceptH Proxy '[JSONRPC]
px AcceptHeader
h NoContent
NoContent

type PossibleJsonRpcResponse = PossibleContent (JsonRpcResponse Value Value)

instance ToJSON a => ToJSON (PossibleContent a) where
    toJSON :: PossibleContent a -> Value
toJSON = \case
        SomeContent a
x -> a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x
        PossibleContent a
EmptyContent -> () -> Value
forall a. ToJSON a => a -> Value
toJSON ()

type RawJsonRpcEndpoint =
  ReqBody '[JSONRPC, JSON] (Request Value)
    :> Post '[JSONRPC, JSON] PossibleJsonRpcResponse

#if MIN_VERSION_servant_server(0,18,0)
instance
  (RouteJsonRpc api, HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters) =>
  HasServer (RawJsonRpc ctype api) context
  where
#elif MIN_VERSION_servant_server(0,14,0)
  instance (RouteJsonRpc api) => HasServer (RawJsonRpc ctype api) context where
#endif
  type ServerT (RawJsonRpc ctype api) m = RpcHandler api m
  route :: forall env.
Proxy (RawJsonRpc ctype api)
-> Context context
-> Delayed env (Server (RawJsonRpc ctype api))
-> Router env
route Proxy (RawJsonRpc ctype api)
_ Context context
cx = Proxy RawJsonRpcEndpoint
-> Context context
-> Delayed env (Server RawJsonRpcEndpoint)
-> Router env
forall env.
Proxy RawJsonRpcEndpoint
-> Context context
-> Delayed env (Server RawJsonRpcEndpoint)
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Proxy RawJsonRpcEndpoint
endpoint Context context
cx (Delayed env (Request Value -> Handler PossibleJsonRpcResponse)
 -> Router env)
-> (Delayed env (RpcHandler api Handler)
    -> Delayed env (Request Value -> Handler PossibleJsonRpcResponse))
-> Delayed env (RpcHandler api Handler)
-> Router env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RpcHandler api Handler
 -> Request Value -> Handler PossibleJsonRpcResponse)
-> Delayed env (RpcHandler api Handler)
-> Delayed env (Request Value -> Handler PossibleJsonRpcResponse)
forall a b. (a -> b) -> Delayed env a -> Delayed env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proxy api
-> Proxy Handler
-> RpcHandler api Handler
-> Request Value
-> Handler PossibleJsonRpcResponse
forall (m :: * -> *) a.
(Monad m, RouteJsonRpc a) =>
Proxy a
-> Proxy m
-> RpcHandler a m
-> Request Value
-> m PossibleJsonRpcResponse
serveJsonRpc Proxy api
pxa Proxy Handler
pxh)
   where
    endpoint :: Proxy RawJsonRpcEndpoint
endpoint = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @RawJsonRpcEndpoint
    pxa :: Proxy api
pxa = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api
    pxh :: Proxy Handler
pxh = forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @Handler

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (RawJsonRpc ctype api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (RawJsonRpc ctype api) m
-> ServerT (RawJsonRpc ctype api) n
hoistServerWithContext Proxy (RawJsonRpc ctype api)
_ Proxy context
_ forall x. m x -> n x
f ServerT (RawJsonRpc ctype api) m
x = Proxy api
-> (forall x. m x -> n x) -> RpcHandler api m -> RpcHandler api n
forall a (m :: * -> *) (n :: * -> *).
RouteJsonRpc a =>
Proxy a
-> (forall x. m x -> n x) -> RpcHandler a m -> RpcHandler a n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> (forall x. m x -> n x) -> RpcHandler api m -> RpcHandler api n
hoistRpcRouter (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) m x -> n x
forall x. m x -> n x
f ServerT (RawJsonRpc ctype api) m
RpcHandler api m
x

-- | This internal class is how we accumulate a map of handlers for dispatch
class RouteJsonRpc a where
  type RpcHandler a (m :: Type -> Type)
  jsonRpcRouter ::
    (Monad m) =>
    Proxy a ->
    Proxy m ->
    RpcHandler a m ->
    Map String (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
  hoistRpcRouter :: Proxy a -> (forall x. m x -> n x) -> RpcHandler a m -> RpcHandler a n

generalizeResponse ::
  (ToJSON e, ToJSON r) =>
  Either (JsonRpcErr e) r ->
  Either (JsonRpcErr Value) Value
generalizeResponse :: forall e r.
(ToJSON e, ToJSON r) =>
Either (JsonRpcErr e) r -> Either (JsonRpcErr Value) Value
generalizeResponse = (JsonRpcErr e -> JsonRpcErr Value)
-> (r -> Value)
-> Either (JsonRpcErr e) r
-> Either (JsonRpcErr Value) Value
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap JsonRpcErr e -> JsonRpcErr Value
forall {a}. ToJSON a => JsonRpcErr a -> JsonRpcErr Value
repack r -> Value
forall a. ToJSON a => a -> Value
toJSON
 where
  repack :: JsonRpcErr a -> JsonRpcErr Value
repack JsonRpcErr a
e = JsonRpcErr a
e{errorData = toJSON <$> errorData e}

onDecodeFail :: String -> JsonRpcErr e
onDecodeFail :: forall e. String -> JsonRpcErr e
onDecodeFail String
msg = Int -> String -> Maybe e -> JsonRpcErr e
forall e. Int -> String -> Maybe e -> JsonRpcErr e
JsonRpcErr Int
invalidParamsCode String
msg Maybe e
forall a. Maybe a
Nothing

instance (KnownSymbol method, FromJSON p, ToJSON e, ToJSON r) => RouteJsonRpc (JsonRpc method p e r) where
  type RpcHandler (JsonRpc method p e r) m = p -> m (Either (JsonRpcErr e) r)

  jsonRpcRouter :: forall (m :: * -> *).
Monad m =>
Proxy (JsonRpc method p e r)
-> Proxy m
-> RpcHandler (JsonRpc method p e r) m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
jsonRpcRouter Proxy (JsonRpc method p e r)
_ Proxy m
_ RpcHandler (JsonRpc method p e r) m
h = [(String,
  Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))]
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
methodName, Value -> m (PossibleContent (Either (JsonRpcErr Value) Value))
h')]
   where
    methodName :: String
methodName = Proxy method -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy method -> String) -> Proxy method -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @method
    onDecode :: p -> m (Either (JsonRpcErr Value) Value)
onDecode = (Either (JsonRpcErr e) r -> Either (JsonRpcErr Value) Value)
-> m (Either (JsonRpcErr e) r)
-> m (Either (JsonRpcErr Value) Value)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (JsonRpcErr e) r -> Either (JsonRpcErr Value) Value
forall e r.
(ToJSON e, ToJSON r) =>
Either (JsonRpcErr e) r -> Either (JsonRpcErr Value) Value
generalizeResponse (m (Either (JsonRpcErr e) r)
 -> m (Either (JsonRpcErr Value) Value))
-> (p -> m (Either (JsonRpcErr e) r))
-> p
-> m (Either (JsonRpcErr Value) Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcHandler (JsonRpc method p e r) m
p -> m (Either (JsonRpcErr e) r)
h

    h' :: Value -> m (PossibleContent (Either (JsonRpcErr Value) Value))
h' =
      (Either (JsonRpcErr Value) Value
 -> PossibleContent (Either (JsonRpcErr Value) Value))
-> m (Either (JsonRpcErr Value) Value)
-> m (PossibleContent (Either (JsonRpcErr Value) Value))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (JsonRpcErr Value) Value
-> PossibleContent (Either (JsonRpcErr Value) Value)
forall a. a -> PossibleContent a
SomeContent
        (m (Either (JsonRpcErr Value) Value)
 -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
-> (Value -> m (Either (JsonRpcErr Value) Value))
-> Value
-> m (PossibleContent (Either (JsonRpcErr Value) Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> m (Either (JsonRpcErr Value) Value))
-> (p -> m (Either (JsonRpcErr Value) Value))
-> Either String p
-> m (Either (JsonRpcErr Value) Value)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either (JsonRpcErr Value) Value
-> m (Either (JsonRpcErr Value) Value)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (JsonRpcErr Value) Value
 -> m (Either (JsonRpcErr Value) Value))
-> (String -> Either (JsonRpcErr Value) Value)
-> String
-> m (Either (JsonRpcErr Value) Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonRpcErr Value -> Either (JsonRpcErr Value) Value
forall a b. a -> Either a b
Left (JsonRpcErr Value -> Either (JsonRpcErr Value) Value)
-> (String -> JsonRpcErr Value)
-> String
-> Either (JsonRpcErr Value) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JsonRpcErr Value
forall e. String -> JsonRpcErr e
onDecodeFail) p -> m (Either (JsonRpcErr Value) Value)
onDecode
        (Either String p -> m (Either (JsonRpcErr Value) Value))
-> (Value -> Either String p)
-> Value
-> m (Either (JsonRpcErr Value) Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser p) -> Value -> Either String p
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser p
forall a. FromJSON a => Value -> Parser a
parseJSON

  hoistRpcRouter :: forall (m :: * -> *) (n :: * -> *).
Proxy (JsonRpc method p e r)
-> (forall x. m x -> n x)
-> RpcHandler (JsonRpc method p e r) m
-> RpcHandler (JsonRpc method p e r) n
hoistRpcRouter Proxy (JsonRpc method p e r)
_ forall x. m x -> n x
f RpcHandler (JsonRpc method p e r) m
x = m (Either (JsonRpcErr e) r) -> n (Either (JsonRpcErr e) r)
forall x. m x -> n x
f (m (Either (JsonRpcErr e) r) -> n (Either (JsonRpcErr e) r))
-> (p -> m (Either (JsonRpcErr e) r))
-> p
-> n (Either (JsonRpcErr e) r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcHandler (JsonRpc method p e r) m
p -> m (Either (JsonRpcErr e) r)
x

instance (KnownSymbol method, FromJSON p) => RouteJsonRpc (JsonRpcNotification method p) where
  type RpcHandler (JsonRpcNotification method p) m = p -> m NoContent

  jsonRpcRouter :: forall (m :: * -> *).
Monad m =>
Proxy (JsonRpcNotification method p)
-> Proxy m
-> RpcHandler (JsonRpcNotification method p) m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
jsonRpcRouter Proxy (JsonRpcNotification method p)
_ Proxy m
_ RpcHandler (JsonRpcNotification method p) m
h = [(String,
  Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))]
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
methodName, Value -> m (PossibleContent (Either (JsonRpcErr Value) Value))
h')]
   where
    methodName :: String
methodName = Proxy method -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy method -> String) -> Proxy method -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @method
    onDecode :: p -> m (PossibleContent (Either (JsonRpcErr Value) Value))
onDecode p
x = PossibleContent (Either (JsonRpcErr Value) Value)
forall a. PossibleContent a
EmptyContent PossibleContent (Either (JsonRpcErr Value) Value)
-> m NoContent
-> m (PossibleContent (Either (JsonRpcErr Value) Value))
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ RpcHandler (JsonRpcNotification method p) m
p -> m NoContent
h p
x

    h' :: Value -> m (PossibleContent (Either (JsonRpcErr Value) Value))
h' =
      (String -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
-> (p -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
-> Either String p
-> m (PossibleContent (Either (JsonRpcErr Value) Value))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (PossibleContent (Either (JsonRpcErr Value) Value)
-> m (PossibleContent (Either (JsonRpcErr Value) Value))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PossibleContent (Either (JsonRpcErr Value) Value)
 -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
-> (String -> PossibleContent (Either (JsonRpcErr Value) Value))
-> String
-> m (PossibleContent (Either (JsonRpcErr Value) Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (JsonRpcErr Value) Value
-> PossibleContent (Either (JsonRpcErr Value) Value)
forall a. a -> PossibleContent a
SomeContent (Either (JsonRpcErr Value) Value
 -> PossibleContent (Either (JsonRpcErr Value) Value))
-> (String -> Either (JsonRpcErr Value) Value)
-> String
-> PossibleContent (Either (JsonRpcErr Value) Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonRpcErr Value -> Either (JsonRpcErr Value) Value
forall a b. a -> Either a b
Left (JsonRpcErr Value -> Either (JsonRpcErr Value) Value)
-> (String -> JsonRpcErr Value)
-> String
-> Either (JsonRpcErr Value) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JsonRpcErr Value
forall e. String -> JsonRpcErr e
onDecodeFail) p -> m (PossibleContent (Either (JsonRpcErr Value) Value))
onDecode
        (Either String p
 -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
-> (Value -> Either String p)
-> Value
-> m (PossibleContent (Either (JsonRpcErr Value) Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Parser p) -> Value -> Either String p
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser p
forall a. FromJSON a => Value -> Parser a
parseJSON

  hoistRpcRouter :: forall (m :: * -> *) (n :: * -> *).
Proxy (JsonRpcNotification method p)
-> (forall x. m x -> n x)
-> RpcHandler (JsonRpcNotification method p) m
-> RpcHandler (JsonRpcNotification method p) n
hoistRpcRouter Proxy (JsonRpcNotification method p)
_ forall x. m x -> n x
f RpcHandler (JsonRpcNotification method p) m
x = m NoContent -> n NoContent
forall x. m x -> n x
f (m NoContent -> n NoContent)
-> (p -> m NoContent) -> p -> n NoContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcHandler (JsonRpcNotification method p) m
p -> m NoContent
x

instance (RouteJsonRpc a, RouteJsonRpc b) => RouteJsonRpc (a :<|> b) where
  type RpcHandler (a :<|> b) m = RpcHandler a m :<|> RpcHandler b m

  jsonRpcRouter :: forall (m :: * -> *).
Monad m =>
Proxy (a :<|> b)
-> Proxy m
-> RpcHandler (a :<|> b) m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
jsonRpcRouter Proxy (a :<|> b)
_ Proxy m
pxm (RpcHandler a m
ha :<|> RpcHandler b m
hb) = Proxy a
-> Proxy m
-> RpcHandler a m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall a (m :: * -> *).
(RouteJsonRpc a, Monad m) =>
Proxy a
-> Proxy m
-> RpcHandler a m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall (m :: * -> *).
Monad m =>
Proxy a
-> Proxy m
-> RpcHandler a m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
jsonRpcRouter Proxy a
pxa Proxy m
pxm RpcHandler a m
ha Map
  String
  (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall a. Semigroup a => a -> a -> a
<> Proxy b
-> Proxy m
-> RpcHandler b m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall a (m :: * -> *).
(RouteJsonRpc a, Monad m) =>
Proxy a
-> Proxy m
-> RpcHandler a m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall (m :: * -> *).
Monad m =>
Proxy b
-> Proxy m
-> RpcHandler b m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
jsonRpcRouter Proxy b
pxb Proxy m
pxm RpcHandler b m
hb
   where
    pxa :: Proxy a
pxa = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
    pxb :: Proxy b
pxb = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b

  hoistRpcRouter :: forall (m :: * -> *) (n :: * -> *).
Proxy (a :<|> b)
-> (forall x. m x -> n x)
-> RpcHandler (a :<|> b) m
-> RpcHandler (a :<|> b) n
hoistRpcRouter Proxy (a :<|> b)
_ forall x. m x -> n x
f (RpcHandler a m
x :<|> RpcHandler b m
y) = Proxy a
-> (forall x. m x -> n x) -> RpcHandler a m -> RpcHandler a n
forall a (m :: * -> *) (n :: * -> *).
RouteJsonRpc a =>
Proxy a
-> (forall x. m x -> n x) -> RpcHandler a m -> RpcHandler a n
forall (m :: * -> *) (n :: * -> *).
Proxy a
-> (forall x. m x -> n x) -> RpcHandler a m -> RpcHandler a n
hoistRpcRouter (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) m x -> n x
forall x. m x -> n x
f RpcHandler a m
x RpcHandler a n
-> RpcHandler b n -> RpcHandler a n :<|> RpcHandler b n
forall a b. a -> b -> a :<|> b
:<|> Proxy b
-> (forall x. m x -> n x) -> RpcHandler b m -> RpcHandler b n
forall a (m :: * -> *) (n :: * -> *).
RouteJsonRpc a =>
Proxy a
-> (forall x. m x -> n x) -> RpcHandler a m -> RpcHandler a n
forall (m :: * -> *) (n :: * -> *).
Proxy b
-> (forall x. m x -> n x) -> RpcHandler b m -> RpcHandler b n
hoistRpcRouter (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @b) m x -> n x
forall x. m x -> n x
f RpcHandler b m
y

{- | This function is the glue required to convert a collection of
handlers in servant standard style to the handler that 'RawJsonRpc'
expects.
-}
serveJsonRpc ::
  (Monad m, RouteJsonRpc a) =>
  Proxy a ->
  Proxy m ->
  RpcHandler a m ->
  Request Value ->
  m PossibleJsonRpcResponse
serveJsonRpc :: forall (m :: * -> *) a.
(Monad m, RouteJsonRpc a) =>
Proxy a
-> Proxy m
-> RpcHandler a m
-> Request Value
-> m PossibleJsonRpcResponse
serveJsonRpc Proxy a
px Proxy m
pxm RpcHandler a m
hs (Request String
m Value
v Maybe Word64
ix')
  | Just Value -> m (PossibleContent (Either (JsonRpcErr Value) Value))
h <- String
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
-> Maybe
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
m Map
  String
  (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
hmap =
      Value -> m (PossibleContent (Either (JsonRpcErr Value) Value))
h Value
v m (PossibleContent (Either (JsonRpcErr Value) Value))
-> (PossibleContent (Either (JsonRpcErr Value) Value)
    -> m PossibleJsonRpcResponse)
-> m PossibleJsonRpcResponse
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SomeContent (Right Value
x)
          | Just Word64
ix <- Maybe Word64
ix' -> PossibleJsonRpcResponse -> m PossibleJsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PossibleJsonRpcResponse -> m PossibleJsonRpcResponse)
-> (JsonRpcResponse Value Value -> PossibleJsonRpcResponse)
-> JsonRpcResponse Value Value
-> m PossibleJsonRpcResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonRpcResponse Value Value -> PossibleJsonRpcResponse
forall a. a -> PossibleContent a
SomeContent (JsonRpcResponse Value Value -> m PossibleJsonRpcResponse)
-> JsonRpcResponse Value Value -> m PossibleJsonRpcResponse
forall a b. (a -> b) -> a -> b
$ Word64 -> Value -> JsonRpcResponse Value Value
forall e r. Word64 -> r -> JsonRpcResponse e r
Result Word64
ix Value
x
          | Bool
otherwise -> PossibleJsonRpcResponse -> m PossibleJsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PossibleJsonRpcResponse -> m PossibleJsonRpcResponse)
-> (JsonRpcResponse Value Value -> PossibleJsonRpcResponse)
-> JsonRpcResponse Value Value
-> m PossibleJsonRpcResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonRpcResponse Value Value -> PossibleJsonRpcResponse
forall a. a -> PossibleContent a
SomeContent (JsonRpcResponse Value Value -> m PossibleJsonRpcResponse)
-> JsonRpcResponse Value Value -> m PossibleJsonRpcResponse
forall a b. (a -> b) -> a -> b
$ Maybe Word64 -> JsonRpcErr Value -> JsonRpcResponse Value Value
forall e r. Maybe Word64 -> JsonRpcErr e -> JsonRpcResponse e r
Errors Maybe Word64
ix' JsonRpcErr Value
forall {e}. JsonRpcErr e
invalidRequest
        SomeContent (Left JsonRpcErr Value
e) -> PossibleJsonRpcResponse -> m PossibleJsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PossibleJsonRpcResponse -> m PossibleJsonRpcResponse)
-> (JsonRpcResponse Value Value -> PossibleJsonRpcResponse)
-> JsonRpcResponse Value Value
-> m PossibleJsonRpcResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonRpcResponse Value Value -> PossibleJsonRpcResponse
forall a. a -> PossibleContent a
SomeContent (JsonRpcResponse Value Value -> m PossibleJsonRpcResponse)
-> JsonRpcResponse Value Value -> m PossibleJsonRpcResponse
forall a b. (a -> b) -> a -> b
$ Maybe Word64 -> JsonRpcErr Value -> JsonRpcResponse Value Value
forall e r. Maybe Word64 -> JsonRpcErr e -> JsonRpcResponse e r
Errors Maybe Word64
ix' JsonRpcErr Value
e
        PossibleContent (Either (JsonRpcErr Value) Value)
EmptyContent -> PossibleJsonRpcResponse -> m PossibleJsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PossibleJsonRpcResponse
forall a. PossibleContent a
EmptyContent
  | Bool
otherwise = PossibleJsonRpcResponse -> m PossibleJsonRpcResponse
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PossibleJsonRpcResponse -> m PossibleJsonRpcResponse)
-> (JsonRpcResponse Value Value -> PossibleJsonRpcResponse)
-> JsonRpcResponse Value Value
-> m PossibleJsonRpcResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonRpcResponse Value Value -> PossibleJsonRpcResponse
forall a. a -> PossibleContent a
SomeContent (JsonRpcResponse Value Value -> m PossibleJsonRpcResponse)
-> JsonRpcResponse Value Value -> m PossibleJsonRpcResponse
forall a b. (a -> b) -> a -> b
$ Maybe Word64 -> JsonRpcErr Value -> JsonRpcResponse Value Value
forall e r. Maybe Word64 -> JsonRpcErr e -> JsonRpcResponse e r
Errors Maybe Word64
ix' JsonRpcErr Value
missingMethod
 where
  missingMethod :: JsonRpcErr Value
missingMethod = Int -> String -> Maybe Value -> JsonRpcErr Value
forall e. Int -> String -> Maybe e -> JsonRpcErr e
JsonRpcErr Int
methodNotFoundCode (String
"Unknown method: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
m) Maybe Value
forall a. Maybe a
Nothing
  hmap :: Map
  String
  (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
hmap = Proxy a
-> Proxy m
-> RpcHandler a m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall a (m :: * -> *).
(RouteJsonRpc a, Monad m) =>
Proxy a
-> Proxy m
-> RpcHandler a m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
forall (m :: * -> *).
Monad m =>
Proxy a
-> Proxy m
-> RpcHandler a m
-> Map
     String
     (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
jsonRpcRouter Proxy a
px Proxy m
pxm RpcHandler a m
hs
  invalidRequest :: JsonRpcErr e
invalidRequest = Int -> String -> Maybe e -> JsonRpcErr e
forall e. Int -> String -> Maybe e -> JsonRpcErr e
JsonRpcErr Int
invalidRequestCode String
"Missing id" Maybe e
forall a. Maybe a
Nothing