-- |
-- 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 :: forall (m :: * -> *).
(Applicative m, Monad m) =>
Methods m -> ConduitT ByteString ByteString m ()
serve Methods m
methods = forall (m :: * -> *).
Monad m =>
ConduitM ByteString (Processed (Request Value)) m ()
parseRequests
             forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b.
Monad m =>
(a -> m [b]) -> ConduitT a b m ()
C.concatMapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response Value -> [ByteString]
encodeResponse forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *).
Monad m =>
ConduitM ByteString (Processed (Request Value)) m ()
parseRequests = 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 forall a. Maybe a
Nothing
  where
    loop :: StateT
  (Maybe (ByteString -> Result Value))
  (ConduitT ByteString (Processed (Request Value)) m)
  ()
loop = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 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 <- forall (m :: * -> *) s. Monad m => StateT s m s
get
      case Maybe (ByteString -> Result Value)
p of
        Maybe (ByteString -> Result Value)
Nothing -> 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 <- forall {a}.
StateT
  (Maybe a)
  (ConduitT ByteString (Processed (Request Value)) m)
  (Maybe a)
getPartialParser
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (ByteString -> Result Value)
p of
                 Maybe (ByteString -> Result Value)
Nothing -> 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 = forall (m :: * -> *) s. Monad m => StateT s m s
get forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a. Maybe a
Nothing

    handle :: Result Value
-> StateT
     (Maybe (ByteString -> Result Value))
     (ConduitT ByteString (Processed (Request Value)) m)
     ()
handle Fail{}        = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a. Processed a
ParseError)
    handle (Partial ByteString -> Result Value
k)   = forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (forall a. a -> Maybe a
Just ByteString -> Result Value
k) 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
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (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 = forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield forall a b. (a -> b) -> a -> b
$ case forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe forall a. FromJSON a => Value -> Parser a
parseJSON Value
r of
                                Maybe a
Nothing -> forall a. Processed a
InvalidRequest
                                Just a
r' -> forall a. a -> Processed a
Correct a
r'

handleRequest :: Monad m
              => Methods m
              -> Processed (Request Value)
              -> m (Response Value)
handleRequest :: forall (m :: * -> *).
Monad m =>
Methods m -> Processed (Request Value) -> m (Response Value)
handleRequest Methods m
_       Processed (Request Value)
InvalidRequest    = forall (m :: * -> *). Monad m => m (Response Value)
invalidRequest
handleRequest Methods m
_       Processed (Request Value)
ParseError        = forall (m :: * -> *). Monad m => m (Response Value)
parseError
handleRequest Methods m
methods (Correct Request Value
request) =
  case forall (m :: * -> *). Methods m -> Text -> Maybe (Method m)
lookup Methods m
methods (forall a. Request a -> Text
reqMethod Request Value
request) of
    Maybe (Method m)
Nothing -> forall (m :: * -> *). Monad m => Value -> m (Response Value)
methodNotFound (forall a. Request a -> Value
reqId Request Value
request)
    Just Method m
m  -> 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 :: forall (m :: * -> *).
(Applicative m, Monad m) =>
Method m -> Request Value -> m (Response Value)
runMethod (Method i -> m (Either MethodError o)
f) Request Value
request = do
  let ri :: Value
ri = forall a. Request a -> Value
reqId Request Value
request
  case forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe forall a. FromJSON a => Value -> Parser a
parseJSON (forall a. Request a -> a
reqParams Request Value
request) of
    Maybe i
Nothing -> forall (m :: * -> *). Monad m => Value -> m (Response Value)
invalidParams Value
ri
    Just i
ps -> forall a.
ToJSON a =>
Value -> Either MethodError a -> Response Value
processResult Value
ri 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 :: forall a.
ToJSON a =>
Value -> Either MethodError a -> Response Value
processResult Value
reqId (Left (MethodError Int
code Text
msg)) = forall a. Int -> Text -> Maybe Value -> Response a
Error Int
code Text
msg (forall a. a -> Maybe a
Just Value
reqId)
processResult Value
reqId (Right a
res)                   = forall a. a -> Value -> Response a
Result (forall a. ToJSON a => a -> Value
toJSON a
res) Value
reqId


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

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

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

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

mkError :: (Monad m) => Int -> Text -> Maybe Value -> m (Response Value)
mkError :: forall (m :: * -> *).
Monad m =>
Int -> Text -> Maybe Value -> m (Response Value)
mkError Int
code Text
msg Maybe Value
id = forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode