{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Control.TimeWarp.Rpc.PureRpc
( PureRpc
, runPureRpc
, DelaysSpecifier (..)
, Delays (..)
, ConnectionOutcome (..)
, getRandomTR
) where
import Control.Exception.Base (Exception)
import Control.Lens (both, makeLenses, to, use, (%%=),
(%~), at, (?=))
import Control.Monad (forM_, when)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM)
import Control.Monad.Random (MonadRandom (getRandomR), Rand, runRand)
import Control.Monad.State (MonadState (get, put, state), StateT,
evalStateT)
import Control.Monad.Trans (MonadIO, MonadTrans, lift)
import Data.Default (Default, def)
import Data.Map as Map
import Data.Time.Units (fromMicroseconds, toMicroseconds)
import Data.Typeable (Typeable)
import System.Random (StdGen)
import Data.MessagePack (Object, MessagePack (..))
import Control.TimeWarp.Logging (WithNamedLogger)
import Control.TimeWarp.Rpc.MonadRpc (Client (..), Host, Method (..),
MonadRpc (execClient, serve),
Port, RpcError (..), methodBody,
methodName, NetworkAddress)
import Control.TimeWarp.Timed (Microsecond, MonadTimed (..),
PureThreadId, TimedT, for,
virtualTime, runTimedT, sleepForever,
wait, ThreadId)
localhost :: Host
localhost = "127.0.0.1"
data ConnectionOutcome
= ConnectedIn Microsecond
| NeverConnected
newtype Delays = Delays
{
evalDelay :: NetworkAddress
-> Microsecond
-> Rand StdGen ConnectionOutcome
}
class DelaysSpecifier d where
toDelays :: d -> Delays
instance DelaysSpecifier Delays where
toDelays = id
instance DelaysSpecifier () where
toDelays = const . Delays . const . const . return $ NeverConnected
instance DelaysSpecifier Microsecond where
toDelays = Delays . const . const . return . ConnectedIn
instance DelaysSpecifier (Microsecond, Microsecond) where
toDelays = Delays . const . const . fmap ConnectedIn . getRandomTR
instance Show Delays where
show _ = "Delays"
instance Default Delays where
def = Delays . const . const . return . ConnectedIn $ 0
getRandomTR :: MonadRandom m => (Microsecond, Microsecond) -> m Microsecond
getRandomTR = fmap fromMicroseconds . getRandomR . (both %~ toMicroseconds)
type Listeners m = Map.Map (Port, String) ([Object] -> m Object)
data NetInfo m = NetInfo
{ _listeners :: Listeners m
, _randSeed :: StdGen
, _delays :: Delays
}
$(makeLenses ''NetInfo)
-- | Implementation of RPC protocol for emulation, allows to manually define
-- network nastiness via `Delays` datatype. TCP model is used.
--
-- List of known issues:
--
-- * Method, once being declared in net, can't be removed.
-- Even `throwTo` won't help.
--
-- * In implementation, remote method is actually inlined at call position,
-- so @instance WithNamedLogger@ would refer to caller's logger name, not
-- server's one.
newtype PureRpc m a = PureRpc
{ unwrapPureRpc :: TimedT (StateT (NetInfo (PureRpc m)) m) a
} deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch,
MonadMask, WithNamedLogger)
type instance ThreadId (PureRpc m) = PureThreadId
deriving instance (MonadIO m, MonadCatch m) => MonadTimed (PureRpc m)
instance MonadTrans PureRpc where
lift = PureRpc . lift . lift
instance MonadState s m => MonadState s (PureRpc m) where
get = lift get
put = lift . put
state = lift . state
-- | Launches distributed scenario, emulating work of network.
runPureRpc
:: (MonadIO m, MonadCatch m, DelaysSpecifier delays)
=> StdGen -> delays -> PureRpc m a -> m a
runPureRpc _randSeed (toDelays -> _delays) rpc =
evalStateT (runTimedT $ unwrapPureRpc rpc) net
where
net = NetInfo{..}
_listeners = Map.empty
request :: (MonadThrow m, MessagePack a)
=> Client a
-> Listeners (PureRpc m)
-> Port
-> PureRpc m a
request (Client name args) listeners' port =
case Map.lookup (port, name) listeners' of
Nothing -> throwM $ ServerError $ toObject $ mconcat
["method \"", name, "\" not found at port ", show port]
Just f -> do
res <- f args
case fromObject res of
Nothing -> throwM $ ResultTypeError "type mismatch" res
Just r -> return r
instance (MonadIO m, MonadCatch m) =>
MonadRpc (PureRpc m) where
execClient addr@(host, port) cli =
if host /= localhost
then
error "Can't emulate for host /= localhost"
else do
waitDelay addr
ls <- PureRpc $ use listeners
request cli ls port
serve port methods =
PureRpc $
do lift $
forM_ methods $
\Method {..} -> do
let methodRef = (port, methodName)
defined <- use $ listeners . to (Map.member methodRef)
when defined $ return ()
-- TODO:
-- throwM $ PortAlreadyBindedError port
listeners . at (port, methodName) ?= methodBody
sleepForever
waitDelay
:: (MonadThrow m, MonadIO m, MonadCatch m)
=> NetworkAddress -> PureRpc m ()
waitDelay addr =
PureRpc $
do delays' <- use delays
time <- virtualTime
delay <- randSeed %%= runRand (evalDelay delays' addr time)
case delay of
ConnectedIn connDelay -> wait (for connDelay)
NeverConnected -> sleepForever
data PortAlreadyBindedError = PortAlreadyBindedError Port
deriving (Show, Typeable)
instance Exception PortAlreadyBindedError