servant-jsonrpc 1.1.1 → 1.2.0

raw patch · 4 files changed

+167/−167 lines, 4 filesdep ~aesondep ~servantdep ~textsetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, servant, text

API changes (from Hackage documentation)

Files

• Setup.hs +1/−0
• changelog.md +4/−0
• servant-jsonrpc.cabal +4/−4
• src/Servant/JsonRpc.hs +158/−163

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -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

@@ -1,7 +1,7 @@ cabal-version:       2.4  name:                servant-jsonrpc-version:             1.1.1+version:             1.2.0 author:              Ian Shipman <ics@gambolingpangolin.com> maintainer:          Ian Shipman <ics@gambolingpangolin.com> @@ -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

@@ -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)