diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +# 2.0.0 + +The previous version was hopelessly broken. This completely replaces it. + # 1.0.0 First release diff --git a/servant-jsonrpc-server.cabal b/servant-jsonrpc-server.cabal --- a/servant-jsonrpc-server.cabal +++ b/servant-jsonrpc-server.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: servant-jsonrpc-server -version: 1.0.0 +version: 2.0.0 author: Ian Shipman maintainer: Ian Shipman @@ -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 diff --git a/src/Servant/Server/JsonRpc.hs b/src/Servant/Server/JsonRpc.hs --- a/src/Servant/Server/JsonRpc.hs +++ b/src/Servant/Server/JsonRpc.hs @@ -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