servant-jsonrpc-server 1.0.0 → 2.0.0

raw patch · 4 files changed

+171/−35 lines, 4 filesdep +containersdep ~aesondep ~servant-jsonrpcPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

Dependency ranges changed: aeson, servant-jsonrpc

API changes (from Hackage documentation)

Files

• LICENSE +28/−0
• changelog.md +4/−0
• servant-jsonrpc-server.cabal +9/−6
• src/Servant/Server/JsonRpc.hs +130/−29

@@ -0,0 +1,28 @@+Copyright 2020 Bitnomial, Inc.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+contributors may be used to endorse or promote products derived from+this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,3 +1,7 @@+# 2.0.0++The previous version was hopelessly broken.  This completely replaces it.+ # 1.0.0  First release

@@ -1,7 +1,7 @@ cabal-version:       2.4  name:                servant-jsonrpc-server-version:             1.0.0+version:             2.0.0 author:              Ian Shipman <ics@gambolingpangolin.com> maintainer:          Ian Shipman <ics@gambolingpangolin.com> @@ -9,8 +9,10 @@ description:     Use this package to define a servant server which exposes JSON-RPC over HTTP endpoints. -homepage:            https://github.com/GambolingPangolin/servant-jsonrpc-license:             ISC+homepage:            https://github.com/bitnomial/servant-jsonrpc+license:             BSD-3-Clause+license-file:        LICENSE+copyright:           Bitnomial, Inc. (c) 2020 category:            Web build-type:          Simple @@ -18,7 +20,7 @@  source-repository head   type:     git-  location: https://github.com/GambolingPangolin/servant-jsonrpc.git+  location: https://github.com/bitnomial/servant-jsonrpc.git  library   default-language:    Haskell2010@@ -28,9 +30,10 @@     Servant.Server.JsonRpc    build-depends:-      aeson                 >= 1.3          && < 2.0+      aeson                 >= 1.3          && < 1.5     , base                  >= 4.11         && < 4.13+    , containers            >= 0.5          && < 0.7     , mtl                   >= 2.2          && < 2.3     , servant               >= 0.14         && < 0.17-    , servant-jsonrpc       >= 1.0          && < 1.1+    , servant-jsonrpc       >= 1.0.1        && < 1.1     , servant-server        >= 0.14         && < 0.17

@@ -1,12 +1,13 @@ {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -15,51 +16,151 @@ -- -- This module provides support for writing handlers for JSON-RPC endpoints ----- > type Mul = JsonRpcEndpoint "mul" (Int, Int) String Int+-- > 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 @Mul) mulHandler+-- > server = serve (Proxy @(RawJsonRpc API)) $ addHandler :<|> mulHandler module Servant.Server.JsonRpc-    ( module Servant.JsonRpc+    ( serveJsonRpc+    , RouteJsonRpc (..)+    , module Servant.JsonRpc+    , PossibleContent+    , PossibleJsonRpcResponse     ) where --import           Control.Monad.Error.Class (throwError)-import           Data.Aeson                (FromJSON, ToJSON)-import           Data.Proxy                (Proxy (..))-import           GHC.TypeLits              (KnownSymbol)-import           Servant.API               (NoContent)-import           Servant.Server            (HasServer (..), err400)+import           Data.Aeson               (FromJSON (..), ToJSON (..), Value)+import           Data.Aeson.Types         (parseEither)+import           Data.Bifunctor           (bimap)+import           Data.Map.Strict          (Map)+import qualified Data.Map.Strict          as Map+import           Data.Proxy               (Proxy (..))+import           GHC.TypeLits             (KnownSymbol, symbolVal)+import           Servant.API              ((:<|>) (..), (:>), JSON,+                                           NoContent (..), Post, ReqBody)+import           Servant.API.ContentTypes (AllCTRender (..))+import           Servant.Server           (Handler, HasServer (..))  import           Servant.JsonRpc -instance (KnownSymbol method, FromJSON p, ToJSON e, ToJSON r)-    => HasServer (JsonRpc method p e r) context where -    type ServerT (JsonRpc method p e r) m = p -> m (Either (JsonRpcErr e) r)+-- | 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 -    route _ cx = route endpoint cx . fmap f++instance ToJSON a => AllCTRender '[JSON] (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 '[JSON] (Request Value)+   :> Post '[JSON] PossibleJsonRpcResponse+++instance RouteJsonRpc api => HasServer (RawJsonRpc api) context where+    type ServerT (RawJsonRpc api) m = RpcHandler api m+    route _ cx = route endpoint cx . fmap (serveJsonRpc pxa pxh)         where-        f x (Request _ p (Just ix)) = g ix <$> x p-        f _ _                       = throwError err400-        g ix (Right r) = Result ix r-        g ix (Left e)  = Errors (Just ix) e+        endpoint = Proxy @RawJsonRpcEndpoint+        pxa      = Proxy @api+        pxh      = Proxy @Handler -        endpoint = Proxy @(JsonRpcEndpoint (JsonRpc method p e r))+    hoistServerWithContext _ _ f x = hoistRpcRouter (Proxy @api) f x -    hoistServerWithContext _ _ f x p = f $ x p +-- | This internal class is how we accumulate a map of handlers for dispatch+class RouteJsonRpc a where+    type RpcHandler a (m :: * -> *)+    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 -instance (KnownSymbol method, FromJSON p)-    => HasServer (JsonRpcNotification method p) context where -    type ServerT (JsonRpcNotification method p) m = p -> m NoContent+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 } -    route _ cx = route endpoint cx . fmap f++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-        f x (Request _ p _) = x p-        endpoint = Proxy @(JsonRpcEndpoint (JsonRpcNotification method p))+        methodName = symbolVal $ Proxy @method+        onDecode   = fmap generalizeResponse . h -    hoistServerWithContext _ _ f x p = f $ x p+        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++        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++    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+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