{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
Module      : Recalc.Server.Generic
Description : Servant-like combinators for defining and handling
              JSON-RPC APIs.

Provides a generic way to define and handle JSON-RPC APIs using
a Servant-like approach. Given a protocol type with named routes,
this module allows defining handlers generically.

=== Example:

@
data NamedApi mode = NamedApi
  { rpcGetValue :: mode :- JsonRpc "open" GetParams GetResult
  , rpcAddValue :: mode :- JsonRpc "close" AddParams ()
  } deriving (Generic)

type Api = ToApi NamedApi

data Api mode =
  { getValue :: mode :- JsonRpc "get" () Int
  , addValue :: mode :- JsonRpc "add" Int ()
  }

handlers :: HandlerT Api IO
handlers = namedHandlers server

server :: NamedApi Server
server = NamedApi { ... }
@

which can then be used to handle a @req :: JsonRpcRequest Json.Value@ using:

@
handle @Api req handlers :: Either String (IO ())
@
-}
module Recalc.Server.Generic
  ( Id
  , JsonRpcRequest (..)
  , pattern JsonRpcNotification
  , JsonRpc
  , HasHandler
  , HandlerT
  , handle
  , hoist
  , GenericMode (..)
  , AsServerT
  , AsServer
  , AsApi
  , ToApi
  , namedHandlers
  , (:>)
  , (:<|>) (..)
  ) where

import Control.Exception (SomeException, displayException, try)
import Data.Aeson (Options (..))
import Data.Aeson qualified as Json
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString.Lazy qualified as LB
import Data.Data (Typeable, typeRep)
import Data.Functor ((<&>))
import Data.Kind (Type)
import Data.List
import Data.Proxy
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Word
import GHC.Generics
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)

import Recalc.Server.Json (aesonOptions)

-- | inject jsonrpc version string into a @'Json.Value'@
genericToVersionedJSON
  :: (Generic a, Json.GToJSON' Json.Value Json.Zero (Rep a))
  => Options
  -> a
  -> Json.Value
genericToVersionedJSON :: forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToVersionedJSON Options
options = String -> Value -> Value -> Value
inject String
"jsonrpc" (Text -> Value
Json.String Text
"2.0") (Value -> Value) -> (a -> Value) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Json.genericToJSON Options
options
 where
  inject :: String -> Value -> Value -> Value
inject String
k Value
v = \case
    Json.Object Object
obj -> Object -> Value
Json.Object (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert (String -> Key
Key.fromString String
k) Value
v Object
obj)
    Value
err -> String -> Value
forall a. HasCallStack => String -> a
error (String
"not an object: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
err)

showJson :: Json.ToJSON a => a -> String
showJson :: forall a. ToJSON a => a -> String
showJson = Text -> String
Text.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
Json.encode

type Id = Word64

data JsonRpcRequest params = JsonRpcRequest
  {forall params. JsonRpcRequest params -> String
request'method :: String, forall params. JsonRpcRequest params -> Maybe Id
request'id :: Maybe Id, forall params. JsonRpcRequest params -> params
request'params :: params}
  deriving ((forall x. JsonRpcRequest params -> Rep (JsonRpcRequest params) x)
-> (forall x.
    Rep (JsonRpcRequest params) x -> JsonRpcRequest params)
-> Generic (JsonRpcRequest params)
forall x. Rep (JsonRpcRequest params) x -> JsonRpcRequest params
forall x. JsonRpcRequest params -> Rep (JsonRpcRequest params) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall params x.
Rep (JsonRpcRequest params) x -> JsonRpcRequest params
forall params x.
JsonRpcRequest params -> Rep (JsonRpcRequest params) x
$cfrom :: forall params x.
JsonRpcRequest params -> Rep (JsonRpcRequest params) x
from :: forall x. JsonRpcRequest params -> Rep (JsonRpcRequest params) x
$cto :: forall params x.
Rep (JsonRpcRequest params) x -> JsonRpcRequest params
to :: forall x. Rep (JsonRpcRequest params) x -> JsonRpcRequest params
Generic, Int -> JsonRpcRequest params -> String -> String
[JsonRpcRequest params] -> String -> String
JsonRpcRequest params -> String
(Int -> JsonRpcRequest params -> String -> String)
-> (JsonRpcRequest params -> String)
-> ([JsonRpcRequest params] -> String -> String)
-> Show (JsonRpcRequest params)
forall params.
Show params =>
Int -> JsonRpcRequest params -> String -> String
forall params.
Show params =>
[JsonRpcRequest params] -> String -> String
forall params. Show params => JsonRpcRequest params -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall params.
Show params =>
Int -> JsonRpcRequest params -> String -> String
showsPrec :: Int -> JsonRpcRequest params -> String -> String
$cshow :: forall params. Show params => JsonRpcRequest params -> String
show :: JsonRpcRequest params -> String
$cshowList :: forall params.
Show params =>
[JsonRpcRequest params] -> String -> String
showList :: [JsonRpcRequest params] -> String -> String
Show)

pattern JsonRpcNotification :: String -> params -> JsonRpcRequest params
pattern $bJsonRpcNotification :: forall params. String -> params -> JsonRpcRequest params
$mJsonRpcNotification :: forall {r} {params}.
JsonRpcRequest params
-> (String -> params -> r) -> ((# #) -> r) -> r
JsonRpcNotification method params = JsonRpcRequest method Nothing params

instance Json.FromJSON params => Json.FromJSON (JsonRpcRequest params) where
  parseJSON :: Value -> Parser (JsonRpcRequest params)
parseJSON = Options -> Value -> Parser (JsonRpcRequest params)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
Json.genericParseJSON Options
aesonOptions{Json.rejectUnknownFields = False}

instance Json.ToJSON params => Json.ToJSON (JsonRpcRequest params) where
  toJSON :: JsonRpcRequest params -> Value
toJSON = Options -> JsonRpcRequest params -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToVersionedJSON Options
aesonOptions

data JsonRpcResult rsp = JsonRpcResult
  {forall rsp. JsonRpcResult rsp -> Maybe Id
response'id :: Maybe Id, forall rsp. JsonRpcResult rsp -> rsp
response'result :: rsp}
  deriving ((forall x. JsonRpcResult rsp -> Rep (JsonRpcResult rsp) x)
-> (forall x. Rep (JsonRpcResult rsp) x -> JsonRpcResult rsp)
-> Generic (JsonRpcResult rsp)
forall x. Rep (JsonRpcResult rsp) x -> JsonRpcResult rsp
forall x. JsonRpcResult rsp -> Rep (JsonRpcResult rsp) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall rsp x. Rep (JsonRpcResult rsp) x -> JsonRpcResult rsp
forall rsp x. JsonRpcResult rsp -> Rep (JsonRpcResult rsp) x
$cfrom :: forall rsp x. JsonRpcResult rsp -> Rep (JsonRpcResult rsp) x
from :: forall x. JsonRpcResult rsp -> Rep (JsonRpcResult rsp) x
$cto :: forall rsp x. Rep (JsonRpcResult rsp) x -> JsonRpcResult rsp
to :: forall x. Rep (JsonRpcResult rsp) x -> JsonRpcResult rsp
Generic, Int -> JsonRpcResult rsp -> String -> String
[JsonRpcResult rsp] -> String -> String
JsonRpcResult rsp -> String
(Int -> JsonRpcResult rsp -> String -> String)
-> (JsonRpcResult rsp -> String)
-> ([JsonRpcResult rsp] -> String -> String)
-> Show (JsonRpcResult rsp)
forall rsp.
Show rsp =>
Int -> JsonRpcResult rsp -> String -> String
forall rsp. Show rsp => [JsonRpcResult rsp] -> String -> String
forall rsp. Show rsp => JsonRpcResult rsp -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall rsp.
Show rsp =>
Int -> JsonRpcResult rsp -> String -> String
showsPrec :: Int -> JsonRpcResult rsp -> String -> String
$cshow :: forall rsp. Show rsp => JsonRpcResult rsp -> String
show :: JsonRpcResult rsp -> String
$cshowList :: forall rsp. Show rsp => [JsonRpcResult rsp] -> String -> String
showList :: [JsonRpcResult rsp] -> String -> String
Show)

instance Json.FromJSON rsp => Json.FromJSON (JsonRpcResult rsp)

instance Json.ToJSON rsp => Json.ToJSON (JsonRpcResult rsp) where
  toJSON :: JsonRpcResult rsp -> Value
toJSON =
    Options -> JsonRpcResult rsp -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToVersionedJSON
      Options
aesonOptions
        { omitNothingFields = False -- make sure to encode @JsonRpcResult ()@ as @{..result: []}@
        }

data JsonRpcErrorObject = JsonRpcErrorObject
  { JsonRpcErrorObject -> Int
errorObject'code :: Int
  -- ^ -32099 to -32000 are server-defined JSON-RPC codes
  , JsonRpcErrorObject -> Text
errorObject'message :: Text
  }
  deriving ((forall x. JsonRpcErrorObject -> Rep JsonRpcErrorObject x)
-> (forall x. Rep JsonRpcErrorObject x -> JsonRpcErrorObject)
-> Generic JsonRpcErrorObject
forall x. Rep JsonRpcErrorObject x -> JsonRpcErrorObject
forall x. JsonRpcErrorObject -> Rep JsonRpcErrorObject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JsonRpcErrorObject -> Rep JsonRpcErrorObject x
from :: forall x. JsonRpcErrorObject -> Rep JsonRpcErrorObject x
$cto :: forall x. Rep JsonRpcErrorObject x -> JsonRpcErrorObject
to :: forall x. Rep JsonRpcErrorObject x -> JsonRpcErrorObject
Generic, Int -> JsonRpcErrorObject -> String -> String
[JsonRpcErrorObject] -> String -> String
JsonRpcErrorObject -> String
(Int -> JsonRpcErrorObject -> String -> String)
-> (JsonRpcErrorObject -> String)
-> ([JsonRpcErrorObject] -> String -> String)
-> Show JsonRpcErrorObject
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> JsonRpcErrorObject -> String -> String
showsPrec :: Int -> JsonRpcErrorObject -> String -> String
$cshow :: JsonRpcErrorObject -> String
show :: JsonRpcErrorObject -> String
$cshowList :: [JsonRpcErrorObject] -> String -> String
showList :: [JsonRpcErrorObject] -> String -> String
Show)

instance Json.FromJSON JsonRpcErrorObject

instance Json.ToJSON JsonRpcErrorObject where
  toJSON :: JsonRpcErrorObject -> Value
toJSON = Options -> JsonRpcErrorObject -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
Json.genericToJSON Options
aesonOptions

data JsonRpcError = JsonRpcError
  {JsonRpcError -> Maybe Id
errorResponse'id :: Maybe Id, JsonRpcError -> JsonRpcErrorObject
errorResponse'error :: JsonRpcErrorObject}
  deriving ((forall x. JsonRpcError -> Rep JsonRpcError x)
-> (forall x. Rep JsonRpcError x -> JsonRpcError)
-> Generic JsonRpcError
forall x. Rep JsonRpcError x -> JsonRpcError
forall x. JsonRpcError -> Rep JsonRpcError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JsonRpcError -> Rep JsonRpcError x
from :: forall x. JsonRpcError -> Rep JsonRpcError x
$cto :: forall x. Rep JsonRpcError x -> JsonRpcError
to :: forall x. Rep JsonRpcError x -> JsonRpcError
Generic, Int -> JsonRpcError -> String -> String
[JsonRpcError] -> String -> String
JsonRpcError -> String
(Int -> JsonRpcError -> String -> String)
-> (JsonRpcError -> String)
-> ([JsonRpcError] -> String -> String)
-> Show JsonRpcError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> JsonRpcError -> String -> String
showsPrec :: Int -> JsonRpcError -> String -> String
$cshow :: JsonRpcError -> String
show :: JsonRpcError -> String
$cshowList :: [JsonRpcError] -> String -> String
showList :: [JsonRpcError] -> String -> String
Show)

instance Json.FromJSON JsonRpcError

instance Json.ToJSON JsonRpcError where
  toJSON :: JsonRpcError -> Value
toJSON = Options -> JsonRpcError -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToVersionedJSON Options
aesonOptions

jsonRpcError :: Maybe Id -> String -> JsonRpcError
jsonRpcError :: Maybe Id -> String -> JsonRpcError
jsonRpcError Maybe Id
xId = Maybe Id -> JsonRpcErrorObject -> JsonRpcError
JsonRpcError Maybe Id
xId (JsonRpcErrorObject -> JsonRpcError)
-> (String -> JsonRpcErrorObject) -> String -> JsonRpcError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> JsonRpcErrorObject
JsonRpcErrorObject (-Int
32001) (Text -> JsonRpcErrorObject)
-> (String -> Text) -> String -> JsonRpcErrorObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

type Segment = String
class HasHandler api where
  type HandlerT api (m :: Type -> Type)
  handle'
    :: (JsonRpcRequest Json.Value, [Segment]) -> Handler api -> Either String (IO Json.Value)
  hoist :: (forall x. m x -> n x) -> HandlerT api m -> HandlerT api n

handle
  :: forall api
   . HasHandler api
  => JsonRpcRequest Json.Value
  -> Handler api
  -> Either String (IO Json.Value)
handle :: forall {k} (api :: k).
HasHandler api =>
JsonRpcRequest Value -> Handler api -> Either String (IO Value)
handle = forall (api :: k).
HasHandler api =>
(JsonRpcRequest Value, [String])
-> Handler api -> Either String (IO Value)
forall {k} (api :: k).
HasHandler api =>
(JsonRpcRequest Value, [String])
-> Handler api -> Either String (IO Value)
handle' @api ((JsonRpcRequest Value, [String])
 -> HandlerT api IO -> Either String (IO Value))
-> (JsonRpcRequest Value -> (JsonRpcRequest Value, [String]))
-> JsonRpcRequest Value
-> HandlerT api IO
-> Either String (IO Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,[])

type Handler api = HandlerT api IO

infixr 4 :>
infixr 3 :<|>
infixl 0 :-

data (path :: Symbol) :> (a :: Type) :: Type
data a :<|> b = a :<|> b

data JsonRpc (sym :: Symbol) (params :: Type) (rsp :: Type)

instance (KnownSymbol path, HasHandler api) => HasHandler (path :> api) where
  type HandlerT (path :> api) m = HandlerT api m
  handle' :: (JsonRpcRequest Value, [String])
-> Handler (path :> api) -> Either String (IO Value)
handle' (JsonRpcRequest Value
req, [String]
segments) = forall api.
HasHandler api =>
(JsonRpcRequest Value, [String])
-> Handler api -> Either String (IO Value)
forall {k} (api :: k).
HasHandler api =>
(JsonRpcRequest Value, [String])
-> Handler api -> Either String (IO Value)
handle' @api (JsonRpcRequest Value
req, forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @path Proxy path
forall {k} (t :: k). Proxy t
Proxy String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
segments)
  hoist :: forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x)
-> HandlerT (path :> api) m -> HandlerT (path :> api) n
hoist = forall api (m :: * -> *) (n :: * -> *).
HasHandler api =>
(forall x. m x -> n x) -> HandlerT api m -> HandlerT api n
forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasHandler api =>
(forall x. m x -> n x) -> HandlerT api m -> HandlerT api n
hoist @api

instance (HasHandler a, HasHandler b) => HasHandler (a :<|> b) where
  type HandlerT (a :<|> b) m = HandlerT a m :<|> HandlerT b m
  handle' :: (JsonRpcRequest Value, [String])
-> Handler (a :<|> b) -> Either String (IO Value)
handle' (JsonRpcRequest Value, [String])
req (HandlerT a IO
a :<|> HandlerT b IO
b) = forall api.
HasHandler api =>
(JsonRpcRequest Value, [String])
-> Handler api -> Either String (IO Value)
forall {k} (api :: k).
HasHandler api =>
(JsonRpcRequest Value, [String])
-> Handler api -> Either String (IO Value)
handle' @a (JsonRpcRequest Value, [String])
req HandlerT a IO
a Either String (IO Value)
-> Either String (IO Value) -> Either String (IO Value)
forall a. Semigroup a => a -> a -> a
<> forall api.
HasHandler api =>
(JsonRpcRequest Value, [String])
-> Handler api -> Either String (IO Value)
forall {k} (api :: k).
HasHandler api =>
(JsonRpcRequest Value, [String])
-> Handler api -> Either String (IO Value)
handle' @b (JsonRpcRequest Value, [String])
req HandlerT b IO
b
  hoist :: forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x)
-> HandlerT (a :<|> b) m -> HandlerT (a :<|> b) n
hoist forall x. m x -> n x
nt (HandlerT a m
a :<|> HandlerT b m
b) = forall api (m :: * -> *) (n :: * -> *).
HasHandler api =>
(forall x. m x -> n x) -> HandlerT api m -> HandlerT api n
forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasHandler api =>
(forall x. m x -> n x) -> HandlerT api m -> HandlerT api n
hoist @a m x -> n x
forall x. m x -> n x
nt HandlerT a m
a HandlerT a n -> HandlerT b n -> HandlerT a n :<|> HandlerT b n
forall a b. a -> b -> a :<|> b
:<|> forall api (m :: * -> *) (n :: * -> *).
HasHandler api =>
(forall x. m x -> n x) -> HandlerT api m -> HandlerT api n
forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasHandler api =>
(forall x. m x -> n x) -> HandlerT api m -> HandlerT api n
hoist @b m x -> n x
forall x. m x -> n x
nt HandlerT b m
b

instance
  ( KnownSymbol sym
  , Json.FromJSON params
  , Json.ToJSON rsp
  , Typeable params
  )
  => HasHandler (JsonRpc sym params rsp)
  where
  type HandlerT (JsonRpc sym params rsp) m = (Maybe Id, params) -> m rsp
  handle' :: (JsonRpcRequest Value, [String])
-> Handler (JsonRpc sym params rsp) -> Either String (IO Value)
handle' (JsonRpcRequest{String
Maybe Id
Value
request'method :: forall params. JsonRpcRequest params -> String
request'id :: forall params. JsonRpcRequest params -> Maybe Id
request'params :: forall params. JsonRpcRequest params -> params
request'method :: String
request'id :: Maybe Id
request'params :: Value
..}, [String]
segments) Handler (JsonRpc sym params rsp)
f
    | Bool
methodMatches
    , Json.Success params
params' <- forall a. FromJSON a => Value -> Result a
Json.fromJSON @params Value
request'params =
        IO Value -> Either String (IO Value)
forall a b. b -> Either a b
Right
          (IO Value -> Either String (IO Value))
-> IO Value -> Either String (IO Value)
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (Handler (JsonRpc sym params rsp)
(Maybe Id, params) -> IO rsp
f (Maybe Id
request'id, params
params'))
          IO (Either SomeException rsp)
-> (Either SomeException rsp -> Value) -> IO Value
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            Left SomeException
err -> JsonRpcError -> Value
forall a. ToJSON a => a -> Value
Json.toJSON (Maybe Id -> String -> JsonRpcError
jsonRpcError Maybe Id
request'id (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err))
            Right rsp
res -> JsonRpcResult rsp -> Value
forall a. ToJSON a => a -> Value
Json.toJSON (Maybe Id -> rsp -> JsonRpcResult rsp
forall rsp. Maybe Id -> rsp -> JsonRpcResult rsp
JsonRpcResult Maybe Id
request'id rsp
res)
    | Bool
methodMatches =
        String -> Either String (IO Value)
forall a b. a -> Either a b
Left
          (String -> Either String (IO Value))
-> String -> Either String (IO Value)
forall a b. (a -> b) -> a -> b
$ String
"handler for method '"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
request'method
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' expects '"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show (Proxy params -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy params -> TypeRep) -> Proxy params -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @params)
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' (got: '"
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. ToJSON a => a -> String
showJson Value
request'params
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"')"
    | Bool
otherwise = String -> Either String (IO Value)
forall a b. a -> Either a b
Left (String -> Either String (IO Value))
-> String -> Either String (IO Value)
forall a b. (a -> b) -> a -> b
$ String
"no handler for method '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
request'method String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
request'params
   where
    path :: [String]
path = [String] -> [String]
forall a. [a] -> [a]
reverse (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @sym Proxy sym
forall {k} (t :: k). Proxy t
Proxy String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
segments)
    methodMatches :: Bool
methodMatches = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" [String]
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
request'method

  hoist :: forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x)
-> HandlerT (JsonRpc sym params rsp) m
-> HandlerT (JsonRpc sym params rsp) n
hoist forall x. m x -> n x
nt HandlerT (JsonRpc sym params rsp) m
f = m rsp -> n rsp
forall x. m x -> n x
nt (m rsp -> n rsp)
-> ((Maybe Id, params) -> m rsp) -> (Maybe Id, params) -> n rsp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerT (JsonRpc sym params rsp) m
(Maybe Id, params) -> m rsp
f

-- | generic modes for protocol datatypes
class GenericMode mode where
  type mode :- api :: Type

data AsServerT (m :: Type -> Type)

-- \^ server mode

instance GenericMode (AsServerT m) where
  type AsServerT m :- api = HandlerT api m

type AsServer =
  AsServerT IO
  -- ^ the default server

data AsApi

-- \^ api mode

instance GenericMode AsApi where
  type AsApi :- api = api

class GSum f where
  type GToSum f
  gtoHandler :: f p -> GToSum f

instance (GSum l, GSum r) => GSum (l :*: r) where
  type GToSum (l :*: r) = GToSum l :<|> GToSum r
  gtoHandler :: forall (p :: k). (:*:) l r p -> GToSum (l :*: r)
gtoHandler (l p
l :*: r p
r) = l p -> GToSum l
forall (p :: k). l p -> GToSum l
forall {k} (f :: k -> *) (p :: k). GSum f => f p -> GToSum f
gtoHandler l p
l GToSum l -> GToSum r -> GToSum l :<|> GToSum r
forall a b. a -> b -> a :<|> b
:<|> r p -> GToSum r
forall (p :: k). r p -> GToSum r
forall {k} (f :: k -> *) (p :: k). GSum f => f p -> GToSum f
gtoHandler r p
r

instance GSum f => GSum (M1 i c f) where
  type GToSum (M1 i c f) = GToSum f
  gtoHandler :: forall (p :: k). M1 i c f p -> GToSum (M1 i c f)
gtoHandler = f p -> GToSum f
forall (p :: k). f p -> GToSum f
forall {k} (f :: k -> *) (p :: k). GSum f => f p -> GToSum f
gtoHandler (f p -> GToSum f) -> (M1 i c f p -> f p) -> M1 i c f p -> GToSum f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c f p -> f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance GSum (K1 i c) where
  type GToSum (K1 i c) = c
  gtoHandler :: forall (p :: k). K1 i c p -> GToSum (K1 i c)
gtoHandler = K1 i c p -> c
K1 i c p -> GToSum (K1 i c)
forall k i c (p :: k). K1 i c p -> c
unK1

-- the sum representation of a generic protocol datatype
type ToApi api' = GToSum (Rep (api' AsApi))

-- | generically converts an @Api ('AsServerT' m)@ to its sum representation @ep0 :<|> ep1 :<|> ...@
namedHandlers
  :: (GenericMode m, Generic (api' m), GSum (Rep (api' m)))
  => api' m
  -> GToSum (Rep (api' m))
namedHandlers :: forall {k} (m :: k) (api' :: k -> *).
(GenericMode m, Generic (api' m), GSum (Rep (api' m))) =>
api' m -> GToSum (Rep (api' m))
namedHandlers = Rep (api' m) Any -> GToSum (Rep (api' m))
forall p. Rep (api' m) p -> GToSum (Rep (api' m))
forall {k} (f :: k -> *) (p :: k). GSum f => f p -> GToSum f
gtoHandler (Rep (api' m) Any -> GToSum (Rep (api' m)))
-> (api' m -> Rep (api' m) Any) -> api' m -> GToSum (Rep (api' m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. api' m -> Rep (api' m) Any
forall x. api' m -> Rep (api' m) x
forall a x. Generic a => a -> Rep a x
from