diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for extensible-effects-concurrent +## 0.29.2 +- Improve `Supervisor` API: Use `Init` from the effectful server as start + argument type. + ## 0.29.1 - Add more constraints to `Embeds` - Improve the `CallbackServer` diff --git a/examples/example-embedded-protocols/Main.hs b/examples/example-embedded-protocols/Main.hs --- a/examples/example-embedded-protocols/Main.hs +++ b/examples/example-embedded-protocols/Main.hs @@ -1,39 +1,56 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NumericUnderscores #-} -- | Another example for the library that uses embedded protocols with multiple server back --- ends and a polymorphic client. +-- ends and a polymorphic client, as well as the 'Supervisor.Sup' 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.StatefulServer as Server +import Control.Eff.Concurrent.Process.Timer +import Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful +import Control.Eff.Concurrent.Protocol.StatefulServer as Stateful +import Control.Eff.Concurrent.Protocol.Supervisor as Supervisor 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) main :: IO () main = defaultMain (void embeddedExample) -embeddedExample :: Eff Effects () +embeddedExample :: HasCallStack => Eff Effects () embeddedExample = do - b1 <- Server.start InitBackend1 - b2 <- Server.start InitBackend2 - app <- Server.start InitApp + b1 <- Stateful.start InitBackend1 + b2Sup <- startBackend2Sup + b2 <- Supervisor.spawnOrLookup @Backend2 b2Sup 1 + _ <- Supervisor.spawnOrLookup b2Sup 2 + b2_2 <- Supervisor.spawnOrLookup b2Sup 2 + b2_3 <- Supervisor.spawnOrLookup b2Sup 3 + app <- Stateful.start InitApp cast app DoThis cast app DoThis cast app DoThis call app (SetBackend (Just (SomeBackend b1))) cast app DoThis cast app DoThis - 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 @@ -41,18 +58,26 @@ 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 - call app (SetBackend Nothing) + _ <- Supervisor.stopChild b2Sup 2 + cast app DoThis + call app (SetBackend (Just (SomeBackend b2_3))) + cast app DoThis + Supervisor.stopSupervisor b2Sup + cast app DoThis + ------------------------------ Server Instances -- Application layer -instance Server.Server App Effects where +instance Stateful.Server App Effects where type instance Model App = Maybe SomeBackend data instance StartArgument App Effects = InitApp update me _x e = @@ -63,11 +88,13 @@ traverse_ (`backendForgetObserver` me) oldB traverse_ (`backendRegisterObserver` me) b sendReply rt () + OnCast (AppBackendEvent be) -> + logInfo ("got backend event: " <> T.pack (show be)) OnCast DoThis -> do m <- getModel @App case m of Nothing -> logInfo "doing this without backend" - Just b -> do + Just b -> handleInterrupts (logWarning . T.pack . show) $ do doSomeBackendWork b bi <- getSomeBackendInfo b logInfo ("doing this. Backend: " <> T.pack bi) @@ -174,7 +201,7 @@ data Backend1 deriving Typeable -instance Server.Server Backend1 Effects where +instance Stateful.Server Backend1 Effects where type instance Protocol Backend1 = (Backend, ObserverRegistry BackendEvent) type instance Model Backend1 = (Int, ObserverRegistry BackendEvent) data instance StartArgument Backend1 Effects = InitBackend1 @@ -184,7 +211,7 @@ case e of OnCall rt (ToPduLeft GetBackendInfo) -> sendReply - (toEmbeddedReplyTarget @(Server.Protocol Backend1) @Backend rt) + (toEmbeddedReplyTarget @(Stateful.Protocol Backend1) @Backend rt) ("Backend1 " <> show me <> " " <> show (model ^. _1)) OnCast (ToPduLeft BackendWork) -> do logInfo "working..." @@ -199,7 +226,7 @@ logNotice "observer removed" _ -> logWarning ("unexpected: " <> T.pack (show e)) --- Backend 2 +-- Backend 2 is behind a supervisor data Backend2 deriving Typeable @@ -228,29 +255,41 @@ fromPdu (B2ObserverRegistry x) = Just x fromPdu _ = Nothing -instance Server.Server Backend2 Effects where - type instance Model Backend2 = (Int, ObserverRegistry BackendEvent) - data instance StartArgument Backend2 Effects = InitBackend2 - setup _ _ = pure ( (0, emptyObserverRegistry), () ) - update me _ e = do - model <- getModel @Backend2 +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 (model ^. _1)) + sendReply rt ("Backend2 " <> show me <> " " <> show myIndex) OnCast (B2BackendWork BackendWork) -> do logInfo "working..." - oldM <- getAndModifyModel @Backend2 (over _1 (+ 1)) - when (fst oldM `mod` 2 == 0) - (zoomModel @Backend2 _2 (observerRegistryNotify (BackendEvent "even!"))) + put @Int (myIndex + 1) + when (myIndex `mod` 2 == 0) + (observerRegistryNotify (BackendEvent "even!")) OnCast (B2ObserverRegistry x) -> do logInfo "event registration stuff ..." - zoomModel @Backend2 _2 (observerRegistryHandlePdu x) + 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 <- zoomModel @Backend2 _2 (observerRegistryRemoveProcess @BackendEvent (downProcess pd)) + wasObserver <- observerRegistryRemoveProcess @BackendEvent (downProcess pd) when wasObserver $ logNotice "observer removed" _ -> logWarning ("unexpected: " <> T.pack (show e)) + +type instance Supervisor.ChildId Backend2 = Int + +startBackend2Sup :: Eff Effects (Endpoint (Supervisor.Sup Backend2)) +startBackend2Sup = Supervisor.startSupervisor (Supervisor.MkSupConfig (TimeoutMicros 1_000_000) InitBackend2) -- EXPERIMENTING data EP a where diff --git a/extensible-effects-concurrent.cabal b/extensible-effects-concurrent.cabal --- a/extensible-effects-concurrent.cabal +++ b/extensible-effects-concurrent.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: extensible-effects-concurrent -version: 0.29.1 +version: 0.29.2 description: Please see the README on GitHub at synopsis: Message passing concurrency as extensible-effect homepage: https://github.com/sheyll/extensible-effects-concurrent#readme diff --git a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs --- a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +++ b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs @@ -623,7 +623,7 @@ logAppendProcInfo pid = let addProcessId = over lmProcessId - (maybe (Just (T.pack (printf "% 9s" (show pid)))) Just) + (maybe (Just (T.pack (printf "% 9s" (show title ++ show pid)))) Just) in censorLogs @(Lift IO) addProcessId triggerProcessLinksAndMonitors :: ProcessId -> Interrupt e -> TVar (Set ProcessId) -> Eff BaseEffects () diff --git a/src/Control/Eff/Concurrent/Protocol/StatefulServer.hs b/src/Control/Eff/Concurrent/Protocol/StatefulServer.hs --- a/src/Control/Eff/Concurrent/Protocol/StatefulServer.hs +++ b/src/Control/Eff/Concurrent/Protocol/StatefulServer.hs @@ -3,6 +3,8 @@ -- @since 0.24.0 module Control.Eff.Concurrent.Protocol.StatefulServer ( Server(..) + , Stateful + , Effectful.Init(..) , start , startLink , ModelState diff --git a/src/Control/Eff/Concurrent/Protocol/Supervisor.hs b/src/Control/Eff/Concurrent/Protocol/Supervisor.hs --- a/src/Control/Eff/Concurrent/Protocol/Supervisor.hs +++ b/src/Control/Eff/Concurrent/Protocol/Supervisor.hs @@ -48,19 +48,20 @@ -- -- @since 0.23.0 module Control.Eff.Concurrent.Protocol.Supervisor - ( Sup() - , ChildId - , StartArgument(MkSupConfig) - , supConfigChildStopTimeout - , SpawnErr(AlreadyStarted) - , startSupervisor + ( startSupervisor , stopSupervisor , isSupervisorAlive , monitorSupervisor , getDiagnosticInfo , spawnChild + , spawnOrLookup , lookupChild , stopChild + , Sup() + , ChildId + , Stateful.StartArgument(MkSupConfig) + , supConfigChildStopTimeout + , SpawnErr(AlreadyStarted) ) where import Control.DeepSeq (NFData(rnf)) @@ -68,7 +69,8 @@ import Control.Eff.Concurrent.Protocol import Control.Eff.Concurrent.Protocol.Client import Control.Eff.Concurrent.Protocol.Wrapper -import Control.Eff.Concurrent.Protocol.StatefulServer as Server +import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful +import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful import Control.Eff.Concurrent.Protocol.Supervisor.InternalState import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Process.Timer @@ -88,6 +90,165 @@ import Control.Applicative ((<|>)) -- * Supervisor Server API + + +-- ** Functions + +-- | Start and link a new supervisor process with the given 'SpawnFun'unction. +-- +-- To spawn new child processes use 'spawnChild'. +-- +-- @since 0.23.0 +startSupervisor + :: forall p e + . ( HasCallStack + , LogIo (Processes e) + , TangibleSup p + , Stateful.Server (Sup p) (Processes e) + ) + => Stateful.StartArgument (Sup p) (Processes e) + -> Eff (Processes e) (Endpoint (Sup p)) +startSupervisor = Stateful.start + +-- | Stop the supervisor and shutdown all processes. +-- +-- Block until the supervisor has finished. +-- +-- @since 0.23.0 +stopSupervisor + :: ( HasCallStack + , HasProcesses e q + , Member Logs e + , Lifted IO e + , TangibleSup p + ) + => Endpoint (Sup p) + -> Eff e () +stopSupervisor ep = do + logInfo ("stopping supervisor: " <> pack (show ep)) + mr <- monitor (_fromEndpoint ep) + sendInterrupt (_fromEndpoint ep) NormalExitRequested + r <- receiveSelectedMessage (selectProcessDown mr) + logInfo ("supervisor stopped: " <> pack (show ep) <> " " <> pack (show r)) + +-- | Check if a supervisor process is still alive. +-- +-- @since 0.23.0 +isSupervisorAlive + :: forall p q0 e . + ( HasCallStack + , Member Logs e + , Typeable p + , HasProcesses e q0 + ) + => Endpoint (Sup p) + -> Eff e Bool +isSupervisorAlive x = isProcessAlive (_fromEndpoint x) + +-- | Monitor a supervisor process. +-- +-- @since 0.23.0 +monitorSupervisor + :: forall p q0 e . + ( HasCallStack + , Member Logs e + , HasProcesses e q0 + , TangibleSup p + ) + => Endpoint (Sup p) + -> Eff e MonitorReference +monitorSupervisor x = monitor (_fromEndpoint x) + +-- | Start and monitor a new child process using the 'SpawnFun' passed +-- to 'startSupervisor'. +-- +-- @since 0.23.0 +spawnChild + :: forall p q0 e . + ( HasCallStack + , Member Logs e + , HasProcesses e q0 + , TangibleSup p + , Typeable (Effectful.ServerPdu p) + ) + => Endpoint (Sup p) + -> ChildId p + -> Eff e (Either (SpawnErr p) (Endpoint (Effectful.ServerPdu p))) +spawnChild ep cId = call ep (StartC cId) + +-- | Start and monitor a new child process using the 'SpawnFun' passed +-- to 'startSupervisor'. +-- +-- Call 'spawnChild' and unpack the 'Either' result, +-- ignoring the 'AlreadyStarted' error. +-- +-- @since 0.29.2 +spawnOrLookup + :: forall p q0 e . + ( HasCallStack + , Member Logs e + , HasProcesses e q0 + , TangibleSup p + , Typeable (Effectful.ServerPdu p) + ) + => Endpoint (Sup p) + -> ChildId p + -> Eff e (Endpoint (Effectful.ServerPdu p)) +spawnOrLookup supEp cId = + do res <- spawnChild supEp cId + pure $ + case res of + Left (AlreadyStarted _ ep) -> ep + Right ep -> ep + +-- | Lookup the given child-id and return the output value of the 'SpawnFun' +-- if the client process exists. +-- +-- @since 0.23.0 +lookupChild :: + forall p e q0 . + ( HasCallStack + , Member Logs e + , HasProcesses e q0 + , TangibleSup p + , Typeable (Effectful.ServerPdu p) + ) + => Endpoint (Sup p) + -> ChildId p + -> Eff e (Maybe (Endpoint (Effectful.ServerPdu p))) +lookupChild ep cId = call ep (LookupC @p cId) + +-- | Stop a child process, and block until the child has exited. +-- +-- Return 'True' if a process with that ID was found, 'False' if no process +-- with the given ID was running. +-- +-- @since 0.23.0 +stopChild :: + forall p e q0 . + ( HasCallStack + , Member Logs e + , HasProcesses e q0 + , TangibleSup p + ) + => Endpoint (Sup p) + -> ChildId p + -> Eff e Bool +stopChild ep cId = call ep (StopC @p cId (TimeoutMicros 4000000)) + +-- | Return a 'Text' describing the current state of the supervisor. +-- +-- @since 0.23.0 +getDiagnosticInfo + :: forall p e q0 . + ( HasCallStack + , HasProcesses e q0 + , TangibleSup p + ) + => Endpoint (Sup p) + -> Eff e Text +getDiagnosticInfo s = call s (GetDiagnosticInfo @p) + -- ** Types -- | The index type of 'Server' supervisors. @@ -106,9 +267,9 @@ -- -- @since 0.23.0 data instance Pdu (Sup p) r where - StartC :: ChildId p -> Pdu (Sup p) ('Synchronous (Either (SpawnErr p) (Endpoint (Protocol p)))) + StartC :: ChildId p -> Pdu (Sup p) ('Synchronous (Either (SpawnErr p) (Endpoint (Effectful.ServerPdu p)))) StopC :: ChildId p -> Timeout -> Pdu (Sup p) ('Synchronous Bool) - LookupC :: ChildId p -> Pdu (Sup p) ('Synchronous (Maybe (Endpoint (Protocol p)))) + LookupC :: ChildId p -> Pdu (Sup p) ('Synchronous (Maybe (Endpoint (Effectful.ServerPdu p)))) GetDiagnosticInfo :: Pdu (Sup p) ('Synchronous Text) deriving Typeable @@ -147,8 +308,10 @@ ( LogIo q , TangibleSup p , Tangible (ChildId p) - , Server p (Processes q) - ) => Server (Sup p) (Processes q) where + , Typeable (Effectful.ServerPdu p) + , Effectful.Server p (Processes q) + , HasProcesses (Effectful.ServerEffects p (Processes q)) q + ) => Stateful.Server (Sup p) (Processes q) where -- | Options that control the 'Sup p' process. -- @@ -163,13 +326,13 @@ -- , supConfigChildRestartPolicy :: ChildRestartPolicy -- , supConfigResilience :: Resilience supConfigChildStopTimeout :: Timeout - , supConfigStartFun :: ChildId p -> Server.StartArgument p (Processes q) + , supConfigStartFun :: ChildId p -> Effectful.Init p (Processes q) } type Model (Sup p) = Children (ChildId p) p setup _ _cfg = pure (def, ()) - update _ supConfig (OnCall rt req) = + update _ supConfig (Stateful.OnCall rt req) = case req of GetDiagnosticInfo -> do p <- (pack . show <$> getChildren @(ChildId p) @p) @@ -191,7 +354,7 @@ mExisting <- lookupChildById @(ChildId p) @p i case mExisting of Nothing -> do - childEp <- raise (raise (Server.start (supConfigStartFun supConfig i))) + childEp <- raise (raise (Effectful.start (supConfigStartFun supConfig i))) let childPid = _fromEndpoint childEp cMon <- monitor childPid putChild i (MkChild @p childEp cMon) @@ -199,7 +362,7 @@ Just existingChild -> sendReply rt (Left (AlreadyStarted i (existingChild ^. childEndpoint))) - update _ _supConfig (OnDown pd) = do + update _ _supConfig (Stateful.OnDown pd) = do oldEntry <- lookupAndRemoveChildByMonitor @(ChildId p) @p (downReference pd) case oldEntry of Nothing -> logWarning ("unexpected: " <> pack (show pd)) @@ -210,7 +373,7 @@ <> " => " <> pack (show (_childEndpoint c)) ) - update _ supConfig (OnInterrupt e) = do + update _ supConfig (Stateful.OnInterrupt e) = do let (logSev, exitReason) = case e of NormalExitRequested -> @@ -227,147 +390,15 @@ -- | Runtime-Errors occurring when spawning child-processes. -- -- @since 0.23.0 -data SpawnErr p = AlreadyStarted (ChildId p) (Endpoint (Protocol p)) +data SpawnErr p = AlreadyStarted (ChildId p) (Endpoint (Effectful.ServerPdu p)) deriving (Typeable, Generic) deriving instance Eq (ChildId p) => Eq (SpawnErr p) deriving instance Ord (ChildId p) => Ord (SpawnErr p) -deriving instance (Typeable (Protocol p), Show (ChildId p)) => Show (SpawnErr p) +deriving instance (Typeable (Effectful.ServerPdu p), Show (ChildId p)) => Show (SpawnErr p) instance NFData (ChildId p) => NFData (SpawnErr p) - --- ** Functions --- | Start and link a new supervisor process with the given 'SpawnFun'unction. --- --- To spawn new child processes use 'spawnChild'. --- --- @since 0.23.0 -startSupervisor - :: forall p e - . ( HasCallStack - , LogIo (Processes e) - , TangibleSup p - , Server (Sup p) (Processes e) - ) - => StartArgument (Sup p) (Processes e) - -> Eff (Processes e) (Endpoint (Sup p)) -startSupervisor = Server.start - --- | Stop the supervisor and shutdown all processes. --- --- Block until the supervisor has finished. --- --- @since 0.23.0 -stopSupervisor - :: ( HasCallStack - , HasProcesses e q - , Member Logs e - , Lifted IO e - , TangibleSup p - ) - => Endpoint (Sup p) - -> Eff e () -stopSupervisor ep = do - logInfo ("stopping supervisor: " <> pack (show ep)) - mr <- monitor (_fromEndpoint ep) - sendInterrupt (_fromEndpoint ep) NormalExitRequested - r <- receiveSelectedMessage (selectProcessDown mr) - logInfo ("supervisor stopped: " <> pack (show ep) <> " " <> pack (show r)) - --- | Check if a supervisor process is still alive. --- --- @since 0.23.0 -isSupervisorAlive - :: forall p q0 e . - ( HasCallStack - , Member Logs e - , Typeable p - , HasProcesses e q0 - ) - => Endpoint (Sup p) - -> Eff e Bool -isSupervisorAlive x = isProcessAlive (_fromEndpoint x) - --- | Monitor a supervisor process. --- --- @since 0.23.0 -monitorSupervisor - :: forall p q0 e . - ( HasCallStack - , Member Logs e - , HasProcesses e q0 - , TangibleSup p - ) - => Endpoint (Sup p) - -> Eff e MonitorReference -monitorSupervisor x = monitor (_fromEndpoint x) - --- | Start, link and monitor a new child process using the 'SpawnFun' passed --- to 'startSupervisor'. --- --- @since 0.23.0 -spawnChild - :: forall p q0 e . - ( HasCallStack - , Member Logs e - , HasProcesses e q0 - , TangibleSup p - , Typeable (Protocol p) - ) - => Endpoint (Sup p) - -> ChildId p - -> Eff e (Either (SpawnErr p) (Endpoint (Protocol p))) -spawnChild ep cId = call ep (StartC cId) - --- | Lookup the given child-id and return the output value of the 'SpawnFun' --- if the client process exists. --- --- @since 0.23.0 -lookupChild :: - forall p e q0 . - ( HasCallStack - , Member Logs e - , HasProcesses e q0 - , TangibleSup p - , Typeable (Protocol p) - ) - => Endpoint (Sup p) - -> ChildId p - -> Eff e (Maybe (Endpoint (Protocol p))) -lookupChild ep cId = call ep (LookupC @p cId) - --- | Stop a child process, and block until the child has exited. --- --- Return 'True' if a process with that ID was found, 'False' if no process --- with the given ID was running. --- --- @since 0.23.0 -stopChild :: - forall p e q0 . - ( HasCallStack - , Member Logs e - , HasProcesses e q0 - , TangibleSup p - ) - => Endpoint (Sup p) - -> ChildId p - -> Eff e Bool -stopChild ep cId = call ep (StopC @p cId (TimeoutMicros 4000000)) - --- | Return a 'Text' describing the current state of the supervisor. --- --- @since 0.23.0 -getDiagnosticInfo - :: forall p e q0 . - ( HasCallStack - , HasProcesses e q0 - , TangibleSup p - ) - => Endpoint (Sup p) - -> Eff e Text -getDiagnosticInfo s = call s (GetDiagnosticInfo @p) - -- Internal Functions stopOrKillChild @@ -379,7 +410,7 @@ , Member Logs e , Member (State (Children (ChildId p) p)) e , TangibleSup p - , Typeable (Protocol p) + , Typeable (Effectful.ServerPdu p) ) => ChildId p -> Child p @@ -392,6 +423,8 @@ sendInterrupt (_fromEndpoint (c^.childEndpoint)) NormalExitRequested r1 <- receiveSelectedMessage ( Right <$> selectProcessDown (c^.childMonitoring) <|> Left <$> selectTimerElapsed t ) + demonitor (c^.childMonitoring) + unlinkProcess (_fromEndpoint (c^.childEndpoint)) case r1 of Left timerElapsed -> do logWarning (pack (show timerElapsed) <> ": child "<> pack (show cId) <>" => " <> pack(show (c^.childEndpoint)) <>" did not shutdown in time") @@ -413,7 +446,7 @@ , Member Logs e , Member (State (Children (ChildId p) p)) e , TangibleSup p - , Typeable (Protocol p) + , Typeable (Effectful.ServerPdu p) ) => Timeout -> Eff e () stopAllChildren stopTimeout = removeAllChildren @(ChildId p) @p >>= pure . Map.assocs >>= traverse_ xxx diff --git a/src/Control/Eff/Concurrent/Protocol/Supervisor/InternalState.hs b/src/Control/Eff/Concurrent/Protocol/Supervisor/InternalState.hs --- a/src/Control/Eff/Concurrent/Protocol/Supervisor/InternalState.hs +++ b/src/Control/Eff/Concurrent/Protocol/Supervisor/InternalState.hs @@ -4,7 +4,7 @@ import Control.Eff as Eff import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Protocol -import Control.Eff.Concurrent.Protocol.StatefulServer +import Control.Eff.Concurrent.Protocol.EffectfulServer import Control.Eff.State.Strict as Eff import Control.Lens hiding ((.=), use) import Data.Default @@ -14,14 +14,14 @@ data Child p = MkChild - { _childEndpoint :: Endpoint (Protocol p) + { _childEndpoint :: Endpoint (ServerPdu p) , _childMonitoring :: MonitorReference } deriving (Generic, Typeable, Eq, Ord) instance NFData (Child o) -instance Typeable (Protocol p) => Show (Child p) where +instance Typeable (ServerPdu p) => Show (Child p) where showsPrec d c = showParen (d>=10) (showString "supervised process: " . shows (_childEndpoint c) . showChar ' ' . shows (_childMonitoring c) ) diff --git a/test/SupervisorTests.hs b/test/SupervisorTests.hs --- a/test/SupervisorTests.hs +++ b/test/SupervisorTests.hs @@ -7,7 +7,8 @@ import Control.DeepSeq import Control.Eff import Control.Eff.Concurrent -import Control.Eff.Concurrent.Protocol.StatefulServer as Server +import Control.Eff.Concurrent.Protocol.EffectfulServer (Event(..)) +import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful import Control.Eff.Concurrent.Protocol.Supervisor as Sup import Control.Eff.Concurrent.Process.Timer import Data.Either (fromRight, isLeft, isRight) @@ -24,7 +25,7 @@ testGroup "Supervisor" (let startTestSup = startTestSupWith ExitWhenRequested (TimeoutMicros 500000) - startTestSupWith e t = Sup.startSupervisor (MkSupConfig t (TestServerArgs e)) + startTestSupWith e t = Sup.startSupervisor (MkSupConfig t (Stateful.Init . TestServerArgs e)) spawnTestChild sup i = Sup.spawnChild sup i >>= either (lift . assertFailure . show) pure in [ runTestCase "The supervisor starts and is shut down" $ do outerSelf <- self @@ -37,7 +38,7 @@ () <- receiveMessage Sup.stopSupervisor sup unlinkProcess testWorker - sup <- receiveMessage :: Eff Effects (Endpoint (Sup.Sup TestProtocol)) + sup <- receiveMessage :: Eff Effects (Endpoint (Sup.Sup (Stateful.Stateful TestProtocol))) supAliveAfter1 <- isSupervisorAlive sup logInfo ("still alive 1: " <> pack (show supAliveAfter1)) lift (supAliveAfter1 @=? True) @@ -265,7 +266,7 @@ | ExitWhenRequested deriving Eq -instance Server TestProtocol Effects where +instance Stateful.Server TestProtocol Effects where update _me (TestServerArgs testMode tId) evt = case evt of OnCast (TestInterruptWith i) -> do @@ -286,4 +287,5 @@ logDebug (pack (show tId) <> ": got some info: " <> pack (show evt)) data instance StartArgument TestProtocol Effects = TestServerArgs TestProtocolServerMode Int -type instance ChildId TestProtocol = Int +type instance ChildId (Stateful.Stateful TestProtocol) = Int +