{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Control.TimeWarp.Rpc.MonadRpc
( Port
, Host
, NetworkAddress
, MonadRpc (serve, execClient)
, RpcType()
, execClientTimeout
, Method(..)
, Client(..)
, method
, call
, S.Server
, S.ServerT
, S.MethodType
, C.RpcError(..)
) where
import Control.Monad.Catch (MonadCatch (catch),
MonadThrow (throwM))
import Control.Monad.Reader (ReaderT (..))
import Control.Monad.Trans (lift)
import Data.ByteString (ByteString)
import Data.MessagePack (MessagePack, toObject, Object)
import Data.Time.Units (TimeUnit)
import qualified Network.MessagePack.Client as C
import qualified Network.MessagePack.Server as S
import Control.TimeWarp.Logging (WithNamedLogger, LoggerNameBox (..))
import Control.TimeWarp.Timed (MonadTimed (timeout))
type Port = Int
type Host = ByteString
type NetworkAddress = (Host, Port)
deriving instance WithNamedLogger m => WithNamedLogger (S.ServerT m)
class MonadThrow r => MonadRpc r where
execClient :: MessagePack a => NetworkAddress -> Client a -> r a
serve :: Port -> [Method r] -> r ()
execClientTimeout
:: (MonadTimed m, MonadRpc m, MessagePack a, TimeUnit t)
=> t -> NetworkAddress -> Client a -> m a
execClientTimeout t addr = timeout t . execClient addr
call :: RpcType t => String -> t
call name = rpcc name []
class RpcType t where
rpcc :: String -> [Object] -> t
instance (RpcType t, MessagePack p) => RpcType (p -> t) where
rpcc name objs p = rpcc name $ toObject p : objs
data Client a where
Client :: MessagePack a => String -> [Object] -> Client a
instance MessagePack o => RpcType (Client o) where
rpcc name args = Client name (reverse args)
data Method m = Method
{ methodName :: String
, methodBody :: [Object] -> m Object
}
method :: S.MethodType m f => String -> f -> Method m
method name f = Method
{ methodName = name
, methodBody = S.toBody f
}
instance Monad m => S.MethodType m Object where
toBody res [] = return res
toBody _ _ = error "Too many arguments!"
instance MonadThrow m => MonadThrow (S.ServerT m) where
throwM = lift . throwM
instance MonadCatch m =>
MonadCatch (S.ServerT m) where
catch (S.ServerT action) handler =
S.ServerT $ action `catch` (S.runServerT . handler)
instance MonadRpc m => MonadRpc (ReaderT r m) where
execClient addr cli = lift $ execClient addr cli
serve port methods = ReaderT $
\r -> serve port (convert r <$> methods)
where
convert :: r -> Method (ReaderT r m) -> Method m
convert r Method {..} =
Method methodName (flip runReaderT r . methodBody)
deriving instance MonadRpc m => MonadRpc (LoggerNameBox m)