diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +# 1.2.0 + +* Adds a type parameter to the `JsonRpc` endpoint wrapper to enable the user to choose the content-type in the derived client. + # 1.1.1 * Allow "application/json-rpc" as the content type diff --git a/servant-jsonrpc.cabal b/servant-jsonrpc.cabal --- a/servant-jsonrpc.cabal +++ b/servant-jsonrpc.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: servant-jsonrpc -version: 1.1.1 +version: 1.2.0 author: Ian Shipman maintainer: Ian Shipman @@ -33,8 +33,8 @@ Servant.JsonRpc build-depends: - aeson >= 1.3 && < 2.1 + aeson >= 1.3 && < 2.3 , base >= 4.11 && < 5.0 , http-media >= 0.7.1.3 && < 0.9 - , servant >= 0.14 && < 0.20 - , text >= 1.2 && < 2.1 + , servant >= 0.14 && < 0.21 + , text >= 1.2 && < 2.2 diff --git a/src/Servant/JsonRpc.hs b/src/Servant/JsonRpc.hs --- a/src/Servant/JsonRpc.hs +++ b/src/Servant/JsonRpc.hs @@ -1,221 +1,216 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} --- | --- Module: Servant.JsonRpc --- --- Work with JSON-RPC protocol messages at both type and value level. --- --- > type Mul = JsonRpc "mul" (Int, Int) String Int --- > --- > req :: Request (Int, Int) --- > req = Request "mul" (3, 5) (Just 0) --- > --- > rsp :: JsonRpcResponse String Int --- > rsp = Result 0 15 -module Servant.JsonRpc - ( - -- * API specification types - RawJsonRpc - , JsonRpc - , JsonRpcNotification - , JSONRPC +{- | +Module: Servant.JsonRpc - -- * JSON-RPC messages - , Request (..) - , JsonRpcResponse (..) - , JsonRpcErr (..) +Work with JSON-RPC protocol messages at both type and value level. - -- ** Standard error codes - , parseErrorCode - , invalidRequestCode - , methodNotFoundCode - , invalidParamsCode - , internalErrorCode +> type Mul = JsonRpc "mul" (Int, Int) String Int +> +> req :: Request (Int, Int) +> req = Request "mul" (3, 5) (Just 0) +> +> rsp :: JsonRpcResponse String Int +> rsp = Result 0 15 +-} +module Servant.JsonRpc ( + -- * API specification types + RawJsonRpc, + JsonRpc, + JsonRpcNotification, + JSONRPC, - -- * Type rewriting - , JsonRpcEndpoint - ) where + -- * JSON-RPC messages + Request (..), + JsonRpcResponse (..), + JsonRpcErr (..), + -- ** Standard error codes + parseErrorCode, + invalidRequestCode, + methodNotFoundCode, + invalidParamsCode, + internalErrorCode, -import Control.Applicative (liftA3, (<|>)) -import Data.Aeson (FromJSON (..), ToJSON (..), Value (Null), - object, withObject, (.:), (.:?), (.=)) -import Data.Aeson.Types (Parser) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (isNothing) -import Data.Proxy (Proxy (..)) -import Data.Text.Read (decimal) -import Data.Word (Word64) -import GHC.TypeLits (Symbol) -import Network.HTTP.Media ((//)) -import Servant.API (Accept (..), JSON, MimeRender (..), - MimeUnrender (..), NoContent, Post, - ReqBody, (:>)) + -- * Type rewriting + JsonRpcEndpoint, +) where +import Control.Applicative (liftA3, (<|>)) +import Data.Aeson ( + FromJSON (..), + ToJSON (..), + Value (Null), + object, + withObject, + (.:), + (.:?), + (.=), + ) +import Data.Aeson.Types (Parser) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (isNothing) +import Data.Proxy (Proxy (..)) +import Data.Text.Read (decimal) +import Data.Word (Word64) +import GHC.TypeLits (Symbol) +import Network.HTTP.Media ((//)) +import Servant.API ( + Accept (..), + JSON, + MimeRender (..), + MimeUnrender (..), + NoContent, + Post, + ReqBody, + (:>), + ) -- | Client messages data Request p - = Request - { method :: String - , params :: p - - -- | should be omitted only if the message is a notification, with no response content - , requestId :: Maybe Word64 - } deriving (Eq, Show) - - -instance ToJSON p => ToJSON (Request p) where - toJSON (Request m p ix) = - object - . maybe id (onValue "id") ix - $ [ "jsonrpc" .= ("2.0" :: String) - , "method" .= m - , "params" .= p - ] - - where - onValue n v = ((n .= v) :) - + = Request + { method :: String + , params :: p + , requestId :: Maybe Word64 + -- ^ should be omitted only if the message is a notification, with no response content + } + deriving (Eq, Show) -instance FromJSON p => FromJSON (Request p) where - parseJSON = withObject "JsonRpc Request" $ \obj -> do - ix <- obj .:? "id" - m <- obj .: "method" - p <- obj .: "params" - v <- obj .: "jsonrpc" +instance (ToJSON p) => ToJSON (Request p) where + toJSON (Request m p ix) = + object + . maybe id (onValue "id") ix + $ [ "jsonrpc" .= ("2.0" :: String) + , "method" .= m + , "params" .= p + ] + where + onValue n v = ((n .= v) :) - versionGuard v . pure $ Request m p ix +instance (FromJSON p) => FromJSON (Request p) where + parseJSON = withObject "JsonRpc Request" $ \obj -> do + ix <- obj .:? "id" + m <- obj .: "method" + p <- obj .: "params" + v <- obj .: "jsonrpc" + versionGuard v . pure $ Request m p ix versionGuard :: Maybe String -> Parser a -> Parser a versionGuard v x - | v == Just "2.0" = x - | isNothing v = x - | otherwise = fail "unknown version" - + | v == Just "2.0" = x + | isNothing v = x + | otherwise = fail "unknown version" --- | Server messages. An 'Ack' is a message which refers to a 'Request' but --- both its "errors" and "result" keys are null +{- | Server messages. An 'Ack' is a message which refers to a 'Request' but +both its "errors" and "result" keys are null +-} data JsonRpcResponse e r - = Result Word64 r - | Ack Word64 - | Errors (Maybe Word64) (JsonRpcErr e) - deriving (Eq, Show) - + = Result Word64 r + | Ack Word64 + | Errors (Maybe Word64) (JsonRpcErr e) + deriving (Eq, Show) data JsonRpcErr e = JsonRpcErr - { errorCode :: Int - , errorMessage :: String - , errorData :: Maybe e - } deriving (Eq, Show) - + { errorCode :: Int + , errorMessage :: String + , errorData :: Maybe e + } + deriving (Eq, Show) parseErrorCode :: Int parseErrorCode = -32700 - invalidRequestCode :: Int invalidRequestCode = -32600 - methodNotFoundCode :: Int methodNotFoundCode = -32601 - invalidParamsCode :: Int invalidParamsCode = -32602 - internalErrorCode :: Int internalErrorCode = -32603 - instance (FromJSON e, FromJSON r) => FromJSON (JsonRpcResponse e r) where - parseJSON = withObject "Response" $ \obj -> do - ix <- obj .: "id" <|> (obj .: "id" >>= parseDecimalString) - version <- obj .:? "jsonrpc" - result <- obj .:? "result" - err <- obj .:? "error" - versionGuard version $ pack ix result err - - where - - parseDecimalString = either fail (pure . fmap fst) . traverse decimal - - pack (Just ix) (Just r) Nothing = pure $ Result ix r - pack ix Nothing (Just e) = Errors ix <$> parseErr e - pack (Just ix) Nothing Nothing = pure $ Ack ix - pack _ _ _ = fail "invalid response" + parseJSON = withObject "Response" $ \obj -> do + ix <- obj .: "id" <|> (obj .: "id" >>= parseDecimalString) + version <- obj .:? "jsonrpc" + result <- obj .:? "result" + err <- obj .:? "error" + versionGuard version $ pack ix result err + where + parseDecimalString = either fail (pure . fmap fst) . traverse decimal - parseErr = withObject "Error" $ - liftA3 JsonRpcErr <$> (.: "code") <*> (.: "message") <*> (.:? "data") + pack (Just ix) (Just r) Nothing = pure $ Result ix r + pack ix Nothing (Just e) = Errors ix <$> parseErr e + pack (Just ix) Nothing Nothing = pure $ Ack ix + pack _ _ _ = fail "invalid response" + parseErr = + withObject "Error" $ + liftA3 JsonRpcErr <$> (.: "code") <*> (.: "message") <*> (.:? "data") instance (ToJSON e, ToJSON r) => ToJSON (JsonRpcResponse e r) where - toJSON (Result ix r) = - object [ "jsonrpc" .= ("2.0" :: String) - , "result" .= r - , "id" .= ix - ] - - toJSON (Ack ix) = - object [ "jsonrpc" .= ("2.0" :: String) - , "id" .= ix - , "result" .= Null - , "error" .= Null - ] - - toJSON (Errors ix (JsonRpcErr c msg err)) = - object [ "jsonrpc" .= ("2.0" :: String) - , "id" .= ix - , "error" .= detail - ] - - where - detail = object [ "code" .= c - , "message" .= msg - , "data" .= err - ] - + toJSON (Result ix r) = + object + [ "jsonrpc" .= ("2.0" :: String) + , "result" .= r + , "id" .= ix + ] + toJSON (Ack ix) = + object + [ "jsonrpc" .= ("2.0" :: String) + , "id" .= ix + , "result" .= Null + , "error" .= Null + ] + toJSON (Errors ix (JsonRpcErr c msg err)) = + object + [ "jsonrpc" .= ("2.0" :: String) + , "id" .= ix + , "error" .= detail + ] + where + detail = + object + [ "code" .= c + , "message" .= msg + , "data" .= err + ] -- | A JSON RPC server handles any number of methods. Represent this at the type level using this type. -data RawJsonRpc api - +data RawJsonRpc ctype api -- | JSON-RPC endpoints which respond with a result data JsonRpc (method :: Symbol) p e r - -- | JSON-RPC endpoints which do not respond data JsonRpcNotification (method :: Symbol) p - -type family JsonRpcEndpoint a where - JsonRpcEndpoint (JsonRpc m p e r) - = ReqBody '[JSONRPC] (Request p) :> Post '[JSONRPC] (JsonRpcResponse e r) - - JsonRpcEndpoint (JsonRpcNotification m p) - = ReqBody '[JSONRPC] (Request p) :> Post '[JSONRPC] NoContent +type family JsonRpcEndpoint ctype a where + JsonRpcEndpoint ctype (JsonRpc m p e r) = + ReqBody '[ctype] (Request p) :> Post '[ctype] (JsonRpcResponse e r) + JsonRpcEndpoint ctype (JsonRpcNotification m p) = + ReqBody '[ctype] (Request p) :> Post '[ctype] NoContent -- | The JSON-RPC content type data JSONRPC - instance Accept JSONRPC where - contentTypes _ = "application" // "json-rpc" :| ["application" // "json"] - - -instance ToJSON a => MimeRender JSONRPC a where - mimeRender _ = mimeRender (Proxy @JSON) + contentTypes _ = "application" // "json-rpc" :| ["application" // "json"] +instance (ToJSON a) => MimeRender JSONRPC a where + mimeRender _ = mimeRender (Proxy @JSON) -instance FromJSON a => MimeUnrender JSONRPC a where - mimeUnrender _ = mimeUnrender (Proxy @JSON) +instance (FromJSON a) => MimeUnrender JSONRPC a where + mimeUnrender _ = mimeUnrender (Proxy @JSON)