{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StrictData                 #-}
{-# LANGUAGE Trustworthy                #-}
{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS_GHC -fno-warn-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               (Applicative, pure, (<$>),
                                                    (<|>))
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 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 qualified Data.List                         as List
import           Data.MessagePack                  (MessagePack, Object,
                                                    fromObject, toObject)
import           Data.Monoid                       ((<>))
import qualified Data.Text                         as T
import           Data.Traversable                  (sequenceA)
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 Object -> Maybe o
forall a (m :: * -> *).
(MessagePack a, Applicative m, Monad m, MonadFail m) =>
Object -> m a
fromObject Object
x of
      Maybe o
Nothing -> 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
"argument type error"
      Just o
r  -> Text -> r -> [Object] -> m Object
forall (m :: * -> *) f.
MethodType m f =>
Text -> f -> [Object] -> m Object
toBody Text
n (o -> r
f o
r) [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 [] = o -> Object
forall a. MessagePack a => a -> Object
toObject (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 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 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 ()
-> Sink ByteString m Response
-> m (SealedConduitT () ByteString m (), Response)
forall (m :: * -> *) a b.
Monad m =>
SealedConduitT () a m ()
-> Sink a 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 -> Maybe (Request Object)
forall ix. MessagePack ix => Object -> Maybe (Request ix)
unpackRequest Object
obj of
        Maybe (Request Object)
Nothing ->
          ServerError -> Sink ByteString m Response
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ServerError -> Sink ByteString m Response)
-> ServerError -> Sink ByteString m Response
forall a b. (a -> b) -> a -> b
$ Text -> ServerError
ServerError Text
"invalid request"
        Just req :: Request Object
req@(Int
_, Int
msgid, Object
_, [Object]
_) ->
          m Response -> Sink ByteString m Response
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Response -> Sink ByteString m Response)
-> m Response -> Sink ByteString 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, Text -> Object
forall a. MessagePack a => a -> Object
toObject Text
err, () -> Object
forall a. MessagePack a => a -> Object
toObject ())

  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 =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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, String -> Object
forall a. MessagePack a => a -> Object
toObject String
err, () -> Object
forall a. MessagePack a => a -> Object
toObject ())
    process (R.Success Object
ok ) = (Int
1, Int
msgid, () -> Object
forall a. MessagePack a => a -> Object
toObject (), 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, [Text] -> Object
forall a. MessagePack a => a -> Object
toObject [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)], () -> Object
forall a. MessagePack a => a -> Object
toObject ())


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 a (m :: * -> *).
(MessagePack a, Applicative m, Monad m, MonadFail m) =>
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 a (m :: * -> *).
(MessagePack a, Applicative m, Monad m, MonadFail m) =>
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 ()
-> Sink ByteString m ()
-> m (SealedConduitT () ByteString m (), ())
forall (m :: * -> *) a b.
Monad m =>
Source m a -> Sink a m b -> m (SealedConduitT () a m (), b)
$$+ () -> Sink ByteString m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [Method m]
-> SealedConduitT () ByteString m ()
-> Sink ByteString 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 -> Sink ByteString 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
"*")