servant-jsonrpc (empty) → 1.0.0
raw patch · 4 files changed
+206/−0 lines, 4 filesdep +aesondep +basedep +servantsetup-changed
Dependencies added: aeson, base, servant
Files
- Setup.hs +2/−0
- changelog.md +3/−0
- servant-jsonrpc.cabal +36/−0
- src/Servant/JsonRpc.hs +165/−0
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,3 @@+# 1.0.0++First release
+ servant-jsonrpc.cabal view
@@ -0,0 +1,36 @@+cabal-version: 2.4++name: servant-jsonrpc+version: 1.0.0+author: Ian Shipman <ics@gambolingpangolin.com>+maintainer: Ian Shipman <ics@gambolingpangolin.com>++synopsis: JSON-RPC messages and endpoints+description:+ This module contains types that a programmer can use for JSON-RPC requests,+ server responses, and errors. It also contains two types which should be+ used in concert with servant to compose type level API specifications for+ JSON-RPC endpoints.++homepage: https://github.com/GambolingPangolin/servant-jsonrpc+license: ISC+category: Web+build-type: Simple++extra-source-files: changelog.md++source-repository head+ type: git+ location: https://github.com/GambolingPangolin/servant-jsonrpc.git++library+ default-language: Haskell2010+ hs-source-dirs: src++ exposed-modules:+ Servant.JsonRpc++ build-depends:+ aeson >= 1.3 && < 1.5+ , base >= 4.11 && < 4.13+ , servant >= 0.14 && < 0.17
+ src/Servant/JsonRpc.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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+ JsonRpc+ , JsonRpcNotification++ -- * JSON-RPC messages+ , Request (..)+ , JsonRpcResponse (..)+ , JsonRpcErr (..)++ -- * Type rewriting+ , JsonRpcEndpoint+ ) where+++import Control.Applicative (liftA3)+import Data.Aeson (FromJSON (..), ToJSON (..), Value (Null),+ object, withObject, (.:), (.:?), (.=))+import Data.Aeson.Types (Parser)+import Data.Maybe (isNothing)+import Data.Word (Word64)+import GHC.TypeLits (Symbol)+import Servant.API ((:>), JSON, 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) :)+++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"+++-- | 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)+++data JsonRpcErr e = JsonRpcErr+ { errorCode :: Int+ , errorMessage :: String+ , errorData :: Maybe e+ } deriving (Eq, Show)+++instance (FromJSON e, FromJSON r) => FromJSON (JsonRpcResponse e r) where+ parseJSON = withObject "Response" $ \obj -> do+ ix <- obj .: "id"+ version <- obj .:? "jsonrpc"+ result <- obj .:? "result"+ err <- obj .:? "error"+ versionGuard version $ pack ix result err++ where++ 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+ ]+++-- | 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 '[JSON] (Request p) :> Post '[JSON] (JsonRpcResponse e r)++ JsonRpcEndpoint (JsonRpcNotification m p)+ = ReqBody '[JSON] (Request p) :> Post '[JSON] NoContent