-- |
-- Module      : Data.Conduit.JsonRpc.Server
-- Copyright   : (c) 2012-2021 Gabriele Sales <gbrsales@gmail.com>
--
-- JSON-RPC 2.0 server 'Conduit'.

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Conduit.JsonRpc.Server
  ( serve )
where

import           Control.Applicative
import           Control.Monad                       ((>=>))
import           Control.Monad.Trans                 (lift)
import           Control.Monad.Trans.State
import           Data.Aeson                          hiding (Error)
import           Data.Aeson.Types                    (parseMaybe)
import           Data.Attoparsec.ByteString
import           Data.ByteString                     (ByteString)
import qualified Data.ByteString                     as B
import qualified Data.ByteString.Lazy                as L
import           Data.Conduit
import           Data.Conduit.JsonRpc.Internal.Types
import           Data.Conduit.JsonRpc.Methods        hiding (method)
import qualified Data.Conduit.List                   as C
import           Data.Text                           (Text)
import           Prelude                             hiding (lookup)


data Processed a = Correct !a
                 | InvalidRequest
                 | ParseError

{- |
A 'Conduit' that consumes a stream of JSON-RPC requests, tries to process them
with the provided 'Methods' and writes back the results.

Current limitations:

  * does not support batch requests

  * it is not possible to set the @data@ attribute of error objects
-}
serve :: (Applicative m, Monad m)
      => Methods m -> ConduitT ByteString ByteString m ()
serve :: Methods m -> ConduitT ByteString ByteString m ()
serve Methods m
methods = ConduitM ByteString (Processed (Request Value)) m ()
forall (m :: * -> *).
Monad m =>
ConduitM ByteString (Processed (Request Value)) m ()
parseRequests
             ConduitM ByteString (Processed (Request Value)) m ()
-> ConduitM (Processed (Request Value)) ByteString m ()
-> ConduitT ByteString ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Processed (Request Value) -> m [ByteString])
-> ConduitM (Processed (Request Value)) ByteString m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m [b]) -> ConduitT a b m ()
C.concatMapM ((Response Value -> [ByteString])
-> m (Response Value) -> m [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response Value -> [ByteString]
encodeResponse (m (Response Value) -> m [ByteString])
-> (Processed (Request Value) -> m (Response Value))
-> Processed (Request Value)
-> m [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Methods m -> Processed (Request Value) -> m (Response Value)
forall (m :: * -> *).
Monad m =>
Methods m -> Processed (Request Value) -> m (Response Value)
handleRequest Methods m
methods)


parseRequests :: (Monad m)
              => ConduitM ByteString (Processed (Request Value)) m ()
parseRequests :: ConduitM ByteString (Processed (Request Value)) m ()
parseRequests = StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
-> Maybe (ByteString -> Result Value)
-> ConduitM ByteString (Processed (Request Value)) m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
loop Maybe (ByteString -> Result Value)
forall a. Maybe a
Nothing
  where
    loop :: StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
loop = ConduitT
  ByteString (Processed (Request Value)) m (Maybe ByteString)
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     (Maybe ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ConduitT
  ByteString (Processed (Request Value)) m (Maybe ByteString)
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  (Maybe ByteString)
-> (Maybe ByteString
    -> StateT
         (Maybe (ByteString -> Result Value))
         (ConduitT ByteString (Processed (Request Value)) m)
         ())
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
-> (ByteString
    -> StateT
         (Maybe (ByteString -> Result Value))
         (ConduitT ByteString (Processed (Request Value)) m)
         ())
-> Maybe ByteString
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
flush ByteString
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
process

    process :: ByteString
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
process = ByteString
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     (Result Value)
runParser (ByteString
 -> StateT
      (Maybe (ByteString -> Result Value))
      (ConduitT ByteString (Processed (Request Value)) m)
      (Result Value))
-> (Result Value
    -> StateT
         (Maybe (ByteString -> Result Value))
         (ConduitT ByteString (Processed (Request Value)) m)
         ())
-> ByteString
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Result Value
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
handle

    flush :: StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
flush = do
      Maybe (ByteString -> Result Value)
p <- StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  (Maybe (ByteString -> Result Value))
forall (m :: * -> *) s. Monad m => StateT s m s
get
      case Maybe (ByteString -> Result Value)
p of
        Maybe (ByteString -> Result Value)
Nothing -> ()
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ByteString -> Result Value
k  -> Result Value
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
handle (ByteString -> Result Value
k ByteString
B.empty)

    runParser :: ByteString
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     (Result Value)
runParser ByteString
chunk = do
      Maybe (ByteString -> Result Value)
p <- StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  (Maybe (ByteString -> Result Value))
forall a.
StateT
  (Maybe a)
  (ConduitT ByteString (Processed (Request Value)) m)
  (Maybe a)
getPartialParser
      Result Value
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     (Result Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result Value
 -> StateT
      (Maybe (ByteString -> Result Value))
      (ConduitT ByteString (Processed (Request Value)) m)
      (Result Value))
-> Result Value
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     (Result Value)
forall a b. (a -> b) -> a -> b
$ case Maybe (ByteString -> Result Value)
p of
                 Maybe (ByteString -> Result Value)
Nothing -> Parser Value -> ByteString -> Result Value
forall a. Parser a -> ByteString -> Result a
parse Parser Value
json' ByteString
chunk
                 Just ByteString -> Result Value
k  -> ByteString -> Result Value
k ByteString
chunk

    getPartialParser :: StateT
  (Maybe a)
  (ConduitT ByteString (Processed (Request Value)) m)
  (Maybe a)
getPartialParser = StateT
  (Maybe a)
  (ConduitT ByteString (Processed (Request Value)) m)
  (Maybe a)
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT
  (Maybe a)
  (ConduitT ByteString (Processed (Request Value)) m)
  (Maybe a)
-> StateT
     (Maybe a) (ConduitT ByteString (Processed (Request Value)) m) ()
-> StateT
     (Maybe a)
     (ConduitT ByteString (Processed (Request Value)) m)
     (Maybe a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Maybe a
-> StateT
     (Maybe a) (ConduitT ByteString (Processed (Request Value)) m) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Maybe a
forall a. Maybe a
Nothing

    handle :: Result Value
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
handle Fail{}        = ConduitM ByteString (Processed (Request Value)) m ()
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Processed (Request Value)
-> ConduitM ByteString (Processed (Request Value)) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Processed (Request Value)
forall a. Processed a
ParseError)
    handle (Partial ByteString -> Result Value
k)   = Maybe (ByteString -> Result Value)
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put ((ByteString -> Result Value) -> Maybe (ByteString -> Result Value)
forall a. a -> Maybe a
Just ByteString -> Result Value
k) StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
loop
    handle (Done ByteString
rest Value
r) = do
      ConduitM ByteString (Processed (Request Value)) m ()
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Value -> ConduitM ByteString (Processed (Request Value)) m ()
forall (m :: * -> *) a i.
(Monad m, FromJSON a) =>
Value -> ConduitT i (Processed a) m ()
yieldResponse Value
r)
      if ByteString -> Bool
B.null ByteString
rest
         then StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
loop
         else ByteString
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
process ByteString
rest

    yieldResponse :: Value -> ConduitT i (Processed a) m ()
yieldResponse Value
r = Processed a -> ConduitT i (Processed a) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Processed a -> ConduitT i (Processed a) m ())
-> Processed a -> ConduitT i (Processed a) m ()
forall a b. (a -> b) -> a -> b
$ case (Value -> Parser a) -> Value -> Maybe a
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
r of
                                Maybe a
Nothing -> Processed a
forall a. Processed a
InvalidRequest
                                Just a
r' -> a -> Processed a
forall a. a -> Processed a
Correct a
r'

handleRequest :: Monad m
              => Methods m
              -> Processed (Request Value)
              -> m (Response Value)
handleRequest :: Methods m -> Processed (Request Value) -> m (Response Value)
handleRequest Methods m
_       Processed (Request Value)
InvalidRequest    = m (Response Value)
forall (m :: * -> *). Monad m => m (Response Value)
invalidRequest
handleRequest Methods m
_       Processed (Request Value)
ParseError        = m (Response Value)
forall (m :: * -> *). Monad m => m (Response Value)
parseError
handleRequest Methods m
methods (Correct Request Value
request) =
  case Methods m -> Text -> Maybe (Method m)
forall (m :: * -> *). Methods m -> Text -> Maybe (Method m)
lookup Methods m
methods (Request Value -> Text
forall a. Request a -> Text
reqMethod Request Value
request) of
    Maybe (Method m)
Nothing -> Value -> m (Response Value)
forall (m :: * -> *). Monad m => Value -> m (Response Value)
methodNotFound (Request Value -> Value
forall a. Request a -> Value
reqId Request Value
request)
    Just Method m
m  -> Method m -> Request Value -> m (Response Value)
forall (m :: * -> *).
(Applicative m, Monad m) =>
Method m -> Request Value -> m (Response Value)
runMethod Method m
m Request Value
request

runMethod :: (Applicative m, Monad m)
          => Method m
          -> Request Value
          -> m (Response Value)
runMethod :: Method m -> Request Value -> m (Response Value)
runMethod (Method i -> m (Either MethodError o)
f) Request Value
request = do
  let ri :: Value
ri = Request Value -> Value
forall a. Request a -> Value
reqId Request Value
request
  case (Value -> Parser i) -> Value -> Maybe i
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser i
forall a. FromJSON a => Value -> Parser a
parseJSON (Request Value -> Value
forall a. Request a -> a
reqParams Request Value
request) of
    Maybe i
Nothing -> Value -> m (Response Value)
forall (m :: * -> *). Monad m => Value -> m (Response Value)
invalidParams Value
ri
    Just i
ps -> Value -> Either MethodError o -> Response Value
forall a.
ToJSON a =>
Value -> Either MethodError a -> Response Value
processResult Value
ri (Either MethodError o -> Response Value)
-> m (Either MethodError o) -> m (Response Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> i -> m (Either MethodError o)
f i
ps

processResult :: (ToJSON a) => Value -> Either MethodError a -> Response Value
processResult :: Value -> Either MethodError a -> Response Value
processResult Value
reqId (Left (MethodError Int
code Text
msg)) = Int -> Text -> Maybe Value -> Response Value
forall a. Int -> Text -> Maybe Value -> Response a
Error Int
code Text
msg (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
reqId)
processResult Value
reqId (Right a
res)                   = Value -> Value -> Response Value
forall a. a -> Value -> Response a
Result (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
res) Value
reqId


invalidRequest :: (Monad m) => m (Response Value)
invalidRequest :: m (Response Value)
invalidRequest = Int -> Text -> Maybe Value -> m (Response Value)
forall (m :: * -> *).
Monad m =>
Int -> Text -> Maybe Value -> m (Response Value)
mkError (-Int
32600) Text
"Invalid request" Maybe Value
forall a. Maybe a
Nothing

methodNotFound :: (Monad m) => Value -> m (Response Value)
methodNotFound :: Value -> m (Response Value)
methodNotFound = Int -> Text -> Maybe Value -> m (Response Value)
forall (m :: * -> *).
Monad m =>
Int -> Text -> Maybe Value -> m (Response Value)
mkError (-Int
32601) Text
"Method not found" (Maybe Value -> m (Response Value))
-> (Value -> Maybe Value) -> Value -> m (Response Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just

invalidParams :: (Monad m) => Value -> m (Response Value)
invalidParams :: Value -> m (Response Value)
invalidParams = Int -> Text -> Maybe Value -> m (Response Value)
forall (m :: * -> *).
Monad m =>
Int -> Text -> Maybe Value -> m (Response Value)
mkError (-Int
32602) Text
"Invalid params" (Maybe Value -> m (Response Value))
-> (Value -> Maybe Value) -> Value -> m (Response Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just

parseError :: (Monad m) => m (Response Value)
parseError :: m (Response Value)
parseError = Int -> Text -> Maybe Value -> m (Response Value)
forall (m :: * -> *).
Monad m =>
Int -> Text -> Maybe Value -> m (Response Value)
mkError (-Int
32700) Text
"Parse error" Maybe Value
forall a. Maybe a
Nothing

mkError :: (Monad m) => Int -> Text -> Maybe Value -> m (Response Value)
mkError :: Int -> Text -> Maybe Value -> m (Response Value)
mkError Int
code Text
msg Maybe Value
id = Response Value -> m (Response Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Text -> Maybe Value -> Response Value
forall a. Int -> Text -> Maybe Value -> Response a
Error Int
code Text
msg Maybe Value
id)


encodeResponse :: Response Value -> [ByteString]
encodeResponse :: Response Value -> [ByteString]
encodeResponse = ByteString -> [ByteString]
L.toChunks (ByteString -> [ByteString])
-> (Response Value -> ByteString) -> Response Value -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode