{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StrictData                 #-}
{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-------------------------------------------------------------------
-- |
-- Module    : Network.MessagePackRpc.Server
-- Copyright : (c) Hideyuki Tanaka, 2010-2015
-- License   : BSD3
--
-- Maintainer:  tanaka.hideyuki@gmail.com
-- Stability :  experimental
-- Portability: portable
--
-- This module is server library of MessagePack-RPC.
-- The specification of MessagePack-RPC is at
-- <http://redmine.msgpack.org/projects/msgpack/wiki/RPCProtocolSpec>.
--
-- A simple example:
--
-- > import Network.MessagePackRpc.Server
-- >
-- > add :: Int -> Int -> Server Int
-- > add x y = return $ x + y
-- >
-- > main = serve 1234 [ method "add" add ]
--
--------------------------------------------------------------------

module Network.MessagePack.Server.Basic (
  -- * RPC method types
    Method
  , MethodVal (..)
  , MethodDocs (..)
  , MethodType (..)
  , ServerT (..)
  , Server

  -- * Build a method
  , method

  -- * Get the method name
  , methodName
  , methodDocs

  -- * Start RPC server
  , serve
  ) where

import           Control.Applicative               ((<|>))
import           Control.Monad.Catch               (MonadCatch, MonadThrow,
                                                    catch, throwM)
import           Control.Monad.IO.Unlift           (MonadUnliftIO)
import           Control.Monad.Trans               (MonadIO, MonadTrans, lift,
                                                    liftIO)
import           Control.Monad.Trans.Control       (MonadBaseControl)
import           Control.Monad.Validate            (runValidate)
import qualified Data.Binary                       as Binary
import qualified Data.ByteString                   as S
import           Data.Conduit                      (ConduitT, SealedConduitT,
                                                    Void, runConduit, ($$+),
                                                    ($$++), (.|))
import qualified Data.Conduit.Binary               as CB
import           Data.Conduit.Network              (appSink, appSource,
                                                    runGeneralTCPServer,
                                                    serverSettings,
                                                    setAfterBind)
import           Data.Conduit.Serialization.Binary (ParseError, sinkGet)
import           Data.Kind                         (Type)
import qualified Data.List                         as List
import           Data.MessagePack                  (MessagePack, Object,
                                                    defaultConfig, fromObject,
                                                    fromObjectWith, toObject)
import qualified Data.Text                         as T
import qualified Network.MessagePack.Types.Result  as R
import           Network.Socket                    (SocketOption (ReuseAddr),
                                                    setSocketOption)

import           Network.MessagePack.Interface     (IsReturnType (..), Returns,
                                                    ReturnsM)
import           Network.MessagePack.Types


newtype ServerT m a = ServerT { ServerT m a -> m a
runServerT :: m a }
  deriving (a -> ServerT m b -> ServerT m a
(a -> b) -> ServerT m a -> ServerT m b
(forall a b. (a -> b) -> ServerT m a -> ServerT m b)
-> (forall a b. a -> ServerT m b -> ServerT m a)
-> Functor (ServerT m)
forall a b. a -> ServerT m b -> ServerT m a
forall a b. (a -> b) -> ServerT m a -> ServerT m b
forall (m :: * -> *) a b.
Functor m =>
a -> ServerT m b -> ServerT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ServerT m a -> ServerT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ServerT m b -> ServerT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ServerT m b -> ServerT m a
fmap :: (a -> b) -> ServerT m a -> ServerT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ServerT m a -> ServerT m b
Functor, Functor (ServerT m)
a -> ServerT m a
Functor (ServerT m)
-> (forall a. a -> ServerT m a)
-> (forall a b. ServerT m (a -> b) -> ServerT m a -> ServerT m b)
-> (forall a b c.
    (a -> b -> c) -> ServerT m a -> ServerT m b -> ServerT m c)
-> (forall a b. ServerT m a -> ServerT m b -> ServerT m b)
-> (forall a b. ServerT m a -> ServerT m b -> ServerT m a)
-> Applicative (ServerT m)
ServerT m a -> ServerT m b -> ServerT m b
ServerT m a -> ServerT m b -> ServerT m a
ServerT m (a -> b) -> ServerT m a -> ServerT m b
(a -> b -> c) -> ServerT m a -> ServerT m b -> ServerT m c
forall a. a -> ServerT m a
forall a b. ServerT m a -> ServerT m b -> ServerT m a
forall a b. ServerT m a -> ServerT m b -> ServerT m b
forall a b. ServerT m (a -> b) -> ServerT m a -> ServerT m b
forall a b c.
(a -> b -> c) -> ServerT m a -> ServerT m b -> ServerT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (ServerT m)
forall (m :: * -> *) a. Applicative m => a -> ServerT m a
forall (m :: * -> *) a b.
Applicative m =>
ServerT m a -> ServerT m b -> ServerT m a
forall (m :: * -> *) a b.
Applicative m =>
ServerT m a -> ServerT m b -> ServerT m b
forall (m :: * -> *) a b.
Applicative m =>
ServerT m (a -> b) -> ServerT m a -> ServerT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ServerT m a -> ServerT m b -> ServerT m c
<* :: ServerT m a -> ServerT m b -> ServerT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
ServerT m a -> ServerT m b -> ServerT m a
*> :: ServerT m a -> ServerT m b -> ServerT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
ServerT m a -> ServerT m b -> ServerT m b
liftA2 :: (a -> b -> c) -> ServerT m a -> ServerT m b -> ServerT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ServerT m a -> ServerT m b -> ServerT m c
<*> :: ServerT m (a -> b) -> ServerT m a -> ServerT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
ServerT m (a -> b) -> ServerT m a -> ServerT m b
pure :: a -> ServerT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> ServerT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (ServerT m)
Applicative, Applicative (ServerT m)
a -> ServerT m a
Applicative (ServerT m)
-> (forall a b. ServerT m a -> (a -> ServerT m b) -> ServerT m b)
-> (forall a b. ServerT m a -> ServerT m b -> ServerT m b)
-> (forall a. a -> ServerT m a)
-> Monad (ServerT m)
ServerT m a -> (a -> ServerT m b) -> ServerT m b
ServerT m a -> ServerT m b -> ServerT m b
forall a. a -> ServerT m a
forall a b. ServerT m a -> ServerT m b -> ServerT m b
forall a b. ServerT m a -> (a -> ServerT m b) -> ServerT m b
forall (m :: * -> *). Monad m => Applicative (ServerT m)
forall (m :: * -> *) a. Monad m => a -> ServerT m a
forall (m :: * -> *) a b.
Monad m =>
ServerT m a -> ServerT m b -> ServerT m b
forall (m :: * -> *) a b.
Monad m =>
ServerT m a -> (a -> ServerT m b) -> ServerT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ServerT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> ServerT m a
>> :: ServerT m a -> ServerT m b -> ServerT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ServerT m a -> ServerT m b -> ServerT m b
>>= :: ServerT m a -> (a -> ServerT m b) -> ServerT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ServerT m a -> (a -> ServerT m b) -> ServerT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (ServerT m)
Monad, Monad (ServerT m)
Monad (ServerT m)
-> (forall a. IO a -> ServerT m a) -> MonadIO (ServerT m)
IO a -> ServerT m a
forall a. IO a -> ServerT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (ServerT m)
forall (m :: * -> *) a. MonadIO m => IO a -> ServerT m a
liftIO :: IO a -> ServerT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> ServerT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (ServerT m)
MonadIO, Monad (ServerT m)
Monad (ServerT m)
-> (forall a. String -> ServerT m a) -> MonadFail (ServerT m)
String -> ServerT m a
forall a. String -> ServerT m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (ServerT m)
forall (m :: * -> *) a. MonadFail m => String -> ServerT m a
fail :: String -> ServerT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> ServerT m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (ServerT m)
MonadFail)


instance MonadTrans ServerT where
  lift :: m a -> ServerT m a
lift = m a -> ServerT m a
forall (m :: * -> *) a. m a -> ServerT m a
ServerT
  {-# INLINE lift #-}


type Server = ServerT IO


instance (MonadThrow m, MessagePack o, MethodType m r) => MethodType m (o -> r) where
  toBody :: Text -> (o -> r) -> [Object] -> m Object
toBody Text
n o -> r
f (Object
x : [Object]
xs) =
    case Validate DecodeError o -> Either DecodeError o
forall e a. Validate e a -> Either e a
runValidate (Validate DecodeError o -> Either DecodeError o)
-> (Object -> Validate DecodeError o)
-> Object
-> Either DecodeError o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Object -> Validate DecodeError o
forall a (m :: * -> *).
(MessagePack a, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Object -> m a
fromObjectWith Config
defaultConfig (Object -> Either DecodeError o) -> Object -> Either DecodeError o
forall a b. (a -> b) -> a -> b
$ Object
x of
      Left DecodeError
err -> ServerError -> m Object
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ServerError -> m Object) -> ServerError -> m Object
forall a b. (a -> b) -> a -> b
$ Text -> ServerError
ServerError (Text -> ServerError) -> Text -> ServerError
forall a b. (a -> b) -> a -> b
$ Text
"argument type error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (DecodeError -> String
forall a. Show a => a -> String
show DecodeError
err)
      Right o
ok -> Text -> r -> [Object] -> m Object
forall (m :: * -> *) f.
MethodType m f =>
Text -> f -> [Object] -> m Object
toBody Text
n (o -> r
f o
ok) [Object]
xs
  toBody Text
_ o -> r
_ [] = String -> m Object
forall a. HasCallStack => String -> a
error String
"messagepack-rpc methodtype instance toBody failed"

instance (Functor m, MonadThrow m, MessagePack o) => MethodType m (ServerT m o) where
  toBody :: Text -> ServerT m o -> [Object] -> m Object
toBody Text
_ ServerT m o
m [] = Config -> o -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
defaultConfig (o -> Object) -> m o -> m Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerT m o -> m o
forall (m :: * -> *) a. ServerT m a -> m a
runServerT ServerT m o
m
  toBody Text
n ServerT m o
_ [Object]
ls =
    ServerError -> m Object
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ServerError -> m Object) -> ServerError -> m Object
forall a b. (a -> b) -> a -> b
$ Text -> ServerError
ServerError (Text -> ServerError) -> Text -> ServerError
forall a b. (a -> b) -> a -> b
$
      Text
"invalid arguments for method '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"': " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Object] -> String
forall a. Show a => a -> String
show [Object]
ls)

-- Pure server
instance forall m (r :: Type). Monad m => IsReturnType m (Returns r) where
  type HaskellType (Returns r) = r
  type ServerType m (Returns r) = ServerT m r

  implement :: InterfaceM m (Returns r)
-> HaskellType (Returns r) -> ServerType m (Returns r)
implement InterfaceM m (Returns r)
_ = HaskellType (Returns r) -> ServerType m (Returns r)
forall (m :: * -> *) a. Monad m => a -> m a
return

-- IO Server
instance forall m (r :: Type). MonadIO m => IsReturnType m (ReturnsM IO r) where
  type HaskellType (ReturnsM IO r) = IO r
  type ServerType m (ReturnsM IO r) = ServerT m r

  implement :: InterfaceM m (ReturnsM IO r)
-> HaskellType (ReturnsM IO r) -> ServerType m (ReturnsM IO r)
implement InterfaceM m (ReturnsM IO r)
_ = HaskellType (ReturnsM IO r) -> ServerType m (ReturnsM IO r)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO


processRequests
  :: (Applicative m, MonadThrow m, MonadCatch m)
  => [Method m]
  -> SealedConduitT () S.ByteString m ()
  -> ConduitT S.ByteString Void m t
  -> m b
processRequests :: [Method m]
-> SealedConduitT () ByteString m ()
-> ConduitT ByteString Void m t
-> m b
processRequests [Method m]
methods SealedConduitT () ByteString m ()
rsrc ConduitT ByteString Void m t
sink = do
  (SealedConduitT () ByteString m ()
rsrc', Response
res) <-
    SealedConduitT () ByteString m ()
rsrc SealedConduitT () ByteString m ()
-> ConduitT ByteString Void m Response
-> m (SealedConduitT () ByteString m (), Response)
forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> ConduitT a Void m b -> m (SealedConduitT () a m (), b)
$$++ do
      Object
obj <- Get Object -> ConduitT ByteString Void m Object
forall (m :: * -> *) b z.
MonadThrow m =>
Get b -> ConduitT ByteString z m b
sinkGet Get Object
forall t. Binary t => Get t
Binary.get
      case Object -> Either DecodeError (Request Object)
forall ix.
MessagePack ix =>
Object -> Either DecodeError (Request ix)
unpackRequest Object
obj of
        Left DecodeError
err ->
          ServerError -> ConduitT ByteString Void m Response
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ServerError -> ConduitT ByteString Void m Response)
-> (DecodeError -> ServerError)
-> DecodeError
-> ConduitT ByteString Void m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ServerError
ServerError (Text -> ServerError)
-> (DecodeError -> Text) -> DecodeError -> ServerError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (DecodeError -> String) -> DecodeError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeError -> String
forall a. Show a => a -> String
show (DecodeError -> ConduitT ByteString Void m Response)
-> DecodeError -> ConduitT ByteString Void m Response
forall a b. (a -> b) -> a -> b
$ DecodeError
err
        Right req :: Request Object
req@(Int
_, Int
msgid, Object
_, [Object]
_) ->
          m Response -> ConduitT ByteString Void m Response
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Response -> ConduitT ByteString Void m Response)
-> m Response -> ConduitT ByteString Void m Response
forall a b. (a -> b) -> a -> b
$ [Method m] -> Request Object -> m Response
forall (m :: * -> *).
Applicative m =>
[Method m] -> Request Object -> m Response
getResponse [Method m]
methods Request Object
req m Response -> (ServerError -> m Response) -> m Response
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ServerError Text
err) ->
            Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
1, Int
msgid, Config -> Text -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
defaultConfig Text
err, Config -> () -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
defaultConfig ())

  t
_ <- ConduitT () Void m t -> m t
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m t -> m t) -> ConduitT () Void m t -> m t
forall a b. (a -> b) -> a -> b
$ ByteString -> ConduitT () ByteString m ()
forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i ByteString m ()
CB.sourceLbs (Response -> ByteString
packResponse Response
res) ConduitT () ByteString m ()
-> ConduitT ByteString Void m t -> ConduitT () Void m t
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void m t
sink
  [Method m]
-> SealedConduitT () ByteString m ()
-> ConduitT ByteString Void m t
-> m b
forall (m :: * -> *) t b.
(Applicative m, MonadThrow m, MonadCatch m) =>
[Method m]
-> SealedConduitT () ByteString m ()
-> ConduitT ByteString Void m t
-> m b
processRequests [Method m]
methods SealedConduitT () ByteString m ()
rsrc' ConduitT ByteString Void m t
sink


getResponse
  :: Applicative m
  => [Method m]
  -> Request Object
  -> m Response
getResponse :: [Method m] -> Request Object -> m Response
getResponse [Method m]
methods (Int
0, Int
msgid, Object
mth, [Object]
args) =
  Result Object -> Response
process (Result Object -> Response) -> m (Result Object) -> m Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method m] -> Object -> [Object] -> m (Result Object)
forall (m :: * -> *).
Applicative m =>
[Method m] -> Object -> [Object] -> m (Result Object)
callMethod [Method m]
methods Object
mth [Object]
args
  where
    process :: Result Object -> Response
process (R.Failure String
err) = (Int
1, Int
msgid, Config -> String -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
defaultConfig String
err, Config -> () -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
defaultConfig ())
    process (R.Success Object
ok ) = (Int
1, Int
msgid, Config -> () -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
defaultConfig (), Object
ok)

getResponse [Method m]
_ (Int
rtype, Int
msgid, Object
_, [Object]
_) =
  Response -> m Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Int
msgid, Config -> [Text] -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
defaultConfig [Text
"request type is not 0, got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
rtype)], Config -> () -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
defaultConfig ())


callMethod
  :: (Applicative m)
  => [Method m]
  -> Object
  -> [Object]
  -> m (R.Result Object)
callMethod :: [Method m] -> Object -> [Object] -> m (Result Object)
callMethod [Method m]
methods Object
mth [Object]
args = Result (m Object) -> m (Result Object)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Result (m Object) -> m (Result Object))
-> Result (m Object) -> m (Result Object)
forall a b. (a -> b) -> a -> b
$
  (Text -> Result (m Object)
stringCall (Text -> Result (m Object)) -> Result Text -> Result (m Object)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object -> Result Text
forall (m :: * -> *) a.
(MonadFail m, MessagePack a) =>
Object -> m a
fromObject Object
mth)
  Result (m Object) -> Result (m Object) -> Result (m Object)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (Int -> Result (m Object)
intCall (Int -> Result (m Object)) -> Result Int -> Result (m Object)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object -> Result Int
forall (m :: * -> *) a.
(MonadFail m, MessagePack a) =>
Object -> m a
fromObject Object
mth)

  where
    stringCall :: Text -> Result (m Object)
stringCall Text
name =
      case (Method m -> Bool) -> [Method m] -> Maybe (Method m)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) (Text -> Bool) -> (Method m -> Text) -> Method m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method m -> Text
forall (m :: * -> *). Method m -> Text
methodName) [Method m]
methods of
        Maybe (Method m)
Nothing -> String -> Result (m Object)
forall a. String -> Result a
R.Failure (String -> Result (m Object)) -> String -> Result (m Object)
forall a b. (a -> b) -> a -> b
$ String
"method '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' not found"
        Just Method m
m  -> m Object -> Result (m Object)
forall a. a -> Result a
R.Success (m Object -> Result (m Object)) -> m Object -> Result (m Object)
forall a b. (a -> b) -> a -> b
$ Method m -> [Object] -> m Object
forall (m :: * -> *). Method m -> [Object] -> m Object
methodBody Method m
m [Object]
args

    intCall :: Int -> Result (m Object)
intCall Int
ix =
      case Int -> [Method m] -> [Method m]
forall a. Int -> [a] -> [a]
drop Int
ix [Method m]
methods of
        []  -> String -> Result (m Object)
forall a. String -> Result a
R.Failure (String -> Result (m Object)) -> String -> Result (m Object)
forall a b. (a -> b) -> a -> b
$ String
"method #" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
ix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" not found"
        Method m
m:[Method m]
_ -> m Object -> Result (m Object)
forall a. a -> Result a
R.Success (m Object -> Result (m Object)) -> m Object -> Result (m Object)
forall a b. (a -> b) -> a -> b
$ Method m -> [Object] -> m Object
forall (m :: * -> *). Method m -> [Object] -> m Object
methodBody Method m
m [Object]
args


ignoreParseError :: Applicative m => ParseError -> m ()
ignoreParseError :: ParseError -> m ()
ignoreParseError ParseError
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Start RPC server with a set of RPC methods.
serve
  :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadUnliftIO m)
  => Int        -- ^ Port number
  -> [Method m] -- ^ list of methods
  -> m ()
serve :: Int -> [Method m] -> m ()
serve Int
port [Method m]
methods =
  ServerSettings -> (AppData -> m ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
ServerSettings -> (AppData -> m ()) -> m a
runGeneralTCPServer ServerSettings
settings ((AppData -> m ()) -> m ()) -> (AppData -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \AppData
ad -> do
    (SealedConduitT () ByteString m ()
rsrc, ()
_) <- AppData -> ConduitT () ByteString m ()
forall ad (m :: * -> *) i.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT i ByteString m ()
appSource AppData
ad ConduitT () ByteString m ()
-> ConduitT ByteString Void m ()
-> m (SealedConduitT () ByteString m (), ())
forall (m :: * -> *) a b.
Monad m =>
ConduitT () a m ()
-> ConduitT a Void m b -> m (SealedConduitT () a m (), b)
$$+ () -> ConduitT ByteString Void m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [Method m]
-> SealedConduitT () ByteString m ()
-> ConduitT ByteString Void m ()
-> m ()
forall (m :: * -> *) t b.
(Applicative m, MonadThrow m, MonadCatch m) =>
[Method m]
-> SealedConduitT () ByteString m ()
-> ConduitT ByteString Void m t
-> m b
processRequests [Method m]
methods SealedConduitT () ByteString m ()
rsrc (AppData -> ConduitT ByteString Void m ()
forall ad (m :: * -> *) o.
(HasReadWrite ad, MonadIO m) =>
ad -> ConduitT ByteString o m ()
appSink AppData
ad) m () -> (ParseError -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` ParseError -> m ()
forall (m :: * -> *). Applicative m => ParseError -> m ()
ignoreParseError

  where
    settings :: ServerSettings
settings =
      (Socket -> IO ()) -> ServerSettings -> ServerSettings
forall a. HasAfterBind a => (Socket -> IO ()) -> a -> a
setAfterBind
        (\Socket
s -> Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
ReuseAddr Int
1)
        (Int -> HostPreference -> ServerSettings
serverSettings Int
port HostPreference
"*")