module Control.Eff.Concurrent.Protocol.StatefulServer
( Server(..)
, start
, startLink
, ModelState
, modifyModel
, getAndModifyModel
, modifyAndGetModel
, getModel
, putModel
, getAndPutModel
, useModel
, zoomModel
, SettingsReader
, askSettings
, viewSettings
, Effectful.Event(..)
, RequestOrigin(..)
, Reply(..)
, sendReply
, toEmbeddedOrigin
, embedReplySerializer
)
where
import Control.Eff
import Control.Eff.Extend ()
import Control.Eff.Concurrent.Process
import Control.Eff.Concurrent.Protocol
import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful
import Control.Eff.Concurrent.Protocol.Request
import Control.Eff.Log
import Control.Eff.Reader.Strict
import Control.Eff.State.Strict
import Control.Lens
import Data.Default
import Data.Kind
import Data.Typeable
import GHC.Stack (HasCallStack)
class (Typeable (Protocol a)) => Server (a :: Type) q where
data StartArgument a q
type Protocol a :: Type
type Protocol a = a
type Model a :: Type
type Model a = ()
type Settings a :: Type
type Settings a = ()
setup ::
StartArgument a q
-> Eff (InterruptableProcess q) (Model a, Settings a)
default setup ::
(Default (Model a), Default (Settings a))
=> StartArgument a q
-> Eff (InterruptableProcess q) (Model a, Settings a)
setup _ = pure (def, def)
update ::
StartArgument a q
-> Effectful.Event (Protocol a)
-> Eff (ModelState a ': SettingsReader a ': InterruptableProcess q) ()
data Stateful a deriving Typeable
instance Server a q => Effectful.Server (Stateful a) (InterruptableProcess q) where
data Init (Stateful a) (InterruptableProcess q) = Init (StartArgument a q)
type ServerPdu (Stateful a) = Protocol a
type Effects (Stateful a) (InterruptableProcess q) = ModelState a ': SettingsReader a ': InterruptableProcess q
runEffects (Init sa) m = do
(st, env) <- setup sa
runReader env (evalState st m)
onEvent (Init sa) = update sa
start
:: forall a q h
. ( HasCallStack
, Typeable a
, LogsTo h (InterruptableProcess q)
, Effectful.Server (Stateful a) (InterruptableProcess q)
, Server a q
)
=> StartArgument a q -> Eff (InterruptableProcess q) (Endpoint (Protocol a))
start = Effectful.start . Init
startLink
:: forall a q h
. ( HasCallStack
, Typeable a
, LogsTo h (InterruptableProcess q)
, Effectful.Server (Stateful a) (InterruptableProcess q)
, Server a q
)
=> StartArgument a q -> Eff (InterruptableProcess q) (Endpoint (Protocol a))
startLink = Effectful.startLink . Init
type ModelState a = State (Model a)
modifyModel :: forall a e . Member (ModelState a) e => (Model a -> Model a) -> Eff e ()
modifyModel f = getModel @a >>= putModel @a . f
getAndModifyModel :: forall a e . Member (ModelState a) e => (Model a -> Model a) -> Eff e (Model a)
getAndModifyModel f = getModel @a <* modify f
modifyAndGetModel :: forall a e . Member (ModelState a) e => (Model a -> Model a) -> Eff e (Model a)
modifyAndGetModel f = modifyModel @a f *> getModel @a
getModel :: forall a e . Member (ModelState a) e => Eff e (Model a)
getModel = get
useModel :: forall a b e . Member (ModelState a) e => Getting b (Model a) b -> Eff e b
useModel l = view l <$> getModel @a
putModel :: forall a e . Member (ModelState a) e => Model a -> Eff e ()
putModel = put
getAndPutModel :: forall a e . Member (ModelState a) e => Model a -> Eff e (Model a)
getAndPutModel m = getModel @a <* putModel @a m
zoomModel :: forall a b c e. Member (ModelState a) e => Lens' (Model a) b -> Eff (State b ': e) c -> Eff e c
zoomModel l a = do
m0 <- getModel @a
(c, m1) <- runState (view l m0) a
modifyModel @a (l .~ m1)
return c
type SettingsReader a = Reader (Settings a)
askSettings :: forall a e . Member (SettingsReader a) e => Eff e (Settings a)
askSettings = ask
viewSettings :: forall a b e . Member (SettingsReader a) e => Getting b (Settings a) b -> Eff e b
viewSettings l = view l <$> askSettings @a