module Control.TimeWarp.Rpc.MonadTransfer
(
Port
, Host
, NetworkAddress
, Binding (..)
, localhost
, commLoggerName
, commLog
, MonadTransfer (..)
, MonadResponse (..)
, ResponseContext (..)
, ResponseT (..)
, runResponseT
, mapResponseT
, hoistRespCond
) where
import Control.Lens (iso, view)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Morph (hoist)
import Control.Monad.Reader (MonadReader (..), ReaderT (..), mapReaderT)
import Control.Monad.State (MonadState)
import Control.Monad.Trans (MonadIO (..), MonadTrans (..))
import Control.Monad.Trans.Control (MonadTransControl (..))
import Data.ByteString (ByteString)
import Data.Conduit (ConduitM, Producer, Sink, Source)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Word (Word16)
import System.Wlog (CanLog, HasLoggerName, LoggerName,
LoggerNameBox (..), WithLogger,
modifyLoggerName)
import Serokell.Util.Lens (WrappedM (..), _UnwrappedM)
import Control.TimeWarp.Timed (MonadTimed, ThreadId)
type Port = Word16
type Host = ByteString
localhost :: Host
localhost = "127.0.0.1"
type NetworkAddress = (Host, Port)
commLoggerName :: LoggerName
commLoggerName = "comm"
commLog :: HasLoggerName m => m a -> m a
commLog = modifyLoggerName (<> commLoggerName)
data Binding
= AtPort Port
| AtConnTo NetworkAddress
deriving (Eq, Ord, Show)
class Monad m => MonadTransfer s m | m -> s where
sendRaw :: NetworkAddress
-> Source m ByteString
-> m ()
default sendRaw :: (WrappedM m, MonadTransfer s (UnwrappedM m))
=> NetworkAddress -> Source m ByteString -> m ()
sendRaw addr req = view _UnwrappedM $
sendRaw addr $ view _WrappedM `hoist` req
listenRaw :: Binding
-> Sink ByteString (ResponseT s m) ()
-> m (m ())
default listenRaw :: (WrappedM m, MonadTransfer s (UnwrappedM m))
=> Binding -> Sink ByteString (ResponseT s m) () -> m (m ())
listenRaw binding sink = view _UnwrappedM $ fmap (view _UnwrappedM) $
listenRaw binding $ view _WrappedM `hoistRespCond` sink
close :: NetworkAddress -> m ()
default close :: (WrappedM m, MonadTransfer s (UnwrappedM m))
=> NetworkAddress -> m ()
close = view _UnwrappedM . close
userState :: NetworkAddress -> m s
default userState :: (WrappedM m, MonadTransfer s (UnwrappedM m))
=> NetworkAddress -> m s
userState = view _UnwrappedM . userState
class Monad m => MonadResponse s m | m -> s where
replyRaw :: Producer m ByteString -> m ()
closeR :: m ()
peerAddr :: m Text
userStateR :: m s
default userStateR :: (MonadTrans t, t n ~ m, MonadResponse s n) => t n s
userStateR = lift userStateR
data ResponseContext s = ResponseContext
{ respSend :: forall m . (MonadIO m, MonadMask m, WithLogger m)
=> Source m ByteString -> m ()
, respClose :: IO ()
, respPeerAddr :: Text
, respUserState :: s
}
newtype ResponseT s m a = ResponseT
{ getResponseT :: ReaderT (ResponseContext s) m a
} deriving (Functor, Applicative, Monad, MonadIO, MonadTrans,
MonadThrow, MonadCatch, MonadMask,
MonadState ss, CanLog,
HasLoggerName, MonadTimed)
runResponseT :: ResponseT s m a -> ResponseContext s -> m a
runResponseT = runReaderT . getResponseT
instance Monad m => WrappedM (ResponseT s m) where
type UnwrappedM (ResponseT s m) = ReaderT (ResponseContext s) m
_WrappedM = iso getResponseT ResponseT
type instance ThreadId (ResponseT s m) = ThreadId m
instance MonadReader r m => MonadReader r (ResponseT s m) where
ask = lift ask
reader f = lift $ reader f
local = mapResponseT . local
instance MonadTransfer s m => MonadTransfer s (ResponseT s0 m) where
instance (MonadIO m, MonadMask m, WithLogger m)
=> MonadResponse s (ResponseT s m) where
replyRaw dat = ResponseT ask >>= \ctx -> respSend ctx dat
closeR = ResponseT $ ask >>= liftIO . respClose
peerAddr = respPeerAddr <$> ResponseT ask
userStateR = respUserState <$> ResponseT ask
mapResponseT :: (m a -> n b) -> ResponseT s m a -> ResponseT s n b
mapResponseT how = ResponseT . mapReaderT how . getResponseT
hoistRespCond :: Monad m
=> (forall a . m a -> n a)
-> ConduitM i o (ResponseT s m) r
-> ConduitM i o (ResponseT s n) r
hoistRespCond how = hoist $ mapResponseT how
instance MonadTransfer s m => MonadTransfer s (ReaderT r m) where
sendRaw addr req = ask >>= \ctx -> lift $ sendRaw addr (hoist (`runReaderT` ctx) req)
listenRaw binding sink =
fmap lift $ liftWith $ \run -> listenRaw binding $ hoistRespCond run sink
close = lift . close
userState = lift . userState
instance MonadTransfer s m => MonadTransfer s (LoggerNameBox m) where
instance MonadResponse s m => MonadResponse s (ReaderT r m) where
replyRaw dat = ask >>= \ctx -> lift $ replyRaw (hoist (`runReaderT` ctx) dat)
closeR = lift closeR
peerAddr = lift peerAddr