{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Another example for the library that uses embedded protocols with multiple server back
-- ends and a polymorphic client, as well as the 'Broker' module to start multiple
-- back-ends.
--
-- @since 0.29.0
module Main where
import Control.DeepSeq
import Control.Eff
import Control.Eff.State.Lazy as State
import Control.Eff.Concurrent
import Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful
import Control.Eff.Concurrent.Protocol.StatefulServer as Stateful
import Control.Eff.Concurrent.Protocol.Broker as Broker
import Control.Lens
import Control.Monad
import Data.Dynamic
import Data.Foldable
import Data.Functor.Contravariant (contramap)
import Data.String
import qualified Data.Text as T
import GHC.Stack (HasCallStack)
import Data.Default
main :: IO ()
main =
defaultMain (void embeddedExample)
embeddedExample :: HasCallStack => Eff Effects ()
embeddedExample = do
b1 <- Stateful.startLink InitBackend1
b2Broker <- startBackend2Broker
b2 <- Broker.spawnOrLookup @Backend2 b2Broker 1
_ <- Broker.spawnOrLookup b2Broker 2
b2_2 <- Broker.spawnOrLookup b2Broker 2
b2_3 <- Broker.spawnOrLookup b2Broker 3
app <- Stateful.startLink InitApp
cast app DoThis
cast app DoThis
cast app DoThis
call app (SetBackend (Just (SomeBackend b1)))
cast app DoThis
cast app DoThis
spawn_ "sub-process" $ do
logNotice "spawned sub process"
b1_2 <- Stateful.startLink InitBackend1
call app (SetBackend (Just (SomeBackend b1_2)))
cast app DoThis
cast app DoThis
exitWithError "test-error"
call app (SetBackend Nothing)
cast app DoThis
cast app DoThis
cast app DoThis
call app (SetBackend (Just (SomeBackend b1)))
cast app DoThis
cast app DoThis
call app (SetBackend Nothing)
cast app DoThis
call app (SetBackend (Just (SomeBackend b2)))
cast app DoThis
cast app DoThis
call app (SetBackend (Just (SomeBackend b2_2)))
cast app DoThis
_ <- Broker.stopChild b2Broker 2
cast app DoThis
call app (SetBackend (Just (SomeBackend b2_3)))
cast app DoThis
Broker.stopBroker b2Broker
cast app DoThis
------------------------------ Server Instances
-- Application layer
instance Stateful.Server App Effects where
newtype instance Model App = MkApp (Maybe SomeBackend) deriving Default
data instance StartArgument App Effects = InitApp
update me _x e =
case e of
OnCall rt (SetBackend b) -> do
logInfo "setting backend"
MkApp oldB <- getAndPutModel @App (MkApp b)
traverse_ (`backendForgetObserver` me) oldB
traverse_ (`backendRegisterObserver` me) b
sendReply rt ()
OnCast (AppBackendEvent be) ->
logInfo ("got backend event: " <> T.pack (show be))
OnCast DoThis ->
do MkApp m <- getModel @App
case m of
Nothing -> logInfo "doing this without backend"
Just b -> handleInterrupts (logWarning . T.pack . show) $ do
doSomeBackendWork b
bi <- getSomeBackendInfo b
logInfo ("doing this. Backend: " <> T.pack bi)
_ -> logWarning ("unexpected: "<>T.pack(show e))
------------------------------ Protocol Data Types
-- Application layer
data App deriving Typeable
instance HasPdu App where
type EmbeddedPduList App = '[Observer BackendEvent]
data Pdu App r where
SetBackend :: Maybe SomeBackend -> Pdu App ('Synchronous ())
DoThis :: Pdu App 'Asynchronous
AppBackendEvent :: Pdu (Observer BackendEvent) r -> Pdu App r
deriving Typeable
instance NFData (Pdu App r) where
rnf (SetBackend !_x) = ()
rnf DoThis = ()
rnf (AppBackendEvent e) = rnf e
instance Show (Pdu App r) where
show (SetBackend _x) = "setting backend"
show DoThis = "doing this"
show (AppBackendEvent e) = "got backend event: " ++ show e
instance HasPduPrism App (Observer BackendEvent) where
embedPdu = AppBackendEvent
fromPdu (AppBackendEvent e) = Just e
fromPdu _ = Nothing
-- Backend
data Backend deriving Typeable
instance HasPdu Backend where
data Pdu Backend r where
BackendWork :: Pdu Backend 'Asynchronous
GetBackendInfo :: Pdu Backend ('Synchronous String)
deriving Typeable
instance NFData (Pdu Backend r) where
rnf BackendWork = ()
rnf GetBackendInfo = ()
instance Show (Pdu Backend r) where
show BackendWork = "BackendWork"
show GetBackendInfo = "GetBackendInfo"
newtype BackendEvent where
BackendEvent :: String -> BackendEvent
deriving (NFData, Show, Typeable)
type IsBackend b =
( HasPdu b
, Embeds b Backend
, IsObservable b BackendEvent
, Tangible (Pdu b ('Synchronous String))
, Tangible (Pdu b 'Asynchronous)
)
data SomeBackend =
forall b . IsBackend b => SomeBackend (Endpoint b)
withSomeBackend ::
SomeBackend
-> (forall b . IsBackend b => Endpoint b -> x )
-> x
withSomeBackend (SomeBackend x) f = f x
backendRegisterObserver
:: ( HasProcesses e q
, CanObserve m BackendEvent
, Embeds m (Observer BackendEvent)
, Tangible (Pdu m 'Asynchronous))
=> SomeBackend
-> Endpoint m
-> Eff e ()
backendRegisterObserver (SomeBackend x) o = registerObserver @BackendEvent x o
backendForgetObserver
:: ( HasProcesses e q
, CanObserve m BackendEvent
, Embeds m (Observer BackendEvent)
, Tangible (Pdu m 'Asynchronous)
)
=> SomeBackend
-> Endpoint m
-> Eff e ()
backendForgetObserver (SomeBackend x) o = forgetObserver @BackendEvent x o
getSomeBackendInfo :: HasProcesses e q => SomeBackend -> Eff e String
getSomeBackendInfo (SomeBackend x) = call x GetBackendInfo
doSomeBackendWork :: HasProcesses e q => SomeBackend -> Eff e ()
doSomeBackendWork (SomeBackend x) = cast x BackendWork
-------------------------
-- Backend 1
data Backend1 deriving Typeable
instance Stateful.Server Backend1 Effects where
type instance Protocol Backend1 = (Backend, ObserverRegistry BackendEvent)
newtype instance Model Backend1 = MkBackend1 (Int, ObserverRegistry BackendEvent)
data instance StartArgument Backend1 Effects = InitBackend1
setup _ _ = pure ( MkBackend1 (0, emptyObserverRegistry), () )
update me _ e = do
model <- getModel @Backend1
case e of
OnCall rt (ToPduLeft GetBackendInfo) ->
sendReply
(toEmbeddedReplyTarget @(Stateful.Protocol Backend1) @Backend rt)
("Backend1 " <> show me <> " " <> show (model ^. modelBackend1 . _1))
OnCast (ToPduLeft BackendWork) -> do
logInfo "working..."
modifyModel @Backend1 (over (modelBackend1 . _1) (+ 1))
OnCast (ToPduRight x) -> do
logInfo "event registration stuff ..."
zoomModel @Backend1 (modelBackend1 . _2) (observerRegistryHandlePdu x)
OnDown pd -> do
logWarning (T.pack (show pd))
wasObserver <- zoomModel @Backend1 (modelBackend1 . _2) (observerRegistryRemoveProcess @BackendEvent (downProcess pd))
when wasObserver $
logNotice "observer removed"
_ -> logWarning ("unexpected: " <> T.pack (show e))
modelBackend1 :: Iso' (Model Backend1) (Int, ObserverRegistry BackendEvent)
modelBackend1 = iso (\(MkBackend1 x) -> x) MkBackend1
-- Backend 2 is behind a broker
data Backend2 deriving Typeable
instance HasPdu Backend2 where
type instance EmbeddedPduList Backend2 = '[Backend, ObserverRegistry BackendEvent]
data instance Pdu Backend2 r where
B2ObserverRegistry :: Pdu (ObserverRegistry BackendEvent) r -> Pdu Backend2 r
B2BackendWork :: Pdu Backend r -> Pdu Backend2 r
deriving Typeable
instance NFData (Pdu Backend2 r) where
rnf (B2BackendWork w) = rnf w
rnf (B2ObserverRegistry x) = rnf x
instance Show (Pdu Backend2 r) where
show (B2BackendWork w) = show w
show (B2ObserverRegistry x) = show x
instance HasPduPrism Backend2 Backend where
embedPdu = B2BackendWork
fromPdu (B2BackendWork x) = Just x
fromPdu _ = Nothing
instance HasPduPrism Backend2 (ObserverRegistry BackendEvent) where
embedPdu = B2ObserverRegistry
fromPdu (B2ObserverRegistry x) = Just x
fromPdu _ = Nothing
instance Effectful.Server Backend2 Effects where
type instance ServerEffects Backend2 Effects = State Int ': ObserverRegistryState BackendEvent ': Effects
data instance Init Backend2 Effects = InitBackend2 Int
serverTitle (InitBackend2 x) = fromString ("backend-2: " ++ show x)
runEffects _me _ e = evalObserverRegistryState (evalState 0 e)
onEvent me _ e = do
myIndex <- get @Int
case e of
OnCall rt (B2BackendWork GetBackendInfo) ->
sendReply rt ("Backend2 " <> show me <> " " <> show myIndex)
OnCast (B2BackendWork BackendWork) -> do
logInfo "working..."
put @Int (myIndex + 1)
when (myIndex `mod` 2 == 0)
(observerRegistryNotify (BackendEvent "even!"))
OnCast (B2ObserverRegistry x) -> do
logInfo "event registration stuff ..."
observerRegistryHandlePdu @BackendEvent x
OnInterrupt NormalExitRequested
| even myIndex -> do
logNotice "Kindly exitting -_-"
exitNormally
| otherwise ->
logNotice "Ignoring exit request! :P"
OnDown pd -> do
logWarning (T.pack (show pd))
wasObserver <- observerRegistryRemoveProcess @BackendEvent (downProcess pd)
when wasObserver $
logNotice "observer removed"
_ -> logWarning ("unexpected: " <> T.pack (show e))
type instance Broker.ChildId Backend2 = Int
startBackend2Broker :: Eff Effects (Endpoint (Broker.Broker Backend2))
startBackend2Broker = Broker.startLink (Broker.MkBrokerConfig (TimeoutMicros 1_000_000) InitBackend2)
-- EXPERIMENTING
data EP a where
EP :: forall a (r :: Synchronicity) . (NFData (Pdu a r), Typeable r) => Receiver (Pdu a r) -> EP a
sendEPCast
:: forall a e q
. (HasProcesses e q)
=> EP a
-> (forall x . Pdu a x)
-> Eff e ()
sendEPCast (EP r) p = sendToReceiver r p
embeddedReceiver
:: forall a b
. (Embeds a b, (forall (r :: Synchronicity) . Typeable r => NFData (Pdu b r) ))
=> EP a
-> EP b
embeddedReceiver (EP r) = EP (contramap embedPdu r)