{-# 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,
                                           (:<|>) (..), (:>))
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 -> forall (list :: [*]) a.
AllCTRender list a =>
Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
handleAcceptH Proxy '[JSONRPC]
px AcceptHeader
h a
x
        PossibleContent a
EmptyContent  -> 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)


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


#if MIN_VERSION_servant_server(0,18,0)
instance (RouteJsonRpc api, HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters) => HasServer (RawJsonRpc api) context where
#elif MIN_VERSION_servant_server(0,14,0)
instance RouteJsonRpc api => HasServer (RawJsonRpc api) context where
#endif
    type ServerT (RawJsonRpc api) m = RpcHandler api m
    route :: forall env.
Proxy (RawJsonRpc api)
-> Context context
-> Delayed env (Server (RawJsonRpc api))
-> Router env
route Proxy (RawJsonRpc api)
_ Context context
cx = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 {k} (t :: k). Proxy t
Proxy @RawJsonRpcEndpoint
        pxa :: Proxy api
pxa      = forall {k} (t :: k). Proxy t
Proxy @api
        pxh :: Proxy Handler
pxh      = forall {k} (t :: k). Proxy t
Proxy @Handler

    hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (RawJsonRpc api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (RawJsonRpc api) m
-> ServerT (RawJsonRpc api) n
hoistServerWithContext Proxy (RawJsonRpc api)
_ Proxy context
_ forall x. m x -> n x
f ServerT (RawJsonRpc api) m
x = forall a (m :: * -> *) (n :: * -> *).
RouteJsonRpc a =>
Proxy a
-> (forall x. m x -> n x) -> RpcHandler a m -> RpcHandler a n
hoistRpcRouter (forall {k} (t :: k). Proxy t
Proxy @api) forall x. m x -> n x
f ServerT (RawJsonRpc 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 = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall {a}. ToJSON a => JsonRpcErr a -> JsonRpcErr Value
repack forall a. ToJSON a => a -> Value
toJSON
    where
    repack :: JsonRpcErr a -> JsonRpcErr Value
repack JsonRpcErr a
e = JsonRpcErr a
e { errorData :: Maybe Value
errorData = forall a. ToJSON a => a -> Value
toJSON forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. JsonRpcErr e -> Maybe e
errorData JsonRpcErr a
e }


onDecodeFail :: String -> JsonRpcErr e
onDecodeFail :: forall e. String -> JsonRpcErr e
onDecodeFail String
msg = forall e. Int -> String -> Maybe e -> JsonRpcErr e
JsonRpcErr Int
invalidParamsCode String
msg 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 = 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 = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @method
        onDecode :: p -> m (Either (JsonRpcErr Value) Value)
onDecode   = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e r.
(ToJSON e, ToJSON r) =>
Either (JsonRpcErr e) r -> Either (JsonRpcErr Value) Value
generalizeResponse forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcHandler (JsonRpc method p e r) m
h

        h' :: Value -> m (PossibleContent (Either (JsonRpcErr Value) Value))
h' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> PossibleContent a
SomeContent
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. String -> JsonRpcErr e
onDecodeFail) p -> m (Either (JsonRpcErr Value) Value)
onDecode
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Parser b) -> a -> Either String b
parseEither 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 = forall x. m x -> n x
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcHandler (JsonRpc method p e r) m
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 = 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 = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @method
        onDecode :: p -> m (PossibleContent (Either (JsonRpcErr Value) Value))
onDecode p
x = forall a. PossibleContent a
EmptyContent forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ RpcHandler (JsonRpcNotification method p) m
h p
x

        h' :: Value -> m (PossibleContent (Either (JsonRpcErr Value) Value))
h' = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> PossibleContent a
SomeContent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. String -> JsonRpcErr e
onDecodeFail) p -> m (PossibleContent (Either (JsonRpcErr Value) Value))
onDecode
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Parser b) -> a -> Either String b
parseEither 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 = forall x. m x -> n x
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. RpcHandler (JsonRpcNotification method p) m
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) = forall a (m :: * -> *).
(RouteJsonRpc a, 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 forall a. Semigroup a => a -> a -> a
<> forall a (m :: * -> *).
(RouteJsonRpc a, Monad m) =>
Proxy a
-> Proxy m
-> RpcHandler a 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 {k} (t :: k). Proxy t
Proxy @a
        pxb :: Proxy b
pxb = 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) = forall a (m :: * -> *) (n :: * -> *).
RouteJsonRpc a =>
Proxy a
-> (forall x. m x -> n x) -> RpcHandler a m -> RpcHandler a n
hoistRpcRouter (forall {k} (t :: k). Proxy t
Proxy @a) forall x. m x -> n x
f RpcHandler a m
x forall a b. a -> b -> a :<|> b
:<|> forall a (m :: * -> *) (n :: * -> *).
RouteJsonRpc a =>
Proxy a
-> (forall x. m x -> n x) -> RpcHandler a m -> RpcHandler a n
hoistRpcRouter (forall {k} (t :: k). Proxy t
Proxy @b) 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 <- 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SomeContent (Right Value
x) | Just Word64
ix <- Maybe Word64
ix' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> PossibleContent a
SomeContent forall a b. (a -> b) -> a -> b
$ forall e r. Word64 -> r -> JsonRpcResponse e r
Result Word64
ix Value
x
                              | Bool
otherwise      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> PossibleContent a
SomeContent forall a b. (a -> b) -> a -> b
$ forall e r. Maybe Word64 -> JsonRpcErr e -> JsonRpcResponse e r
Errors Maybe Word64
ix' forall {e}. JsonRpcErr e
invalidRequest
        SomeContent (Left JsonRpcErr Value
e)                   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> PossibleContent a
SomeContent forall a b. (a -> b) -> a -> b
$ forall e r. Maybe Word64 -> JsonRpcErr e -> JsonRpcResponse e r
Errors Maybe Word64
ix' JsonRpcErr Value
e
        PossibleContent (Either (JsonRpcErr Value) Value)
EmptyContent                           -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PossibleContent a
EmptyContent
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> PossibleContent a
SomeContent forall a b. (a -> b) -> a -> b
$ forall e r. Maybe Word64 -> JsonRpcErr e -> JsonRpcResponse e r
Errors Maybe Word64
ix' JsonRpcErr Value
missingMethod
    where
    missingMethod :: JsonRpcErr Value
missingMethod  = forall e. Int -> String -> Maybe e -> JsonRpcErr e
JsonRpcErr Int
methodNotFoundCode (String
"Unknown method: " forall a. Semigroup a => a -> a -> a
<> String
m) forall a. Maybe a
Nothing
    hmap :: Map
  String
  (Value -> m (PossibleContent (Either (JsonRpcErr Value) Value)))
hmap           = forall a (m :: * -> *).
(RouteJsonRpc a, 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 = forall e. Int -> String -> Maybe e -> JsonRpcErr e
JsonRpcErr Int
invalidRequestCode String
"Missing id" forall a. Maybe a
Nothing