servant-jsonrpc-server 2.1.2 → 2.2.0
raw patch · 4 files changed
+160/−140 lines, 4 filesdep ~aesondep ~containersdep ~servantsetup-changed
Dependency ranges changed: aeson, containers, servant, servant-jsonrpc, servant-server
Files
- Setup.hs +1/−0
- changelog.md +4/−0
- servant-jsonrpc-server.cabal +6/−6
- src/Servant/Server/JsonRpc.hs +149/−134
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
changelog.md view
@@ -1,3 +1,7 @@+# 2.2.0++* Accept either `application/json` or `application/json-rpc` from the client and let the client choose the content type for a response+ # 2.1.1 * Relax version bounds
servant-jsonrpc-server.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: servant-jsonrpc-server-version: 2.1.2+version: 2.2.0 author: Ian Shipman <ics@gambolingpangolin.com> maintainer: Ian Shipman <ics@gambolingpangolin.com> @@ -30,9 +30,9 @@ Servant.Server.JsonRpc build-depends:- aeson >= 1.3 && < 2.2+ aeson >= 1.3 && < 2.3 , base >= 4.11 && < 5.0- , containers >= 0.5 && < 0.7- , servant >= 0.14 && < 0.20- , servant-jsonrpc >= 1.0.1 && < 1.2- , servant-server >= 0.14 && < 0.20+ , containers >= 0.5 && < 0.8+ , servant >= 0.14 && < 0.21+ , servant-jsonrpc >= 1.2 && < 1.3+ , servant-server >= 0.14 && < 0.21
src/Servant/Server/JsonRpc.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} #if MIN_VERSION_servant_server(0,18,0) {-# LANGUAGE UndecidableInstances #-}@@ -16,169 +16,184 @@ {-# 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+{- |+Module: Servant.Server.JsonRpc -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 (..))+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 (.++))+import Servant.Server (+ DefaultErrorFormatters,+ ErrorFormatters,+ Handler,+ HasContextEntry,+ HasServer (..),+ type (.++),+ ) #elif MIN_VERSION_servant_server(0,14,0)-import Servant.Server (Handler, HasServer (..))+import Servant.Server (Handler, HasServer (..)) #endif -import Servant.JsonRpc-+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.+{- | 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 px h = \case- SomeContent x -> handleAcceptH px h x- EmptyContent -> handleAcceptH px h NoContent-+instance (ToJSON a) => AllCTRender '[JSONRPC] (PossibleContent a) where+ handleAcceptH px h = \case+ SomeContent x -> handleAcceptH px h x+ EmptyContent -> handleAcceptH px h NoContent type PossibleJsonRpcResponse = PossibleContent (JsonRpcResponse Value Value) --type RawJsonRpcEndpoint- = ReqBody '[JSONRPC] (Request Value)- :> Post '[JSONRPC] PossibleJsonRpcResponse+instance ToJSON a => ToJSON (PossibleContent a) where+ toJSON = \case+ SomeContent x -> toJSON x+ EmptyContent -> 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 api) context where+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 api) context where+ instance (RouteJsonRpc api) => HasServer (RawJsonRpc ctype api) context where #endif- type ServerT (RawJsonRpc api) m = RpcHandler api m- route _ cx = route endpoint cx . fmap (serveJsonRpc pxa pxh)- where- endpoint = Proxy @RawJsonRpcEndpoint- pxa = Proxy @api- pxh = Proxy @Handler-- hoistServerWithContext _ _ f x = hoistRpcRouter (Proxy @api) f x+ type ServerT (RawJsonRpc ctype api) m = RpcHandler api m+ route _ cx = route endpoint cx . fmap (serveJsonRpc pxa pxh)+ where+ endpoint = Proxy @RawJsonRpcEndpoint+ pxa = Proxy @api+ pxh = Proxy @Handler + hoistServerWithContext _ _ f x = hoistRpcRouter (Proxy @api) f 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-+ 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 ::+ (ToJSON e, ToJSON r) =>+ Either (JsonRpcErr e) r ->+ Either (JsonRpcErr Value) Value generalizeResponse = bimap repack toJSON- where- repack e = e { errorData = toJSON <$> errorData e }-+ where+ repack e = e{errorData = toJSON <$> errorData e} onDecodeFail :: String -> JsonRpcErr e onDecodeFail msg = JsonRpcErr invalidParamsCode msg 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 _ _ h = Map.fromList [ (methodName, h') ]- where- methodName = symbolVal $ Proxy @method- onDecode = fmap generalizeResponse . h+ type RpcHandler (JsonRpc method p e r) m = p -> m (Either (JsonRpcErr e) r) - h' = fmap SomeContent- . either (return . Left . onDecodeFail) onDecode- . parseEither parseJSON+ jsonRpcRouter _ _ h = Map.fromList [(methodName, h')]+ where+ methodName = symbolVal $ Proxy @method+ onDecode = fmap generalizeResponse . h - hoistRpcRouter _ f x = f . x+ h' =+ fmap SomeContent+ . either (return . Left . onDecodeFail) onDecode+ . parseEither parseJSON + hoistRpcRouter _ f x = f . x instance (KnownSymbol method, FromJSON p) => RouteJsonRpc (JsonRpcNotification method p) where- type RpcHandler (JsonRpcNotification method p) m = p -> m NoContent-- jsonRpcRouter _ _ h = Map.fromList [ (methodName, h') ]- where- methodName = symbolVal $ Proxy @method- onDecode x = EmptyContent <$ h x+ type RpcHandler (JsonRpcNotification method p) m = p -> m NoContent - h' = either (return . SomeContent . Left . onDecodeFail) onDecode- . parseEither parseJSON+ jsonRpcRouter _ _ h = Map.fromList [(methodName, h')]+ where+ methodName = symbolVal $ Proxy @method+ onDecode x = EmptyContent <$ h x - hoistRpcRouter _ f x = f . x+ h' =+ either (return . SomeContent . Left . onDecodeFail) onDecode+ . parseEither parseJSON + hoistRpcRouter _ f x = f . x instance (RouteJsonRpc a, RouteJsonRpc b) => RouteJsonRpc (a :<|> b) where- type RpcHandler (a :<|> b) m = RpcHandler a m :<|> RpcHandler b m-- jsonRpcRouter _ pxm (ha :<|> hb) = jsonRpcRouter pxa pxm ha <> jsonRpcRouter pxb pxm hb- where- pxa = Proxy @a- pxb = Proxy @b+ type RpcHandler (a :<|> b) m = RpcHandler a m :<|> RpcHandler b m - hoistRpcRouter _ f (x :<|> y) = hoistRpcRouter (Proxy @a) f x :<|> hoistRpcRouter (Proxy @b) f y+ jsonRpcRouter _ pxm (ha :<|> hb) = jsonRpcRouter pxa pxm ha <> jsonRpcRouter pxb pxm hb+ where+ pxa = Proxy @a+ pxb = Proxy @b + hoistRpcRouter _ f (x :<|> y) = hoistRpcRouter (Proxy @a) f x :<|> hoistRpcRouter (Proxy @b) f 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+{- | 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 px pxm hs (Request m v ix')- | Just h <- Map.lookup m hmap- = h v >>= \case- SomeContent (Right x) | Just ix <- ix' -> return . SomeContent $ Result ix x- | otherwise -> return . SomeContent $ Errors ix' invalidRequest- SomeContent (Left e) -> return . SomeContent $ Errors ix' e- EmptyContent -> return EmptyContent- | otherwise = return . SomeContent $ Errors ix' missingMethod- where- missingMethod = JsonRpcErr methodNotFoundCode ("Unknown method: " <> m) Nothing- hmap = jsonRpcRouter px pxm hs- invalidRequest = JsonRpcErr invalidRequestCode "Missing id" Nothing+ | Just h <- Map.lookup m hmap =+ h v >>= \case+ SomeContent (Right x)+ | Just ix <- ix' -> return . SomeContent $ Result ix x+ | otherwise -> return . SomeContent $ Errors ix' invalidRequest+ SomeContent (Left e) -> return . SomeContent $ Errors ix' e+ EmptyContent -> return EmptyContent+ | otherwise = return . SomeContent $ Errors ix' missingMethod+ where+ missingMethod = JsonRpcErr methodNotFoundCode ("Unknown method: " <> m) Nothing+ hmap = jsonRpcRouter px pxm hs+ invalidRequest = JsonRpcErr invalidRequestCode "Missing id" Nothing