extensible-effects-concurrent 0.32.0 → 2.0.0
raw patch · 68 files changed
+10915/−11029 lines, 68 filesdep +criteriondep +unliftiodep −pretty-typesdep ~basedep ~data-defaultdep ~deepseqnew-component:exe:extensible-effects-concurrent-example-loadtest
Dependencies added: criterion, unliftio
Dependencies removed: pretty-types
Dependency ranges changed: base, data-default, deepseq, extensible-effects, lens, text, time
Files
- .travis.yml +0/−31
- ChangeLog.md +63/−26
- README.md +58/−52
- benchmark.nix +4/−0
- brittany.yaml +0/−55
- default.nix +31/−1
- examples/example-1/Main.hs +67/−75
- examples/example-2/Main.hs +66/−57
- examples/example-3/Main.hs +22/−21
- examples/example-4/Main.hs +5/−5
- examples/example-embedded-protocols/Main.hs +139/−134
- examples/loadtest/Main.hs +69/−0
- extensible-effects-concurrent.cabal +119/−199
- extensible-effects-concurrent.nix +0/−15
- release.nix +0/−2
- shell.nix +25/−21
- src-benchmark/Main.hs +99/−0
- src/Control/Eff/Concurrent.hs +217/−223
- src/Control/Eff/Concurrent/Misc.hs +0/−52
- src/Control/Eff/Concurrent/Process.hs +1300/−1449
- src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +867/−822
- src/Control/Eff/Concurrent/Process/Interactive.hs +99/−99
- src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs +298/−269
- src/Control/Eff/Concurrent/Process/Timer.hs +223/−179
- src/Control/Eff/Concurrent/Protocol.hs +145/−115
- src/Control/Eff/Concurrent/Protocol/Broker.hs +299/−336
- src/Control/Eff/Concurrent/Protocol/Broker/InternalState.hs +79/−63
- src/Control/Eff/Concurrent/Protocol/CallbackServer.hs +94/−105
- src/Control/Eff/Concurrent/Protocol/Client.hs +132/−131
- src/Control/Eff/Concurrent/Protocol/EffectfulServer.hs +103/−96
- src/Control/Eff/Concurrent/Protocol/Observer.hs +162/−176
- src/Control/Eff/Concurrent/Protocol/Observer/Queue.hs +129/−124
- src/Control/Eff/Concurrent/Protocol/StatefulServer.hs +142/−127
- src/Control/Eff/Concurrent/Protocol/Watchdog.hs +340/−317
- src/Control/Eff/Concurrent/Protocol/Wrapper.hs +100/−73
- src/Control/Eff/Concurrent/Pure.hs +21/−20
- src/Control/Eff/Concurrent/SingleThreaded.hs +26/−27
- src/Control/Eff/ExceptionExtra.hs +122/−119
- src/Control/Eff/Log.hs +54/−65
- src/Control/Eff/Log/Examples.hs +147/−117
- src/Control/Eff/Log/Handler.hs +372/−460
- src/Control/Eff/Log/Message.hs +867/−593
- src/Control/Eff/Log/MessageRenderer.hs +191/−177
- src/Control/Eff/Log/Writer.hs +49/−46
- src/Control/Eff/LogWriter/Async.hs +87/−82
- src/Control/Eff/LogWriter/Console.hs +25/−23
- src/Control/Eff/LogWriter/DebugTrace.hs +26/−24
- src/Control/Eff/LogWriter/File.hs +59/−52
- src/Control/Eff/LogWriter/Rich.hs +42/−35
- src/Control/Eff/LogWriter/UDP.hs +78/−64
- src/Control/Eff/LogWriter/UnixSocket.hs +63/−54
- src/Control/Eff/Loop.hs +12/−10
- stack.yaml +2/−2
- test/BrokerTests.hs +348/−323
- test/Common.hs +90/−102
- test/Debug.hs +3/−4
- test/Driver.hs +11/−1
- test/ForkIOScheduler.hs +152/−156
- test/GenServerTests.hs +68/−57
- test/Interactive.hs +19/−24
- test/LogMessageIdeaTest.hs +0/−482
- test/LoggingTests.hs +133/−95
- test/LoopTests.hs +78/−81
- test/ObserverTests.hs +235/−232
- test/ProcessBehaviourTestCases.hs +1314/−1259
- test/SingleThreadedScheduler.hs +31/−35
- test/WatchdogTests.hs +694/−736
- with-hoogle.nix +0/−22
− .travis.yml
@@ -1,31 +0,0 @@-language: c--sudo: false--addons:- apt:- sources:- - hvr-ghc- packages:- - ghc-8.6.3--before_install:- - mkdir -p ~/.local/bin- - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'- - export PATH=~/.local/bin:/opt/ghc/$GHCVER/bin:$PATH- - chmod a+x ~/.local/bin/stack--install:- - stack --no-terminal --skip-ghc-check setup--script:- - stack --no-terminal --skip-ghc-check build- - stack --no-terminal --skip-ghc-check build --test --test-arguments '-p "$0 !~ /Loops WITH space leaks/ " --num-threads=2'- - stack --no-terminal --skip-ghc-check haddock--cache:- directories:- - ~/.stack- - ~/.local- - ~/.stack-work-cache- apt: true
ChangeLog.md view
@@ -1,24 +1,61 @@ # Changelog for extensible-effects-concurrent +## 1.0.0++- **[Timer](./src/Control/Eff/Concurrent/Process/Timer.hs)**+ - Allow timers to have custom initial debug log messages++- **[Process](./src/Control/Eff/Concurrent/Process.hs)**+ - Split `Interrupt` into `ShutdownReason` and `InterruptReason`+ - Rename `isProcessDownInterrupt` to `isLinkedProcessCrashed`+ - Remove experimental type-safe `Receiver` type+ - Rename `StrictDynamic` to `Message`++- **[Logging](./src/Control/Eff/Log/Message.hs)**+ - Rename `LogMessage(...)` to `LogEvent(...)`+ - Introduce a newtype and a type class for log messages: `LogMsg` and `ToLogMsg`+ - An effort to move towards a specialized `ToLogMsg` class instead of+ relying on `Show`+ - The new type class `ToLogEventSender` is+ now used by the logging emitting functions+ like e.g.: `logDebug`, `logInfo`, etc.+ This allows to rewrite:++ logNotice ("dettaching: " <> pack (show deadBroker) <> " from: " <> pack (show broker))++ as:++ logNotice "dettaching: " deadBroker " from: " broker++ - Add `StringLogMsg` with the `MSG` constructor+ - Add `AsLogMsg` and `showAsLogMsg`+ - Remove `errorMessageIO`, `infoMessageIO` and `debugMessageIO`+ - Change the `appName` parameter type in some `LogWriter`s from `Text` to `String`++- **Protocol-Server**+ - All protocol server type class instances now expect `ToLogMsg` or `ToTypeLogMsg`+ instances where `Show` and `Typeable` was used before.+ - Remove the phantom type parameter of `Watchdog.CrashReport`+ ## 0.32.0 - **Protocol-Server** - Remove effect parameter from `StartArgument` and `Init`- + - **ForkIO Scheduler** - Fix monitor reference leak - Shorten the process detail output, and return it from `getProcessState` - **Async Logging**- - Fix the Asynchronous LogWriter so it does not stop logging after a flood of log messages- + - Fix the asynchronous LogWriter so it does not stop logging after a flood of log messages + ## 0.31.0 - **Logging** - Fix runtime crash caused by logging- See: [#2](https://github.com/sheyll/extensible-effects-concurrent/issues/2) + See: [#2](https://github.com/sheyll/extensible-effects-concurrent/issues/2) - Replace polymorphic `LogWriter` with a monomorphic one based on `IO` - Rename type aliases:@@ -26,42 +63,42 @@ - `LogIo` -> `IoLogging` - Remove `Capturing` log writer - Remove `Capturing` log writer- - Fix ghci log buffering issue - [#1](https://github.com/sheyll/extensible-effects-concurrent/issues/1) - + - Fix ghci log buffering issue+ [#1](https://github.com/sheyll/extensible-effects-concurrent/issues/1)+ ## 0.30.0 - Improve inline code documentation-- **Supervisor:** - - Rename to **[Broker](./src/Control/Eff/Concurrent/Protocol/Broker.hs)** - - Add the `ChildEvent` needed by the new **watchdog** +- **Supervisor:**+ - Rename to **[Broker](./src/Control/Eff/Concurrent/Protocol/Broker.hs)**+ - Add the `ChildEvent` needed by the new **watchdog** - Add `callById` and `castById` - [Process](./src/Control/Eff/Concurrent/Process.hs) - Introduce a new `Interrupt NoRecovery` clause: `ExitOtherProcessNotRunning`- - Change the second parameter of `ProcessDown` from `SomeExitReason` to `Interrupt NoRecovery`+ - Change the second parameter of `ProcessDown` from `InterruptOrShutdown` to `Interrupt NoRecovery` - Introduce new `Interrupt` reasons for all categories with an existential parameter, that must have `NFData`, `Show` and `Typeable` constraints.- - Introduce a new timing primitive: `Delay` + - Introduce a new timing primitive: `Delay` - [StatefulServer](./src/Control/Eff/Concurrent/Protocol/StatefulServer.hs) - _Upgrade_ the associated **type alias** `Model` to an associated **type**.- - Add `mapEffects` - - Add `coerceEffects` + - Add `mapEffects`+ - Add `coerceEffects` - Export the `TimeoutMicros` constructor-- Add **[Watchdog](./src/Control/Eff/Concurrent/Protocol/Watchdog.hs)** a server that watches +- Add **[Watchdog](./src/Control/Eff/Concurrent/Protocol/Watchdog.hs)** a server that watches a **[Broker](./src/Control/Eff/Concurrent/Protocol/Broker.hs)** and restarts crashed processes registered at the broker.- + - **[Logging](./src/Control/Eff/Log.hs)** - Add `logCallStack`- - Add `logMultiLine` + - Add `logMultiLine` - **[Timer](./src/Control/Eff/Concurrent/Process/Timer.hs)** - Allow timers to have custom titles via: - `sendAfterWithTitle` - `startTimerWithTitle`- - Switch to use the new `Delay` primitive - + - Switch to use the new `Delay` primitive+ ## 0.29.2 - Improve `Supervisor` API: Use `Init` from the effectful server as start argument type.@@ -71,10 +108,10 @@ - Improve the `CallbackServer` - Add `LogWriterEffects` - Rewrite `HandleLogWriter` so that the instance types have to be effects.- TL,DR; This allows shorter type signatures than before. + TL,DR; This allows shorter type signatures than before. ## 0.29.0-- Remove the reply type parameter from `HasPdu` +- Remove the reply type parameter from `HasPdu` - Make a new constraint `Embeds` that replaces `EmbedProtocol` - Rename `EmbedProtocol` to `HasPduPrism` - Add `EmbeddedPduList` to `HasPdu`@@ -93,16 +130,16 @@ - Improve/fix `EmbedProtocol` type class - Add a _this_ like parameter to the methods of `EffectfulServer` - Rename `IsPdu` to `HasPdu`-- Remove `GenServer` from `EffectfulServer` and put it into a +- Remove `GenServer` from `EffectfulServer` and put it into a new module: `Control.Eff.Concurrent.Protocol.CallbackServer` - Rename `Control.Eff.Concurrent.Protocol.Request` to `(...).Wrapper` ## 0.26.1 - Documentation fixes-- `Supervisor`: Don't start a new process when a process for a child-id exists +- `Supervisor`: Don't start a new process when a process for a child-id exists ## 0.26.0-- Introduce `ReplyTarget` +- Introduce `ReplyTarget` - Change the `sendReply` signature to accept a `ReplyTarget` ## 0.25.1@@ -373,7 +410,7 @@ - Rewrite logging to be a `Reader` of a `LogWriter` - Remove pure logging, the `Logs...` constraint must be accompanied by `Lifted IO` (or `MonadIO`) in many log functions- most prominently `logMsg`+ most prominently `sendLogEvent` - Add a `lmDistance` field in `LogMessage` - Add `increaseLogMessageDistance` and `dropDistantLogMessages` using the new `lmDistance` field@@ -412,7 +449,7 @@ ## 0.7.1 - Improve call-stack support in log messages-- Expose `setLogMessageTimestamp` and `setLogMessageThreadId`+- Expose `setLogEventsTimestamp` and `setLogEventsThreadId` ## 0.7.0
README.md view
@@ -1,18 +1,26 @@ # extensible-effects-concurrent -[](https://travis-ci.org/sheyll/extensible-effects-concurrent)+# DEPRECATION WARNING +**THIS PROJECT WILL NO LONGER BE MAINTAINED AND I ACTIVELY ADVISE AGAINST USING IT**++While some ideas seemed wortwhile, I realized that this project could not perform as good as+I had hoped under high load.++This project is deprecated in favor of a small library that encapsulates+only a tiny wrapper around TVars and forkIO.+ [](http://hackage.haskell.org/package/extensible-effects-concurrent) ## From Erlang to Haskell -This project is an attempt to implement core ideas learned from the **Erlang/OTP** +This project is an attempt to implement core ideas learned from the **Erlang/OTP** framework in Haskell using **[extensible-effects](http://hackage.haskell.org/package/extensible-effects)**. This library sketches my personal history of working on a large, real world Erlang-application, trying to bring some of the ideas over to Haskell.+application, trying to bring some ideas over to Haskell. -I know about cloud-haskell and transient, but I wanted something based on +I know about cloud-haskell and transient, but I wanted something based on 'extensible-effects', and I also wanted to deepen my understanding of it. ### Modeling an Application with Processes@@ -38,14 +46,14 @@ replyToMe <- self sendMessage person replyToMe personName <- receiveMessage- logInfo' ("I just met " ++ personName)+ logInfo "I just met " (personName :: String) alice :: Eff Effects () alice = do logInfo "I am waiting for someone to ask me..." sender <- receiveMessage sendMessage sender ("Alice" :: String)- logInfo' (show sender ++ " message received.")+ logInfo sender " message received." ``` This is taken from [example-4](./examples/example-4/Main.hs).@@ -71,14 +79,14 @@ ``` The mental model of the programming framework regards objects as **processes**-with an isolated internal state. +with an isolated internal state. **[Processes](http://hackage.haskell.org/package/extensible-effects-concurrent-0.25.0/docs/Control-Eff-Concurrent-Process.html)** are at the center of that contraption. All *actions* happen in processes, and all *interactions* happen via messages sent-between processes. +between processes. This is called **Message Passing Concurrency**;-in this library it is provided via the **`Process`** effect. +in this library it is provided via the **`Process`** effect. The **`Process`** effect itself is just an *abstract interface*. @@ -97,13 +105,13 @@ ### Process Life-Cycles and Interprocess Links -All processes except the first process are **`spawned`** by existing +All processes except the first process are **`spawned`** by existing processes. When a process **`spawns`** a new process they are independent apart from the fact that the parent knows the process-id of the spawend child process.- -Processes can **monitor** each other to be notified when a communication partner exits, ++Processes can **monitor** each other to be notified when a communication partner exits, potentially in unforseen ways. Similarily processes may choose to mutually **link** each other.@@ -111,18 +119,18 @@ That allows to model **trees** in which processes watch and start or restart each other. -Because processes never share memory, the internal - possibly broken - state of +Because processes never share memory, the internal - possibly broken - state of a process is gone, when a process exits; hence restarting a process will not-be bothered by left-over, possibly inconsistent, state. +be bothered by left-over, possibly inconsistent, state. -### Timers +### Timers [The Timer module](src/Control/Eff/Concurrent/Process/Timer.hs) contains functions to send messages after a time has passed, and reiceive messages with timeouts. ### More Type-Safety: [The Protocol Metaphor](./src/Control/Eff/Concurrent/Protocol.hs) -As the library carefully leaves the realm of untyped messages, it uses the +As the library carefully leaves the realm of untyped messages, it uses the concept of a **protocol** that governs the communication between concurrent processes, which are either **protocol servers** or **clients** as a metaphor.@@ -131,15 +139,15 @@ The idea is to indicate such a _protocol_ using a **custom data type**, e.g. `data TemperatureSensorReader` or `data SqlServer`.- + The library consists some tricks to restrict the kinds of messages that are acceptable when communicating with processes _adhering to the protocol_. This _protocol_ is not encoded in the users code, but rather something that-the programmer keeps in his head. +the programmer keeps in his head. -In order to be appreciated by authors of real world applications, the -protocol can be defined by giving an abstract message sum-type and +In order to be appreciated by authors of real world applications, the+protocol can be defined by giving an abstract message sum-type and code for spawning server processes. It focusses on these questions:@@ -153,11 +161,11 @@ that could even be a so called __phantom type__, i.e. a type without any runtime values: -```haskell +```haskell -data UserRegistry -- look mom, no constructors!! +data UserRegistry -- look mom, no constructors!! -``` +``` Such a type exists only for the type system. @@ -165,14 +173,14 @@ and for defining type class and type family instances, e.g. -```haskell +```haskell newtype Endpoint protocol = MkServer { _processId :: ProcessId } data UserRegistry startUserRegistry :: Eff e (Endpoint UserRegistry)-startUserRegistry = +startUserRegistry = error "just an example" ```@@ -190,10 +198,10 @@ The `ProcessId` of a process identifies the messages box that `receiveMessage` will use, when waiting for an incoming message. -While it defines _where_ the messages are collected, it does +While it defines _where_ the messages are collected, it does not restrict or inform about _what_ data is handled by a process. -An [Endpoint](https://hackage.haskell.org/package/extensible-effects-concurrent/docs/Control-Eff-Concurrent-Protocol.html#t:Endpoint) is a wrapper +An [Endpoint](https://hackage.haskell.org/package/extensible-effects-concurrent/docs/Control-Eff-Concurrent-Protocol.html#t:Endpoint) is a wrapper around the `ProcessId` that takes a _type parameter_. The type does not have to have any values, it can be a phantom type.@@ -208,29 +216,29 @@ It is therefore helpful to be able to compose protocols. -The machinery in this library allows to list several +The machinery in this library allows to list several PDU instances understood by endpoints of a given protocol phantom type. -#### Protocol Clients +#### Protocol Clients -_Clients_ use a protocol by sending `Pdu`s indexed by +_Clients_ use a protocol by sending `Pdu`s indexed by some protocol phantom type to a server process. Clients use `Endpoint`s to address these servers, and the functions defined in [the corresponding module](https://hackage.haskell.org/package/extensible-effects-concurrent/docs/Control-Eff-Concurrent-Protocol-Client.html). -Most important are these two functions: +Most important are these two functions: * [cast](https://hackage.haskell.org/package/extensible-effects-concurrent/docs/Control-Eff-Concurrent-Protocol-Client.html#v:cast) to send fire-and-forget messages- + * [call](https://hackage.haskell.org/package/extensible-effects-concurrent/docs/Control-Eff-Concurrent-Protocol-Client.html#v:cast) to send RPC-style requests and wait (block) for the responses.- Also, when the server is not running, or crashes in + Also, when the server is not running, or crashes in while waiting, the calling process is interrupted -#### Protocol Servers +#### Protocol Servers This library offers an API for defining practically safe to use __protocol servers__:@@ -238,51 +246,50 @@ * [EffectfulServer](./src/Control/Eff/Concurrent/Protocol/EffectfulServer.hs) This modules defines the framework of a process, that has a callback function that is repeatedly called when ever a message was received.- - The callback may rely on any extra effects (extensible effects). + The callback may rely on any extra effects (extensible effects).+ * [StatefulServer](./src/Control/Eff/Concurrent/Protocol/StatefulServer.hs) A server based on the `EffectfulServer` that includes the definition of- in internal state called __Model__, and some nice + in internal state called __Model__, and some nice helper functions to access the model. These functions- allow the use of lenses. - Unlike the effectful server, the effects that the + allow the use of lenses.+ Unlike the effect server, the effects that the callback functions can use are defined in this module. * [CallbackServer](./src/Control/Eff/Concurrent/Protocol/CallbackServer.hs) A server based on the `EffectfulServer` that does not require a type class- instance like the stateful and effectful servers do.+ instance like the stateful and effect servers do. It can be used to define _inline_ servers.- + #### Events and Observers -A parameterized protocol for event handling is provided in +A parameterized protocol for event handling is provided in the module: -* [Observer](./src/Control/Eff/Concurrent/Protocol/Observer.hs) - +* [Observer](./src/Control/Eff/Concurrent/Protocol/Observer.hs) + #### Brokers and Watchdogs -A key part of a robust system is monitoring and possibly restarting +A key part of a robust system is monitoring and possibly restarting stuff that crashes, this is done in conjunction by two modules: * [Broker](./src/Control/Eff/Concurrent/Protocol/Broker.hs) * [Watchdog](./src/Control/Eff/Concurrent/Protocol/Watchdog.hs) -A client of a process that might be restarted cannot use the `ProcessId` -directly, but has to use an abstract ID and lookup the `ProcessId` from a -process **[broker](./src/Control/Eff/Concurrent/Protocol/Broker.hs)**, that manages the current `ProcessId` of protocol server+A client of a process that might be restarted cannot use the `ProcessId`+directly, but has to use an abstract ID and lookup the `ProcessId` from a process **[broker](./src/Control/Eff/Concurrent/Protocol/Broker.hs)**, that manages the current `ProcessId` of protocol server processes. That way, when ever the server process registered at a broker crashes,-**a [watchdog](./src/Control/Eff/Concurrent/Protocol/Watchdog.hs) process** can (re-)start the crashed server. +**a [watchdog](./src/Control/Eff/Concurrent/Protocol/Watchdog.hs) process** can (re-)start the crashed server. ### Additional services -Currently a **logging effect** is also part of the code base.+Currently, a **logging effect** is also part of the code base. ## Usage and Implementation -Should work with `stack`, `cabal` and `nix`. +Should work with `stack`, `cabal` and `nix`. ### Required GHC Extensions @@ -292,7 +299,6 @@ - AllowAmbiguousTypes - TypeApplications- ## Planned Features
+ benchmark.nix view
@@ -0,0 +1,4 @@+{ withProfiling ? false+}:+(import ./default.nix { inherit withProfiling; }).extensible-effects-concurrent.components.benchmarks.extensible-effects-concurrent-bench+
− brittany.yaml
@@ -1,55 +0,0 @@-conf_debug:- dconf_roundtrip_exactprint_only: false- dconf_dump_bridoc_simpl_par: false- dconf_dump_ast_unknown: false- dconf_dump_bridoc_simpl_floating: false- dconf_dump_config: false- dconf_dump_bridoc_raw: false- dconf_dump_bridoc_final: false- dconf_dump_bridoc_simpl_alt: false- dconf_dump_bridoc_simpl_indent: false- dconf_dump_annotations: false- dconf_dump_bridoc_simpl_columns: false- dconf_dump_ast_full: false-conf_forward:- options_ghc:- - -XLambdaCase- - -XMultiWayIf- - -XGADTs- - -XViewPatterns- - -XTupleSections- - -XExplicitForAll- - -XQuasiQuotes- - -XTemplateHaskell- - -XBangPatterns- - -XTypeInType- - -XTypeApplications- - -XTypeFamilies-conf_errorHandling:- econf_ExactPrintFallback: ExactPrintFallbackModeInline- econf_Werror: false- econf_omit_output_valid_check: false- econf_produceOutputOnErrors: false-conf_preprocessor:- ppconf_CPPMode: CPPModeAbort- ppconf_hackAroundIncludes: false-conf_version: 1-conf_layout:- lconfig_reformatModulePreamble: true- lconfig_altChooser:- tag: AltChooserBoundedSearch- contents: 3- lconfig_allowSingleLineExportList: false- lconfig_importColumn: 50- lconfig_hangingTypeSignature: false- lconfig_importAsColumn: 50- lconfig_alignmentLimit: 30- lconfig_indentListSpecial: true- lconfig_indentAmount: 2- lconfig_alignmentBreakOnMultiline: true- lconfig_cols: 80- lconfig_indentPolicy: IndentPolicyFree- lconfig_indentWhereSpecial: true- lconfig_columnAlignMode:- tag: ColumnAlignModeMajority- contents: 0.7
default.nix view
@@ -1,1 +1,31 @@-import ./extensible-effects-concurrent.nix +{ pkgs ? (import nix/pkgs.nix { })+, withProfiling ? false+}:+pkgs.haskell-nix.project {+ src = pkgs.haskell-nix.haskellLib.cleanGit {+ name = "extensible-effects-concurrent";+ src = ./.;+ };+ projectFileName = "cabal.project";+ # compiler-nix-name = "ghc8102";+ compiler-nix-name = "ghc865";+ pkg-def-extras = [ ];+ modules =+ [+ {+ packages.extensible-effects-concurrent.components.library.doCoverage = false;+ }+ ] +++ (if withProfiling then+ [{+ packages.extensible-effects-concurrent.components.library.enableLibraryProfiling = true;+ packages.extensible-effects-concurrent.components.exes.extensible-effects-concurrent-example-1.enableExecutableProfiling = true;+ packages.extensible-effects-concurrent.components.exes.extensible-effects-concurrent-example-2.enableExecutableProfiling = true;+ packages.extensible-effects-concurrent.components.exes.extensible-effects-concurrent-example-3.enableExecutableProfiling = true;+ packages.extensible-effects-concurrent.components.exes.extensible-effects-concurrent-example-4.enableExecutableProfiling = true;+ packages.extensible-effects-concurrent.components.exes.extensible-effects-concurrent-example-loadtest.enableExecutableProfiling = true;+ packages.extensible-effects-concurrent.components.tests.extensible-effects-concurrent-test.enableExecutableProfiling = true;+ }] else [ ]);++}+
examples/example-1/Main.hs view
@@ -1,63 +1,65 @@ -- | A complete example for the library module Main where -import GHC.Stack-import Control.Eff-import Control.Monad-import Data.Dynamic-import Control.Eff.Concurrent+import Control.DeepSeq+import Control.Eff+import Control.Eff.Concurrent import qualified Control.Eff.Concurrent.Protocol.CallbackServer as Callback-import Control.Eff.Concurrent.Protocol.EffectfulServer as Server-import qualified Control.Exception as Exc-import qualified Data.Text as T-import Control.DeepSeq-import Data.Type.Pretty+import Control.Eff.Concurrent.Protocol.EffectfulServer as Server+import qualified Control.Exception as Exc+import Control.Monad+import Data.Dynamic data TestProtocol- deriving Typeable+ deriving (Typeable) -type instance ToPretty TestProtocol = PutStr "test"+instance ToTypeLogMsg TestProtocol where+ toTypeLogMsg _ = "TestProtocol" instance HasPdu TestProtocol where- data instance Pdu TestProtocol x where+ data Pdu TestProtocol x where SayHello :: String -> Pdu TestProtocol ('Synchronous Bool) Shout :: String -> Pdu TestProtocol 'Asynchronous Terminate :: Pdu TestProtocol ('Synchronous ())- TerminateError :: String -> Pdu TestProtocol ('Synchronous ())+ TerminateError :: LogMsg -> Pdu TestProtocol ('Synchronous ()) deriving (Typeable) +instance ToLogMsg (Pdu TestProtocol r) where+ toLogMsg = \case+ SayHello x -> packLogMsg "Hello " <> packLogMsg x+ Shout x -> packLogMsg "HEEELLLOOOO " <> packLogMsg x+ Terminate -> packLogMsg "terminate normally"+ TerminateError x -> packLogMsg "terminate with error: " <> x+ instance NFData (Pdu TestProtocol x) where rnf (SayHello s) = rnf s rnf (Shout s) = rnf s rnf Terminate = () rnf (TerminateError s) = rnf s - data MyException = MyException- deriving Show+ deriving (Show) instance Exc.Exception MyException -deriving instance Show (Pdu TestProtocol x)- main :: IO () main = defaultMain example -mainProcessSpawnsAChildAndReturns :: HasCallStack => Eff Effects ()+mainProcessSpawnsAChildAndReturns :: Eff Effects () mainProcessSpawnsAChildAndReturns = void (spawn "some child" (void receiveAnyMessage)) -example:: HasCallStack => Eff Effects ()+example :: Eff Effects () example = do me <- self- logInfo (T.pack ("I am " ++ show me))+ logInfo (LABEL "I am " me) server <- testServerLoop- logInfo (T.pack ("Started server " ++ show server))+ logInfo (LABEL "Started server" server) let go = do lift (putStr "Enter something: ") x <- lift getLine case x of ('K' : rest) -> do- call server (TerminateError rest)+ call server (TerminateError (packLogMsg rest)) go ('S' : _) -> do call server Terminate@@ -68,61 +70,51 @@ ('R' : rest) -> do replicateM_ (read rest) (cast server (Shout x)) go- ('q' : _) -> logInfo "Done."- _ -> do+ ('q' : _) -> logInfo (MSG "Done.")+ _ -> do res <- call server (SayHello x)- logInfo (T.pack ("Result: " ++ show res))+ logInfo (LABEL "Result" res) go go testServerLoop :: Eff Effects (Endpoint TestProtocol) testServerLoop = Callback.startLink (Callback.callbacks handleReq "test-server-1")- where- handleReq :: Endpoint TestProtocol -> Event TestProtocol -> Eff Effects ()- handleReq me (OnCall rt cm) =- case cm of- Terminate -> do- logInfo (T.pack (show me ++ " exiting"))- sendReply rt ()- interrupt NormalExitRequested-- TerminateError e -> do- logInfo (T.pack (show me ++ " exiting with error: " ++ e))- sendReply rt ()- interrupt (ErrorInterrupt e)-- SayHello mx ->- case mx of- "e1" -> do- logInfo (T.pack (show me ++ " raising an error"))- interrupt (ErrorInterrupt "No body loves me... :,(")-- "e2" -> do- logInfo (T.pack (show me ++ " throwing a MyException "))- void (lift (Exc.throw MyException))-- "self" -> do- logInfo (T.pack (show me ++ " casting to self"))- cast me (Shout "from me")- sendReply rt False-- "stop" -> do- logInfo (T.pack (show me ++ " stopping me"))- sendReply rt False- interrupt (ErrorInterrupt "test error")-- x -> do- logInfo (T.pack (show me ++ " Got Hello: " ++ x))- sendReply rt (length x > 3)-- handleReq me (OnCast (Shout x)) = do- logInfo (T.pack (show me ++ " Shouting: " ++ x))-- handleReq me (OnInterrupt msg) = do- logInfo (T.pack (show me ++ " is exiting: " ++ show msg))- logProcessExit msg- interrupt msg-- handleReq me wtf =- logCritical (T.pack (show me ++ " WTF: " ++ show wtf))-+ where+ handleReq :: Endpoint TestProtocol -> Event TestProtocol -> Eff Effects ()+ handleReq me (OnCall rt cm) =+ case cm of+ Terminate -> do+ logInfo me (MSG "exiting")+ sendReply rt ()+ interrupt NormalExitRequested+ TerminateError e -> do+ logInfo me (LABEL "exiting with error" e)+ sendReply rt ()+ interrupt (ErrorInterrupt e)+ SayHello mx ->+ case mx of+ "e1" -> do+ logInfo me (MSG "raising an error")+ interrupt (ErrorInterrupt "No body loves me... :,(")+ "e2" -> do+ logInfo me (MSG "throwing a MyException")+ void (lift (Exc.throw MyException))+ "self" -> do+ logInfo me (MSG "casting to self")+ cast me (Shout "from me")+ sendReply rt False+ "stop" -> do+ logInfo me (MSG "stopping me")+ sendReply rt False+ interrupt (ErrorInterrupt "test error")+ x -> do+ logInfo me (LABEL "Got Hello" x)+ sendReply rt (length x > 3)+ handleReq me (OnCast (Shout x)) = do+ logInfo me (LABEL "Shouting" x)+ handleReq me (OnInterrupt msg) = do+ logInfo me (LABEL "is exiting" msg)+ logProcessExit msg+ interrupt msg+ handleReq me wtf =+ logCritical me (LABEL "WTF" wtf)
examples/example-2/Main.hs view
@@ -1,41 +1,46 @@+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-}+ -- | Another complete example for the library module Main where -import Data.Dynamic-import Control.Eff-import Control.Eff.Concurrent.SingleThreaded-import Control.Eff.Concurrent.Protocol.StatefulServer-import Control.Monad-import Data.Foldable-import Control.Lens-import Control.Concurrent-import Control.DeepSeq-import qualified Data.Text as T-import Data.Type.Pretty-import Data.Default+import Control.Concurrent+import Control.DeepSeq+import Control.Eff+import Control.Eff.Concurrent.Protocol.StatefulServer+import Control.Eff.Concurrent.SingleThreaded+import Control.Lens+import Control.Monad+import Data.Default+import Data.Dynamic+import Data.Foldable main :: IO () main = defaultMain (void counterExample) -- * First API -data Counter deriving Typeable--type instance ToPretty Counter = PutStr "counter"+data Counter deriving (Typeable) instance HasPdu Counter where- data instance Pdu Counter x where+ data Pdu Counter x where Inc :: Pdu Counter 'Asynchronous Cnt :: Pdu Counter ('Synchronous Integer)- deriving Typeable+ deriving (Typeable) +instance ToTypeLogMsg Counter where+ toTypeLogMsg _ = "Counter"++instance ToLogMsg (Pdu Counter x) where+ toLogMsg Inc = packLogMsg "increment"+ toLogMsg Cnt = packLogMsg "get-count"+ instance NFData (Pdu Counter x) where rnf Inc = () rnf Cnt = () -counterExample- :: Eff Effects ()+counterExample ::+ Eff Effects () counterExample = do c <- spawnCounter let cp = _fromEndpoint c@@ -64,15 +69,20 @@ lift (threadDelay 500000) lift (threadDelay 500000) -data SupiDupi deriving Typeable--type instance ToPretty SupiDupi = PutStr "supi dupi"+data SupiDupi deriving (Typeable) instance HasPdu SupiDupi where- data instance Pdu SupiDupi r where+ data Pdu SupiDupi r where Whoopediedoo :: Bool -> Pdu SupiDupi ('Synchronous (Maybe ()))- deriving Typeable+ deriving (Typeable) +instance ToTypeLogMsg SupiDupi where+ toTypeLogMsg _ = "SupiDupi"++instance ToLogMsg (Pdu SupiDupi r) where+ toLogMsg (Whoopediedoo f) =+ packLogMsg "whoopediedoo: " <> toLogMsg f+ instance Show (Pdu SupiDupi r) where show (Whoopediedoo True) = "woopediedooo" show (Whoopediedoo False) = "no woopy doopy"@@ -81,23 +91,22 @@ rnf (Whoopediedoo b) = rnf b newtype CounterChanged = CounterChanged Integer- deriving (Show, Typeable, NFData)+ deriving (Show, Typeable, NFData, ToLogMsg) -type instance ToPretty CounterChanged = PutStr "counter changed"+instance ToTypeLogMsg CounterChanged where+ toTypeLogMsg _ = "CounterChanged" type SupiCounter = (Counter, ObserverRegistry CounterChanged, SupiDupi) -type instance ToPretty (Counter, ObserverRegistry CounterChanged, SupiDupi) = PutStr "supi-counter"- instance (IoLogging q) => Server SupiCounter (Processes q) where-- newtype instance Model SupiCounter = SupiCounterModel- ( Integer- , ObserverRegistry CounterChanged- , Maybe (ReplyTarget SupiCounter (Maybe ()))- )+ newtype Model SupiCounter+ = SupiCounterModel+ ( Integer,+ ObserverRegistry CounterChanged,+ Maybe (ReplyTarget SupiCounter (Maybe ()))+ ) - data instance StartArgument SupiCounter = MkEmptySupiCounter+ data StartArgument SupiCounter = MkEmptySupiCounter setup _ _ = return (SupiCounterModel (0, emptyObserverRegistry, Nothing), ()) @@ -109,61 +118,61 @@ ToPdu2 _ -> error "unreachable" ToPdu3 (Whoopediedoo c) -> modifyModel @SupiCounter (supiTarget .~ if c then Just rt else Nothing)- OnCast castReq -> case castReq of ToPdu1 Inc -> do val' <- view supiCounter <$> modifyAndGetModel (supiCounter %~ (+ 1)) zoomModel supiRegistry (observerRegistryNotify (CounterChanged val')) when (val' > 5) $- getAndModifyModel (supiTarget .~ Nothing)- >>= traverse_ (\rt' -> sendReply rt' (Just ())) . view supiTarget+ getAndModifyModel (supiTarget .~ Nothing)+ >>= traverse_ (\rt' -> sendReply rt' (Just ())) . view supiTarget ToPdu2 x -> zoomModel supiRegistry (observerRegistryHandlePdu x) ToPdu3 _ -> error "unreachable"- OnDown pd -> do wasRemoved <- zoomModel supiRegistry (observerRegistryRemoveProcess @CounterChanged (downProcess pd)) if wasRemoved- then logDebug ("removed: " <> T.pack (show pd))- else logError ("unexpected: " <> T.pack (show pd))+ then logDebug (LABEL "removed" pd)+ else logError (LABEL "unexpected" pd)+ other -> logWarning other - other -> logWarning (T.pack (show other))+instance ToLogMsg (StartArgument SupiCounter) where+ toLogMsg _ = packLogMsg "start arg: supi counter" supiCounter :: Lens' (Model SupiCounter) Integer supiCounter = lens- (\(SupiCounterModel (x,_,_)) -> x)- (\(SupiCounterModel (_,y,z)) x -> SupiCounterModel (x,y,z))+ (\(SupiCounterModel (x, _, _)) -> x)+ (\(SupiCounterModel (_, y, z)) x -> SupiCounterModel (x, y, z)) supiRegistry :: Lens' (Model SupiCounter) (ObserverRegistry CounterChanged) supiRegistry = lens- (\(SupiCounterModel (_,y,_)) -> y)- (\(SupiCounterModel (x,_,z)) y -> SupiCounterModel (x,y,z))+ (\(SupiCounterModel (_, y, _)) -> y)+ (\(SupiCounterModel (x, _, z)) y -> SupiCounterModel (x, y, z)) supiTarget :: Lens' (Model SupiCounter) (Maybe (ReplyTarget SupiCounter (Maybe ()))) supiTarget = lens- (\(SupiCounterModel (_,_,z)) -> z)- (\(SupiCounterModel (x,y,_)) z -> SupiCounterModel (x,y,z))+ (\(SupiCounterModel (_, _, z)) -> z)+ (\(SupiCounterModel (x, y, _)) z -> SupiCounterModel (x, y, z)) -spawnCounter :: (IoLogging q) => Eff (Processes q) ( Endpoint SupiCounter )+spawnCounter :: (IoLogging q) => Eff (Processes q) (Endpoint SupiCounter) spawnCounter = startLink MkEmptySupiCounter - deriving instance Show (Pdu Counter x) -logCounterObservations- :: (IoLogging q, Typeable q)- => Eff (Processes q) (Endpoint (Observer CounterChanged))+logCounterObservations ::+ IoLogging q => Eff (Processes q) (Endpoint (Observer CounterChanged)) logCounterObservations = startLink OCCStart instance Member Logs q => Server (Observer CounterChanged) (Processes q) where- data instance StartArgument (Observer CounterChanged) = OCCStart- newtype instance Model (Observer CounterChanged) = CounterChangedModel () deriving Default+ data StartArgument (Observer CounterChanged) = OCCStart+ newtype Model (Observer CounterChanged) = CounterChangedModel () deriving (Default) update _ _ e = case e of- OnCast (Observed msg) -> logInfo' ("observerRegistryNotify: " ++ show msg)- _ -> logNotice (T.pack (show e))+ OnCast (Observed msg) -> logInfo (LABEL "observerRegistryNotify" msg)+ _ -> logNotice e +instance ToLogMsg (StartArgument (Observer CounterChanged)) where+ toLogMsg _ = packLogMsg "start-arg for the CounterChanged observer"
examples/example-3/Main.hs view
@@ -1,28 +1,29 @@+{-# LANGUAGE NoOverloadedStrings #-}+ module Main where -import Control.Eff-import Control.Eff.Log-import Control.Eff.LogWriter.File-import Control.Eff.LogWriter.Rich-import Control.Eff.LogWriter.DebugTrace-import Control.Lens+import Control.Eff+import Control.Eff.Log+import Control.Eff.LogWriter.DebugTrace+import Control.Eff.LogWriter.File+import Control.Eff.LogWriter.Rich+import Control.Lens main :: IO () main =- runLift- $ withFileLogging "extensible-effects-concurrent-example-3.log" "test-app" local0 allLogMessages renderConsoleMinimalisticWide- $ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("traced: " <>)) (debugTraceLogWriter renderRFC5424)))- $ modifyLogWriter (richLogWriter "example-3" local0)- $ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("traced without timestamp: " <>)) (debugTraceLogWriter renderRFC5424)))- $ do- logEmergency "test emergencySeverity 1"- logCritical "test criticalSeverity 2"- logAlert "test alertSeverity 3"- logError "test errorSeverity 4"- logWarning "test warningSeverity 5"- logInfo "test informationalSeverity 6"- logDebug "test debugSeverity 7"-+ runLift $+ withFileLogging "extensible-effects-concurrent-example-3.log" "test-app" local0 allLogEvents renderConsoleMinimalisticWide $+ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (logEventMessage %~ (packLogMsg "traced: " <>)) (debugTraceLogWriter renderRFC5424))) $+ modifyLogWriter (richLogWriter "example-3" local0) $+ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (logEventMessage %~ (packLogMsg "traced without timestamp: " <>)) (debugTraceLogWriter renderRFC5424))) $+ do+ logEmergency "test emergencySeverity 1"+ logCritical "test criticalSeverity 2"+ logAlert "test alertSeverity 3"+ logError "test errorSeverity 4"+ logWarning "test warningSeverity 5"+ logInfo "test informationalSeverity 6"+ logDebug "test debugSeverity 7" severeMessages :: LogPredicate-severeMessages = view (lmSeverity . to (<= errorSeverity))+severeMessages = view (logEventSeverity . to (<= errorSeverity))
examples/example-4/Main.hs view
@@ -1,7 +1,7 @@ module Main where -import Control.Eff-import Control.Eff.Concurrent+import Control.Eff+import Control.Eff.Concurrent main :: IO () main = defaultMain example@@ -12,11 +12,11 @@ replyToMe <- self sendMessage person replyToMe personName <- receiveMessage- logInfo' ("I just met " ++ personName)+ logInfo (LABEL "I just met " (MSG personName)) alice :: Eff Effects () alice = do- logInfo "I am waiting for someone to ask me..."+ logInfo (MSG "I am waiting for someone to ask me...") sender <- receiveMessage sendMessage sender ("Alice" :: String)- logInfo' (show sender ++ " message received.")+ logInfo sender (MSG " message received.")
examples/example-embedded-protocols/Main.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeApplications #-} {-# 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.@@ -7,22 +10,19 @@ -- @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 Control.DeepSeq+import Control.Eff+import Control.Eff.Concurrent+import Control.Eff.Concurrent.Protocol.Broker as Broker+import Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful+import Control.Eff.Concurrent.Protocol.StatefulServer as Stateful+import Control.Eff.State.Lazy as State+import Control.Lens+import Control.Monad import Data.Default+import Data.Dynamic+import Data.Foldable+import GHC.Stack (HasCallStack) main :: IO () main =@@ -44,7 +44,7 @@ cast app DoThis cast app DoThis spawn_ "sub-process" $ do- logNotice "spawned sub process"+ logNotice (MSG "spawned sub process") b1_2 <- Stateful.startLink InitBackend1 call app (SetBackend (Just (SomeBackend b1_2))) cast app DoThis@@ -71,181 +71,204 @@ 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 = 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+data App deriving (Typeable) +instance ToTypeLogMsg App where+ toTypeLogMsg _ = "App"+ 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+ 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 ToLogMsg (Pdu App r) where+ toLogMsg (SetBackend _x) = "setting backend"+ toLogMsg DoThis = "doing this"+ toLogMsg (AppBackendEvent e) = "got backend event: " <> toLogMsg e instance HasPduPrism App (Observer BackendEvent) where embedPdu = AppBackendEvent fromPdu (AppBackendEvent e) = Just e fromPdu _ = Nothing +instance Stateful.Server App Effects where+ newtype Model App = MkApp (Maybe SomeBackend) deriving (Default)+ data StartArgument App = InitApp+ update me _x e =+ case e of+ OnCall rt (SetBackend b) -> do+ logInfo (MSG "setting backend")+ MkApp oldB <- getAndPutModel @App (MkApp b)+ traverse_ (`backendForgetObserver` me) oldB+ traverse_ (`backendRegisterObserver` me) b+ sendReply rt ()+ OnCast (AppBackendEvent be) ->+ logInfo (LABEL "got backend event" be)+ OnCast DoThis ->+ do+ MkApp m <- getModel @App+ case m of+ Nothing -> logInfo (MSG "doing this without backend")+ Just b -> handleInterrupts logWarning $ do+ doSomeBackendWork b+ bi <- getSomeBackendInfo b+ logInfo (LABEL "doing this, backend" bi)+ _ -> logWarning (LABEL "unexpected" e)++instance ToLogMsg (StartArgument App) where+ toLogMsg _ = packLogMsg "start app"++------------------------------ Protocol Data Types+ -- Backend-data Backend deriving Typeable+data Backend deriving (Typeable) +instance ToTypeLogMsg Backend where+ toTypeLogMsg _ = "Backend"+ instance HasPdu Backend where data Pdu Backend r where BackendWork :: Pdu Backend 'Asynchronous GetBackendInfo :: Pdu Backend ('Synchronous String)- deriving Typeable+ deriving (Typeable) instance NFData (Pdu Backend r) where rnf BackendWork = () rnf GetBackendInfo = () +instance ToLogMsg (Pdu Backend r)+ instance Show (Pdu Backend r) where show BackendWork = "BackendWork" show GetBackendInfo = "GetBackendInfo" newtype BackendEvent where- BackendEvent :: String -> BackendEvent- deriving (NFData, Show, Typeable)+ BackendEvent :: String -> BackendEvent+ deriving (NFData, Show, Typeable, ToLogMsg) +instance ToTypeLogMsg BackendEvent where+ toTypeLogMsg _ = "BackendEvent"+ type IsBackend b =- ( HasPdu b- , Embeds b Backend- , IsObservable b BackendEvent- , Tangible (Pdu b ('Synchronous String))- , Tangible (Pdu b 'Asynchronous)+ ( HasPdu b,+ Embeds b Backend,+ ToTypeLogMsg b,+ IsObservable b BackendEvent,+ Tangible (Pdu b ('Synchronous String)),+ ToLogMsg (Pdu b ('Synchronous String)),+ Tangible (Pdu b 'Asynchronous),+ ToLogMsg (Pdu b 'Asynchronous) ) -data SomeBackend =- forall b . IsBackend b => SomeBackend (Endpoint b)+data SomeBackend+ = forall b. IsBackend b => SomeBackend (Endpoint b) withSomeBackend ::- SomeBackend- -> (forall b . IsBackend b => Endpoint b -> x )- -> x+ 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 ::+ ( HasProcesses e q,+ CanObserve m BackendEvent,+ Tangible (Pdu m 'Asynchronous),+ ToLogMsg (Pdu m 'Asynchronous),+ ToTypeLogMsg m+ ) =>+ 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 ::+ (HasProcesses e q) =>+ 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 :: HasProcesses e q => SomeBackend -> Eff e () doSomeBackendWork (SomeBackend x) = cast x BackendWork ------------------------- -- Backend 1 -data Backend1 deriving Typeable+data Backend1 deriving (Typeable) +instance ToTypeLogMsg Backend1 where+ toTypeLogMsg _ = "Backend1"+ 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 = InitBackend1- setup _ _ = pure ( MkBackend1 (0, emptyObserverRegistry), () )+ type Protocol Backend1 = (Backend, ObserverRegistry BackendEvent)+ newtype Model Backend1 = MkBackend1 (Int, ObserverRegistry BackendEvent)+ data StartArgument Backend1 = 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))+ ("Backend1 " <> show (toLogMsg me) <> " " <> show (model ^. modelBackend1 . _1)) OnCast (ToPduLeft BackendWork) -> do- logInfo "working..."+ logInfo (MSG "working...") modifyModel @Backend1 (over (modelBackend1 . _1) (+ 1)) OnCast (ToPduRight x) -> do- logInfo "event registration stuff ..."+ logInfo (MSG "event registration stuff ...") zoomModel @Backend1 (modelBackend1 . _2) (observerRegistryHandlePdu x) OnDown pd -> do- logWarning (T.pack (show pd))+ logWarning pd wasObserver <- zoomModel @Backend1 (modelBackend1 . _2) (observerRegistryRemoveProcess @BackendEvent (downProcess pd)) when wasObserver $- logNotice "observer removed"- _ -> logWarning ("unexpected: " <> T.pack (show e))+ logNotice (MSG "observer removed")+ _ -> logWarning (LABEL "unexpected" e) -modelBackend1 :: Iso' (Model Backend1) (Int, ObserverRegistry BackendEvent)+modelBackend1 :: Iso' (Model Backend1) (Int, ObserverRegistry BackendEvent) modelBackend1 = iso (\(MkBackend1 x) -> x) MkBackend1 +instance ToLogMsg (StartArgument Backend1) where+ toLogMsg InitBackend1 = packLogMsg "InitBackend1"+ -- Backend 2 is behind a broker -data Backend2 deriving Typeable+data Backend2 deriving (Typeable) +instance ToTypeLogMsg Backend2 where+ toTypeLogMsg _ = "Backend2"+ instance HasPdu Backend2 where- type instance EmbeddedPduList Backend2 = '[Backend, ObserverRegistry BackendEvent]- data instance Pdu Backend2 r where+ type EmbeddedPduList Backend2 = '[Backend, ObserverRegistry BackendEvent]+ data Pdu Backend2 r where B2ObserverRegistry :: Pdu (ObserverRegistry BackendEvent) r -> Pdu Backend2 r B2BackendWork :: Pdu Backend r -> Pdu Backend2 r- deriving Typeable+ 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 ToLogMsg (Pdu Backend2 r) where+ toLogMsg (B2BackendWork w) = toLogMsg w+ toLogMsg (B2ObserverRegistry x) = toLogMsg x instance HasPduPrism Backend2 Backend where embedPdu = B2BackendWork@@ -258,58 +281,40 @@ fromPdu _ = Nothing instance Effectful.Server Backend2 Effects where- type instance ServerEffects Backend2 Effects = State Int ': ObserverRegistryState BackendEvent ': Effects- data instance Init Backend2 = InitBackend2 Int- serverTitle (InitBackend2 x) = fromString ("backend-2: " ++ show x)- runEffects _me _ e = evalObserverRegistryState (evalState 0 e)+ type ServerEffects Backend2 Effects = State Int ': ObserverRegistryState BackendEvent ': Effects+ data Init Backend2 = InitBackend2 Int+ 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)+ sendReply rt ("Backend2 " <> show (toLogMsg me) <> " " <> show myIndex) OnCast (B2BackendWork BackendWork) -> do- logInfo "working..."+ logInfo (MSG "working...") put @Int (myIndex + 1)- when (myIndex `mod` 2 == 0)+ when+ (myIndex `mod` 2 == 0) (observerRegistryNotify (BackendEvent "even!")) OnCast (B2ObserverRegistry x) -> do- logInfo "event registration stuff ..."+ logInfo (MSG "event registration stuff ...") observerRegistryHandlePdu @BackendEvent x OnInterrupt NormalExitRequested | even myIndex -> do- logNotice "Kindly exitting -_-"+ logNotice (MSG "Kindly exitting -_-") exitNormally | otherwise ->- logNotice "Ignoring exit request! :P"+ logNotice (MSG "Ignoring exit request! :P") OnDown pd -> do- logWarning (T.pack (show pd))+ logWarning pd wasObserver <- observerRegistryRemoveProcess @BackendEvent (downProcess pd) when wasObserver $- logNotice "observer removed"- _ -> logWarning ("unexpected: " <> T.pack (show e))+ logNotice (MSG "observer removed")+ _ -> logWarning (LABEL "unexpected" e) type instance Broker.ChildId Backend2 = Int +instance ToLogMsg (Init Backend2) where+ toLogMsg (InitBackend2 x) = packLogMsg "backend2_" <> toLogMsg x+ 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)--
+ examples/loadtest/Main.hs view
@@ -0,0 +1,69 @@+-- | This example uses most parts of the+-- the library and allows to interactively+-- generate a lot of processes.+--+-- The goal is to be able to benchmark and/or+-- profile the library.+--+-- This library will use a log writer, and will+-- filter debug messages.+--+-- It starts a book store server, that has several+-- book store warehouses.+--+-- The book store and the warehouses remain constant+-- throughout the life time of the program.+--+-- There are also many book store customer+-- processes that are spawned, buy a random+-- amount of books, randomly selling some+-- back to the book store, and eventually dieing+-- after a random lifetime.+--+-- Throughout the life time the book store sends+-- each customer random advertising messages at random+-- intervalls.+--+-- Through a UI process a user can interactively+-- spawn and kill customers, books and warehouses.+-- The UI process will also observe all kinds of events+-- and print them.+-- The UI process dispatches the incoming commands to+-- the book store, the warehouses and the customers.+module Main where++-- The Warehouse:+-- Messages:+-- * StoreBook (async: Book -> ())+-- * RetreiveBook (sync: Title -> Maybe Book)+-- * DestroyWarehouse (sync: [Book])+-- Events:+-- * WarehoseCapacityChanged++-- The Book Store+-- Messages:+-- * Observe WarehoseEvents+-- * Observe CustomerEvents+-- * ListAvailableBooks+-- * RegisterCustomer+-- * BuyBook+-- * SellBook++-- The Customer+-- Messages:+-- * DoSomething+-- * Die+-- Life Events:+-- * Died+-- BuyEvents:+-- * BoughtBook+-- * SoldBook++-- The World+-- Messages:+-- * CreateBookStore+-- * AddBooks+-- * SpawnCustomers+-- * KillCustomers+--+
extensible-effects-concurrent.cabal view
@@ -1,6 +1,6 @@-cabal-version: 2.0+cabal-version: 2.4 name: extensible-effects-concurrent-version: 0.32.0+version: 2.0.0 description: Please see the README on GitHub at <https://github.com/sheyll/extensible-effects-concurrent#readme> synopsis: Message passing concurrency as extensible-effect homepage: https://github.com/sheyll/extensible-effects-concurrent#readme@@ -8,9 +8,9 @@ author: Sven Heyll maintainer: sven.heyll@gmail.com category: Concurrency, Control, Effect-tested-with: GHC==8.6.3, GHC==8.6.4+tested-with: GHC==8.6.5,GHC==8.8.3,GHC==8.10.2 copyright: Copyright Sven Heyll-license: BSD3+license: BSD-3-Clause license-file: LICENSE build-type: Simple @@ -20,45 +20,92 @@ extra-source-files: stack.yaml- extensible-effects-concurrent.nix default.nix shell.nix- release.nix- with-hoogle.nix+ benchmark.nix ChangeLog.md README.md- brittany.yaml- .travis.yml source-repository head type: git location: https://github.com/sheyll/extensible-effects-concurrent +common compiler-flags+ ghc-options:+ -Wall+ -Wcompat+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wredundant-constraints+ -fhide-source-paths+ -- -Wmissing-export-lists+ -Wpartial-fields+ -- -Wmissing-deriving-strategies+ -fno-full-laziness+ default-extensions:+ AllowAmbiguousTypes,+ BangPatterns,+ ConstraintKinds,+ DefaultSignatures,+ DeriveFoldable,+ DeriveFunctor,+ DeriveFunctor,+ DeriveGeneric,+ DeriveTraversable,+ FlexibleContexts,+ FlexibleInstances,+ FunctionalDependencies,+ GADTs,+ GeneralizedNewtypeDeriving,+ LambdaCase,+ MultiParamTypeClasses,+ NumericUnderscores,+ OverloadedStrings,+ RankNTypes,+ ScopedTypeVariables,+ StandaloneDeriving,+ TemplateHaskell,+ TupleSections,+ TypeApplications,+ TypeFamilies,+ TypeInType,+ TypeOperators,+ ViewPatterns+ other-extensions:+ ImplicitParams,+ OverloadedStrings,+ UndecidableInstances+ default-language: Haskell2010++common deps+ build-depends:+ base >= 4.12 && <5,+ deepseq >= 1.4 && < 1.5,+ text >= 1.2 && < 1.3,+ extensible-effects >= 5 && < 6+ library+ import: deps, compiler-flags hs-source-dirs: src build-depends: async >= 2.2 && <3,- base >= 4.12 && <5, data-default >= 0.7 && < 0.8,- deepseq >= 1.4 && < 1.5, directory, hashable >= 1.2, hostname, exceptions >= 0.10 && < 0.11, safe-exceptions >= 0.1 && < 0.2, filepath >= 1.4 && < 1.5,- time >= 1.8 && < 1.9,+ time >= 1.8 && < 2, mtl >= 2.2 && < 2.3, containers >=0.5.8 && <0.7,- lens >= 4.14 && < 4.18,+ lens >= 4.14 && < 5, monad-control >= 1.0 && < 1.1,- extensible-effects >= 5 && < 6, stm >= 2.4.5 && <2.6, transformers-base >= 0.4 && < 0.5,- text >= 1.2 && < 1.3,- network >= 2 && < 4,- pretty-types >= 0.2.3.1 && < 0.4+ network >= 2 && < 4 autogen-modules: Paths_extensible_effects_concurrent exposed-modules: Control.Eff.Loop,@@ -77,7 +124,6 @@ Control.Eff.LogWriter.UDP, Control.Eff.LogWriter.UnixSocket, Control.Eff.Concurrent,- Control.Eff.Concurrent.Misc, Control.Eff.Concurrent.Protocol, Control.Eff.Concurrent.Protocol.CallbackServer, Control.Eff.Concurrent.Protocol.Client,@@ -98,197 +144,93 @@ other-modules: Control.Eff.Concurrent.Protocol.Broker.InternalState, Paths_extensible_effects_concurrent- default-extensions:- AllowAmbiguousTypes,- BangPatterns,- ConstraintKinds,- DefaultSignatures,- DeriveFoldable,- DeriveFunctor,- DeriveFunctor,- DeriveGeneric,- DeriveTraversable,- FlexibleContexts,- FlexibleInstances,- FunctionalDependencies,- GADTs,- GeneralizedNewtypeDeriving,- LambdaCase,- OverloadedStrings,- MultiParamTypeClasses,- NumericUnderscores,- RankNTypes,- ScopedTypeVariables,- StandaloneDeriving,- TemplateHaskell,- TupleSections,- TypeApplications,- TypeFamilies,- TypeInType,- TypeOperators,- ViewPatterns- other-extensions: ImplicitParams,- UndecidableInstances- default-language: Haskell2010- ghc-options: -Wall -fno-full-laziness executable extensible-effects-concurrent-example-1+ import: deps, compiler-flags main-is: Main.hs hs-source-dirs: examples/example-1- build-depends:- base- , extensible-effects-concurrent- , extensible-effects- , text- , deepseq- , pretty-types >= 0.2.3.1 && < 0.4- ghc-options: -Wall -threaded -fno-full-laziness- default-language: Haskell2010- default-extensions: AllowAmbiguousTypes- , BangPatterns- , DataKinds- , DeriveGeneric- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , GeneralizedNewtypeDeriving- , LambdaCase- , NumericUnderscores- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , StandaloneDeriving- , TemplateHaskell- , TypeApplications- , TypeFamilies- , TypeOperators+ build-depends: extensible-effects-concurrent+ ghc-options: -threaded+ ghc-prof-options: -fprof-auto "-with-rtsopts=-T -xt -Pa -hc -L256"+ default-extensions:+ OverloadedStrings executable extensible-effects-concurrent-example-2+ import: deps, compiler-flags main-is: Main.hs hs-source-dirs: examples/example-2 build-depends:- base- , data-default+ data-default , extensible-effects-concurrent- , extensible-effects , lens- , text- , deepseq- , pretty-types >= 0.2.3.1 && < 0.4- ghc-options: -Wall -threaded -fno-full-laziness- default-language: Haskell2010- default-extensions: AllowAmbiguousTypes- , BangPatterns- , DataKinds- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , GeneralizedNewtypeDeriving- , NumericUnderscores- , LambdaCase- , RankNTypes- , ScopedTypeVariables- , StandaloneDeriving- , TemplateHaskell- , TypeApplications- , TypeFamilies- , TypeOperators- , OverloadedStrings+ ghc-options: -threaded+ ghc-prof-options: -fprof-auto "-with-rtsopts=-T -xt -Pa -hc -L256"+ default-extensions:+ OverloadedStrings executable extensible-effects-concurrent-example-3+ import: deps, compiler-flags main-is: Main.hs hs-source-dirs: examples/example-3 build-depends:- base- , extensible-effects-concurrent- , extensible-effects+ extensible-effects-concurrent , lens- ghc-options: -Wall -threaded -fno-full-laziness- default-language: Haskell2010- default-extensions: AllowAmbiguousTypes- , BangPatterns- , DataKinds- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , GeneralizedNewtypeDeriving- , LambdaCase- , NumericUnderscores- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , StandaloneDeriving- , TemplateHaskell- , TypeApplications- , TypeFamilies- , TypeOperators+ ghc-options: -threaded+ ghc-prof-options: -fprof-auto "-with-rtsopts=-T -xt -Pa -hc -L256"+ default-extensions:+ OverloadedStrings executable extensible-effects-concurrent-example-4+ import: compiler-flags main-is: Main.hs hs-source-dirs: examples/example-4 build-depends: base , extensible-effects-concurrent , extensible-effects- ghc-options: -Wall -threaded -fno-full-laziness- default-language: Haskell2010- default-extensions: AllowAmbiguousTypes- , BangPatterns- , DataKinds- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , GeneralizedNewtypeDeriving- , LambdaCase- , NumericUnderscores- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , StandaloneDeriving- , TemplateHaskell- , TypeApplications- , TypeFamilies- , TypeOperators-+ ghc-options: -threaded+ ghc-prof-options: -fprof-auto "-with-rtsopts=-T -xt -Pa -hc -L256" executable extensible-effects-concurrent-example-embedded-protocols+ import: deps, compiler-flags main-is: Main.hs hs-source-dirs: examples/example-embedded-protocols build-depends:- base- , deepseq- , data-default+ data-default , extensible-effects-concurrent- , extensible-effects , lens- , text- ghc-options: -Wall -threaded -fno-full-laziness- default-language: Haskell2010- default-extensions: AllowAmbiguousTypes- , BangPatterns- , ConstraintKinds- , DataKinds- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , GeneralizedNewtypeDeriving- , LambdaCase- , NumericUnderscores- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , StandaloneDeriving- , TemplateHaskell- , TypeApplications- , TypeFamilies- , TypeOperators+ ghc-options: -threaded+ ghc-prof-options: -fprof-auto "-with-rtsopts=-T -xt -Pa -hc -L256"+ default-extensions:+ OverloadedStrings +executable extensible-effects-concurrent-example-loadtest+ import: deps, compiler-flags+ main-is: Main.hs+ hs-source-dirs: examples/loadtest+ build-depends:+ data-default+ , extensible-effects-concurrent+ , lens+ ghc-options: -threaded+ ghc-prof-options: -fprof-auto "-with-rtsopts=-T -xt -Pa -hc -L256"+ default-extensions:+ OverloadedStrings++ +benchmark extensible-effects-concurrent-bench+ import: deps, compiler-flags+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: src-benchmark+ ghc-options: -Wno-missing-signatures -threaded "-with-rtsopts=-N"+ build-depends:+ extensible-effects-concurrent,+ criterion,+ unliftio+ test-suite extensible-effects-concurrent-test+ import: compiler-flags type: exitcode-stdio-1.0 main-is: Driver.hs hs-source-dirs: test@@ -299,14 +241,14 @@ , GenServerTests , Interactive , LoggingTests- , LogMessageIdeaTest , LoopTests , ObserverTests , ProcessBehaviourTestCases , BrokerTests , SingleThreadedScheduler , WatchdogTests- ghc-options: -Wall -threaded -fno-full-laziness -Wno-missing-signatures+ ghc-options: -threaded -Wno-missing-signatures+ ghc-prof-options: -fprof-auto "-with-rtsopts=-T -xt -Pa -hc -L256" build-depends: async , base@@ -320,32 +262,10 @@ , HUnit , lens , monad-control- , pretty-types >= 0.2.3.1 && < 0.4 , QuickCheck , stm , tasty , tasty-discover , tasty-hunit , text- , text , time- default-language: Haskell2010- default-extensions: AllowAmbiguousTypes- , BangPatterns- , DataKinds- , DeriveGeneric- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , GeneralizedNewtypeDeriving- , LambdaCase- , NumericUnderscores- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , StandaloneDeriving- , TemplateHaskell- , TypeApplications- , TypeFamilies- , TypeOperators
− extensible-effects-concurrent.nix
@@ -1,15 +0,0 @@-let- pkgs = import ./pkgs.nix;- lib = pkgs.lib;- haskellPackages = pkgs.haskellPackages;- cleanSrc = lib.cleanSourceWith {- filter = (path: type:- let base = baseNameOf (toString path);- in !(lib.hasPrefix ".ghc.environment." base) &&- !(lib.hasSuffix ".nix" base)- );- src = lib.cleanSource ./.;- };-- in haskellPackages.callCabal2nix- "extensible-effects-concurrent" cleanSrc {}
− release.nix
@@ -1,2 +0,0 @@-{ pkgs ? (import <nixpkgs> {}) }:-pkgs.callPackage ./extensible-effects-concurrent.nix {}
shell.nix view
@@ -1,22 +1,26 @@-let extensible-effects-concurrent = import ./extensible-effects-concurrent.nix;- pkgs = import <nixpkgs> {};+let+ pkgs = import nix/pkgs.nix { }; in-pkgs.haskellPackages.shellFor {- packages = p: [extensible-effects-concurrent];- withHoogle = true;- buildInputs = with pkgs.haskellPackages;- [ pkgs.cabal-install- pkgs.cabal2nix- pkgs.erlang- ghcid- hoogle- pointfree- graphmod- cabal-plan- # brittany- weeder- pkgs.stack- pkgs.nix- pkgs.graphviz-nox- ];- }+(import ./default.nix { inherit pkgs; }).shellFor {+ packages = p: [ p.extensible-effects-concurrent ];+ withHoogle = true;+ tools = {+ cabal = "3.2.0.0";+ ormolu = "0.1.4.1";+ haskell-language-server = "0.6.0";+ };+ buildInputs = with pkgs.haskellPackages;+ [+ pkgs.emacs+ pkgs.neovim+ tasty-discover+ ghcid+ graphmod+ cabal-plan+ brittany+ weeder+ pkgs.graphviz-nox+ pkgs.pandoc+ ];+}+
+ src-benchmark/Main.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}++module Main (main) where++import Control.DeepSeq+import Control.Eff+import Control.Eff.Concurrent+import Control.Monad (replicateM)+import qualified Criterion.Main as Criterion+import Criterion.Types+ ( bench,+ bgroup,+ nfAppIO,+ )+import Data.Dynamic+import GHC.Stack++main =+ Criterion.defaultMain+ [ bgroup+ "unidirectionalMessagePassing"+ [ bench+ ( "n="+ <> show noMessages+ <> ": "+ <> show senderNo+ <> " -> " + <> show receiverNo+ )+ ( nfAppIO+ unidirectionalMessagePassing+ (senderNo, noMessages, receiverNo)+ )+ | noMessages <- [100000],+ (senderNo, receiverNo) <-+ [ (1, 1000)+ -- (10, 100),+ -- (1, 1),+ -- (1000, 1)+ ]+ ]+ ]++mkTestMessage :: Int -> TestMessage+mkTestMessage !i =+ MkTestMessage+ ( "The not so very very very very very very very very very very very very very very very very very very very very very very very very " ++ show i,+ "large",+ "meeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeessssssssssssssssssssssssssssssssss" ++ show i,+ ( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",+ "ggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggggeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee",+ even i,+ 123423421111111111111111111123234 * toInteger i+ )+ )++newtype TestMessage = MkTestMessage ([Char], [Char], [Char], ([Char], [Char], Bool, Integer))+ deriving newtype (Show, NFData, Typeable)++unidirectionalMessagePassing :: HasCallStack => (Int, Int, Int) -> IO ()+unidirectionalMessagePassing (!np, !nm, !nc) = defaultMainWithLogWriter noOpLogWriter $ do+ cs <- consumers+ ps <- producers cs+ awaitAllDown cs+ awaitAllDown ps+ where+ producers !cs =+ replicateM nc (spawn "producer" produce)+ where+ produce =+ mapM_+ (uncurry (flip sendMessage))+ ((,) <$> (mkTestMessage <$> [0 .. (nm `div` (nc * np)) - 1]) <*> cs)+ consumers = do+ replicateM nc (spawn "consumer" (consume (nm `div` nc)))+ where+ consume 0 = return ()+ consume workLeft = do+ (MkTestMessage !_msg) <- receiveMessage+ consume (workLeft - 1)++awaitAllDown :: [ProcessId] -> Eff Effects ()+awaitAllDown [] = return ()+awaitAllDown (p : rest) = do+ m <- monitor p+ _ <- receiveSelectedMessage (selectProcessDown m)+ awaitAllDown rest+
src/Control/Eff/Concurrent.hs view
@@ -12,248 +12,242 @@ -- -- * "Control.Eff.Concurrent.Pure" -- * "Control.Eff.Concurrent.SingleThreaded"--- module Control.Eff.Concurrent- (- -- * Concurrent Processes with Message Passing Concurrency- module Control.Eff.Concurrent.Process- ,+ ( -- * Concurrent Processes with Message Passing Concurrency+ module Control.Eff.Concurrent.Process,+ -- * /Scheduler/ Process Effect Handler+ -- ** Concurrent Scheduler- module Control.Eff.Concurrent.Process.ForkIOScheduler- ,+ module Control.Eff.Concurrent.Process.ForkIOScheduler,+ -- * Timers and Timeouts- module Control.Eff.Concurrent.Process.Timer- ,+ module Control.Eff.Concurrent.Process.Timer,+ -- * Data Types and Functions for APIs (aka Protocols)- module Control.Eff.Concurrent.Protocol- ,+ module Control.Eff.Concurrent.Protocol,+ -- ** /Client/ Functions for Consuming APIs- module Control.Eff.Concurrent.Protocol.Client- ,+ module Control.Eff.Concurrent.Protocol.Client,+ -- ** /Protocol-Server/ Support Functions for building protocol servers- module Control.Eff.Concurrent.Protocol.Wrapper- ,+ module Control.Eff.Concurrent.Protocol.Wrapper,+ -- ** /Observer/ Functions for Events and Event Listener- module Control.Eff.Concurrent.Protocol.Observer- ,+ module Control.Eff.Concurrent.Protocol.Observer,+ -- * Utilities+ -- ** FilteredLogging Effect- module Control.Eff.Log- ,+ module Control.Eff.Log,+ -- ** Log Writer+ -- *** Asynchronous- module Control.Eff.LogWriter.Async- ,+ module Control.Eff.LogWriter.Async,+ -- *** Console- module Control.Eff.LogWriter.Console- ,+ module Control.Eff.LogWriter.Console,+ -- *** File- module Control.Eff.LogWriter.File- ,+ module Control.Eff.LogWriter.File,+ -- *** UDP- module Control.Eff.LogWriter.UDP+ module Control.Eff.LogWriter.UDP, - , -- *** "Debug.Trace"- module Control.Eff.LogWriter.DebugTrace+ -- *** "Debug.Trace"+ module Control.Eff.LogWriter.DebugTrace, - , -- *** Generic IO- module Control.Eff.LogWriter.Rich+ -- *** Generic IO+ module Control.Eff.LogWriter.Rich, - , -- *** Unix Domain Socket- module Control.Eff.LogWriter.UnixSocket- ,+ -- *** Unix Domain Socket+ module Control.Eff.LogWriter.UnixSocket,+ -- ** Preventing Space Leaks- module Control.Eff.Loop+ module Control.Eff.Loop, ) where -import Control.Eff.Concurrent.Process- ( Process(..)- , SafeProcesses- , Processes- , HasProcesses- , HasSafeProcesses- , ProcessTitle(..)- , fromProcessTitle- , ProcessDetails(..)- , fromProcessDetails- , Timeout(TimeoutMicros, fromTimeoutMicros)- , StrictDynamic()- , toStrictDynamic- , fromStrictDynamic- , unwrapStrictDynamic- , Serializer(..)- , ProcessId(..)- , fromProcessId- , yieldProcess- , delay- , sendMessage- , sendAnyMessage- , makeReference- , receiveMessage- , receiveSelectedMessage- , flushMessages- , receiveAnyMessage- , receiveLoop- , receiveSelectedLoop- , receiveAnyLoop- , MessageSelector(runMessageSelector)- , selectMessage- , filterMessage- , selectMessageWith- , selectDynamicMessage- , selectAnyMessage- , self- , isProcessAlive- , getProcessState- , updateProcessDetails- , spawn- , spawn_- , spawnLink- , spawnRaw- , spawnRaw_- , ResumeProcess(..)- , executeAndResume- , executeAndResumeOrExit- , executeAndResumeOrThrow- , interrupt- , sendInterrupt- , exitBecause- , exitNormally- , exitWithError- , sendShutdown -- TODO rename to 'sendExit'- , linkProcess- , unlinkProcess- , monitor- , demonitor- , ProcessDown(..)- , selectProcessDown- , selectProcessDownByProcessId- , becauseProcessIsDown- , MonitorReference(..)- , withMonitor- , receiveWithMonitor- , Interrupt(..)- , Interrupts- , interruptToExit- , ExitRecovery(..)- , RecoverableInterrupt- , ExitSeverity(..)- , SomeExitReason(SomeExitReason)- , toExitRecovery- , isRecoverable- , toExitSeverity- , isProcessDownInterrupt- , isCrash- , toCrashReason- , fromSomeExitReason- , logProcessExit- , provideInterruptsShutdown- , handleInterrupts- , tryUninterrupted- , exitOnInterrupt- , logInterrupts- , provideInterrupts- , mergeEitherInterruptAndExitReason- , sendToReceiver- , Receiver(..)- , receiverPid- )-import Control.Eff.Concurrent.Process.Timer- ( TimerReference()- , TimerElapsed(fromTimerElapsed)- , sendAfter- , startTimer- , sendAfterWithTitle- , startTimerWithTitle- , selectTimerElapsed- , cancelTimer- , receiveAfter- , receiveSelectedAfter- , receiveSelectedWithMonitorAfter- , receiveAfterWithTitle- , receiveSelectedAfterWithTitle- , receiveSelectedWithMonitorAfterWithTitle- )--import Control.Eff.Concurrent.Protocol- ( HasPdu(..)- , Embeds- , Pdu(..)- , Synchronicity(..)- , ProtocolReply- , Tangible- , TangiblePdu- , Endpoint(..)- , fromEndpoint- , proxyAsEndpoint- , asEndpoint- , HasPduPrism(..)- , toEmbeddedEndpoint- , fromEmbeddedEndpoint- )-import Control.Eff.Concurrent.Protocol.Client- ( cast- , call- , callWithTimeout- , castSingleton- , castEndpointReader- , callSingleton- , callEndpointReader- , HasEndpointReader- , runEndpointReader- , askEndpoint- , EndpointReader- )-import Control.Eff.Concurrent.Protocol.Observer- ( Observer(..)- , ObservationSink- , IsObservable- , CanObserve- , Pdu(RegisterObserver, ForgetObserver, Observed)- , registerObserver- , forgetObserver- , forgetObserverUnsafe- , ObserverRegistry(..)- , ObserverRegistryState- , evalObserverRegistryState- , emptyObserverRegistry- , observerRegistryHandlePdu- , observerRegistryRemoveProcess- , observerRegistryNotify- )-import Control.Eff.Concurrent.Protocol.Wrapper- ( Request(..)- , sendReply- , ReplyTarget(..)- , replyTarget- , embeddedReplyTarget- , replyTargetOrigin- , replyTargetSerializer- , toEmbeddedReplyTarget- , RequestOrigin(..)- , embedRequestOrigin- , toEmbeddedOrigin- , Reply(..)- , embedReplySerializer- , makeRequestOrigin- )-import Control.Eff.Concurrent.Process.ForkIOScheduler- ( schedule- , defaultMain- , defaultMainWithLogWriter- , SafeEffects- , Effects- , BaseEffects- , HasBaseEffects- )-import Control.Eff.Log-import Control.Eff.LogWriter.Async-import Control.Eff.LogWriter.Console-import Control.Eff.LogWriter.DebugTrace-import Control.Eff.LogWriter.File-import Control.Eff.LogWriter.Rich-import Control.Eff.LogWriter.UDP-import Control.Eff.LogWriter.UnixSocket-import Control.Eff.Loop+import Control.Eff.Concurrent.Process+ ( ExitSeverity (..),+ HasProcesses,+ HasSafeProcesses,+ InterruptOrShutdown (..),+ InterruptReason (..),+ Interrupts,+ Message (),+ MessageSelector (runMessageSelector),+ MonitorReference (..),+ Process (..),+ ProcessDetails (..),+ ProcessDown (..),+ ProcessId (..),+ ProcessTitle (..),+ Processes,+ ResumeProcess (..),+ SafeProcesses,+ Serializer (..),+ ShutdownReason (..),+ Timeout (TimeoutMicros, fromTimeoutMicros),+ UnhandledProcessExit (..),+ UnhandledProcessInterrupt (..),+ becauseOtherProcessNotRunning,+ delay,+ demonitor,+ executeAndResume,+ executeAndResumeOrExit,+ executeAndResumeOrThrow,+ exitBecause,+ exitNormally,+ exitOnInterrupt,+ exitWithError,+ filterMessage,+ flushMessages,+ fromMessage,+ fromProcessDetails,+ fromProcessId,+ fromProcessTitle,+ getProcessState,+ handleInterrupts,+ interrupt,+ interruptToExit,+ isCrash,+ isLinkedProcessCrashed,+ isProcessAlive,+ linkProcess,+ logInterrupts,+ logProcessExit,+ makeReference,+ mergeEitherInterruptAndExitReason,+ monitor,+ provideInterrupts,+ provideInterruptsShutdown,+ receiveAnyLoop,+ receiveAnyMessage,+ receiveLoop,+ receiveMessage,+ receiveSelectedLoop,+ receiveSelectedMessage,+ receiveWithMonitor,+ selectAnyMessage,+ selectDynamicMessage,+ selectMessage,+ selectMessageWith,+ selectProcessDown,+ selectProcessDownByProcessId,+ self,+ sendAnyMessage,+ sendInterrupt,+ sendMessage,+ sendShutdown,+ spawn,+ spawnLink,+ spawnRaw,+ spawnRaw_,+ spawn_,+ toCrashReason,+ toExitSeverity,+ toMessage,+ toProcessTitle,+ tryUninterrupted,+ unlinkProcess,+ unwrapMessage,+ updateProcessDetails,+ withMonitor,+ yieldProcess,+ )+import Control.Eff.Concurrent.Process.ForkIOScheduler+ ( BaseEffects,+ Effects,+ HasBaseEffects,+ SafeEffects,+ defaultMain,+ defaultMainWithLogWriter,+ schedule,+ )+import Control.Eff.Concurrent.Process.Timer+ ( TimerElapsed (fromTimerElapsed),+ TimerReference (),+ cancelTimer,+ receiveAfter,+ receiveAfterWithTitle,+ receiveSelectedAfter,+ receiveSelectedAfterWithTitle,+ receiveSelectedWithMonitorAfter,+ receiveSelectedWithMonitorAfterWithTitle,+ selectTimerElapsed,+ sendAfter,+ sendAfterWithTitle,+ startTimer,+ startTimerWithTitle,+ )+import Control.Eff.Concurrent.Protocol+ ( Embeds,+ Endpoint (..),+ HasPdu (..),+ HasPduPrism (..),+ Pdu (..),+ ProtocolReply,+ Synchronicity (..),+ Tangible,+ TangiblePdu,+ asEndpoint,+ fromEndpoint,+ proxyAsEndpoint,+ )+import Control.Eff.Concurrent.Protocol.Client+ ( EndpointReader,+ HasEndpointReader,+ askEndpoint,+ call,+ callEndpointReader,+ callSingleton,+ callWithTimeout,+ cast,+ castEndpointReader,+ castSingleton,+ runEndpointReader,+ )+import Control.Eff.Concurrent.Protocol.Observer+ ( CanObserve,+ IsObservable,+ ObservationSink,+ Observer (..),+ ObserverRegistry (..),+ ObserverRegistryState,+ Pdu (ForgetObserver, Observed, RegisterObserver),+ emptyObserverRegistry,+ evalObserverRegistryState,+ forgetObserver,+ forgetObserverUnsafe,+ observerRegistryHandlePdu,+ observerRegistryNotify,+ observerRegistryRemoveProcess,+ registerObserver,+ )+import Control.Eff.Concurrent.Protocol.Wrapper+ ( Reply (..),+ ReplyTarget (..),+ Request (..),+ RequestOrigin (..),+ embedReplySerializer,+ embedRequestOrigin,+ embeddedReplyTarget,+ makeRequestOrigin,+ replyTarget,+ replyTargetOrigin,+ replyTargetSerializer,+ sendReply,+ toEmbeddedOrigin,+ toEmbeddedReplyTarget,+ )+import Control.Eff.Log+import Control.Eff.LogWriter.Async+import Control.Eff.LogWriter.Console+import Control.Eff.LogWriter.DebugTrace+import Control.Eff.LogWriter.File+import Control.Eff.LogWriter.Rich+import Control.Eff.LogWriter.UDP+import Control.Eff.LogWriter.UnixSocket+import Control.Eff.Loop
− src/Control/Eff/Concurrent/Misc.hs
@@ -1,52 +0,0 @@--- | Internal module containing internal helpers that didn't--- make it into their own library.-module Control.Eff.Concurrent.Misc- ( showSTypeRepPrec- , showSTypeRep- , showSTypeable- , showSPrecTypeable- )- where--import Data.Dynamic-import Data.Typeable ()-import Type.Reflection---- | Render a 'Typeable' to a 'ShowS'.------ @since 0.28.0-showSTypeable :: forall message . Typeable message => ShowS-showSTypeable = showSTypeRep (SomeTypeRep (typeRep @message))---- | Render a 'Typeable' to a 'ShowS' with a precedence parameter.------ @since 0.28.0-showSPrecTypeable :: forall message . Typeable message => Int -> ShowS-showSPrecTypeable d = showSTypeRepPrec d (SomeTypeRep (typeRep @message))---- | This is equivalent to @'showSTypeRepPrec' 0@------ @since 0.24.0-showSTypeRep :: SomeTypeRep -> ShowS-showSTypeRep = showSTypeRepPrec 0---- | An internal utility to print 'Typeable' without the kinds.--- This is like 'showsPrec' in that it accepts a /precedence/ parameter,--- and the result is in parentheses when the precedence is higher than 9.------ @since 0.24.0-showSTypeRepPrec :: Int -> SomeTypeRep -> ShowS-showSTypeRepPrec _d (SomeTypeRep tr) =- let- (con, conArgs) = splitApps tr-- renderArgs =- foldr1 (\f acc -> showString ", " . f . acc)- (showSTypeRepPrec 10 <$> conArgs)-- in showString (tyConName con) .- if not (null conArgs) then- showChar '<'- . renderArgs- . showChar '>'- else id
src/Control/Eff/Concurrent/Process.hs view
@@ -1,1450 +1,1301 @@ {-# LANGUAGE ImplicitParams #-}--- | The message passing effect.------ This module describes an abstract message passing effect, and a process--- effect, mimicking Erlang's process and message semantics.------ Two __scheduler__ implementations for the 'Process' effect are provided:------ * A scheduler using @forkIO@, i.e. relying on the multi threaded GHC runtime:--- "Control.Eff.Concurrent.Process.ForkIOScheduler"------ * And a /pure/(rer) coroutine based scheduler in:--- "Control.Eff.Concurrent.Process.SingleThreadedScheduler"-module Control.Eff.Concurrent.Process- ( -- * Process Effect- Process(..)- -- ** Process Effect Aliases- , SafeProcesses- , Processes- -- ** Process Effect Constraints- , HasProcesses- , HasSafeProcesses- -- ** Process Info- , ProcessTitle(..)- , fromProcessTitle- , ProcessDetails(..)- , fromProcessDetails-- -- ** Process Timer- , Timeout(TimeoutMicros, fromTimeoutMicros)-- , -- ** Message Data- StrictDynamic()- , toStrictDynamic- , fromStrictDynamic- , unwrapStrictDynamic- , Serializer(..)-- -- ** ProcessId Type- , ProcessId(..)- , fromProcessId- -- ** Process State- , ProcessState(..)- -- ** Yielding- , yieldProcess- -- ** Waiting/Sleeping- , delay- -- ** Sending Messages- , sendMessage- , sendAnyMessage- -- ** Utilities- , makeReference- -- ** Receiving Messages- , receiveMessage- , receiveSelectedMessage- , flushMessages- , receiveAnyMessage- , receiveLoop- , receiveSelectedLoop- , receiveAnyLoop- -- ** Selecting Messages to Receive- , MessageSelector(runMessageSelector)- , selectMessage- , filterMessage- , selectMessageWith- , selectDynamicMessage- , selectAnyMessage- -- ** Process State Reflection- , self- , isProcessAlive- , getProcessState- , updateProcessDetails- -- ** Spawning- , spawn- , spawn_- , spawnLink- , spawnRaw- , spawnRaw_- -- ** Process Operation Execution- , ResumeProcess(..)- , executeAndResume- , executeAndResumeOrExit- , executeAndResumeOrThrow- -- ** Exits and Interrupts- -- *** Interrupting Processes- , interrupt- , sendInterrupt- -- *** Exiting Processes- , exitBecause- , exitNormally- , exitWithError- , sendShutdown -- TODO rename to 'sendExit'- -- *** Linking Processes- , linkProcess- , unlinkProcess- -- *** Monitor Processes- , monitor- , demonitor- , ProcessDown(..)- , selectProcessDown- , selectProcessDownByProcessId- , becauseProcessIsDown- , MonitorReference(..)- , withMonitor- , receiveWithMonitor- -- *** Exit and Interrupt Reasons- , Interrupt(..)- , Interrupts- , interruptToExit- , ExitRecovery(..)- , RecoverableInterrupt- , ExitSeverity(..)- , SomeExitReason(SomeExitReason)- , toExitRecovery- , isRecoverable- , toExitSeverity- , isProcessDownInterrupt- , isCrash- , toCrashReason- , fromSomeExitReason- , logProcessExit- -- ** Control Flow- -- *** Process Interrupt Recoverable Handling- , provideInterruptsShutdown- , handleInterrupts- , tryUninterrupted- , exitOnInterrupt- , logInterrupts- , provideInterrupts- , mergeEitherInterruptAndExitReason- -- ** Typed ProcessIds: Receiver- , sendToReceiver- , Receiver(..)- , receiverPid- )-where--import Control.Applicative-import Control.Eff.Concurrent.Misc-import Control.DeepSeq-import Control.Eff-import Control.Eff.Exception-import Control.Eff.Extend-import Control.Eff.Log.Handler-import qualified Control.Exception as Exc-import Control.Lens-import Control.Monad ( void- , (>=>)- )-import Data.Default-import Data.Dynamic-import Data.Functor.Contravariant ()-import Data.Kind-import Data.Function-import Data.Maybe-import Data.String ( IsString, fromString )-import Data.Text ( Text, pack, unpack)-import qualified Data.Text as T-import Type.Reflection ( SomeTypeRep(..), typeRep )-import GHC.Stack-import GHC.Generics ( Generic- , Generic1- )----- | The process effect is the basis for message passing concurrency. This--- effect describes an interface for concurrent, communicating isolated--- processes identified uniquely by a process-id.------ Processes can raise exceptions that can be caught, exit gracefully or with an--- error, or be killed by other processes, with the option of ignoring the--- shutdown request.------ Process Scheduling is implemented in different modules. All scheduler--- implementations should follow some basic rules:------ * fair scheduling------ * sending a message does not block------ * receiving a message does block------ * spawning a child blocks only a very moment------ * a newly spawned process shall be scheduled before the parent process after--- * the spawnRaw------ * when the first process exists, all process should be killed immediately-data Process (r :: [Type -> Type]) b where- -- | Remove all messages from the process' message queue- FlushMessages :: Process r (ResumeProcess [StrictDynamic])- -- | In cooperative schedulers, this will give processing time to the- -- scheduler. Every other operation implicitly serves the same purpose.- --- -- @since 0.12.0- YieldProcess :: Process r (ResumeProcess ())- -- | Simply wait until the time in the given 'Timeout' has elapsed and return.- --- -- @since 0.30.0- Delay :: Timeout -> Process r (ResumeProcess ())-- -- | Return the current 'ProcessId'- SelfPid :: Process r (ResumeProcess ProcessId)- -- | Start a new process, the new process will execute an effect, the function- -- will return immediately with a 'ProcessId'.- Spawn :: ProcessTitle -> Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)- -- | Start a new process, and 'Link' to it .- --- -- @since 0.12.0- SpawnLink :: ProcessTitle -> Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)- -- | Shutdown the process; irregardless of the exit reason, this function never- -- returns,- Shutdown :: Interrupt 'NoRecovery -> Process r a- -- | Shutdown another process immediately, the other process has no way of handling this!- SendShutdown ::ProcessId -> Interrupt 'NoRecovery -> Process r (ResumeProcess ())- -- | Request that another a process interrupts. The targeted process is interrupted- -- and gets an 'Interrupted', the target process may decide to ignore the- -- interrupt and continue as if nothing happened.- SendInterrupt :: ProcessId -> Interrupt 'Recoverable -> Process r (ResumeProcess ())- -- | Send a message to a process addressed by the 'ProcessId'. Sending a- -- message should __always succeed__ and return __immediately__, even if the- -- destination process does not exist, or does not accept messages of the- -- given type.- SendMessage :: ProcessId -> StrictDynamic -> Process r (ResumeProcess ())- -- | Receive a message that matches a criteria.- -- This should block until an a message was received. The message is returned- -- as a 'ResumeProcess' value. The function should also return if an exception- -- was caught or a shutdown was requested.- ReceiveSelectedMessage :: forall r a . MessageSelector a -> Process r (ResumeProcess a)- -- | Generate a unique 'Int' for the current process.- MakeReference :: Process r (ResumeProcess Int)- -- | Monitor another process. When the monitored process exits a- -- 'ProcessDown' is sent to the calling process.- -- The return value is a unique identifier for that monitor.- -- There can be multiple monitors on the same process,- -- and a message for each will be sent.- -- If the process is already dead, the 'ProcessDown' message- -- will be sent immediately, without exit reason- --- -- @since 0.12.0- Monitor :: ProcessId -> Process r (ResumeProcess MonitorReference)- -- | Remove a monitor.- --- -- @since 0.12.0- Demonitor :: MonitorReference -> Process r (ResumeProcess ())- -- | Connect the calling process to another process, such that- -- if one of the processes crashes (i.e. 'isCrash' returns 'True'), the other- -- is shutdown with the 'Interrupt' 'LinkedProcessCrashed'.- --- -- You might wonder: Why not tearing down the linked process when exiting- -- normally?- -- I thought about this. If a process exits normally, it should have the- -- opportunity to shutdown stuff explicitly.- -- And if you want to make sure that there are no dangling child processes- -- after e.g. a broker crash, you can always use 'monitor'.- --- -- @since 0.12.0- Link :: ProcessId -> Process r (ResumeProcess ())- -- | Unlink the calling process from the other process.- --- -- See 'Link' for a discussion on linking.- --- -- @since 0.12.0- Unlink :: ProcessId -> Process r (ResumeProcess ())-- -- | Update the 'ProcessDetails' of a process- UpdateProcessDetails :: ProcessDetails -> Process r (ResumeProcess ())-- -- | Get the 'ProcessState' (or 'Nothing' if the process is dead)- GetProcessState :: ProcessId -> Process r (ResumeProcess (Maybe (ProcessTitle, ProcessDetails, ProcessState)))---instance Show (Process r b) where- showsPrec d = \case- FlushMessages -> showString "flush messages"- YieldProcess -> showString "yield process"- Delay t -> showString "delay process until: " . shows t- SelfPid -> showString "lookup the current process id"- Spawn t _ -> showString "spawn a new process: " . shows t- SpawnLink t _ -> showString "spawn a new process and link to it" . shows t- Shutdown sr ->- showParen (d >= 10) (showString "shutdown " . showsPrec 10 sr)- SendShutdown toPid sr -> showParen- (d >= 10)- ( showString "shutting down "- . showsPrec 10 toPid- . showChar ' '- . showsPrec 10 sr- )- SendInterrupt toPid sr -> showParen- (d >= 10)- ( showString "interrupting "- . showsPrec 10 toPid- . showChar ' '- . showsPrec 10 sr- )- SendMessage toPid sr -> showParen- (d >= 10)- ( showString "sending to "- . showsPrec 10 toPid- . showChar ' '- . showsPrec 10 sr- )- ReceiveSelectedMessage _ -> showString "receive a message"- MakeReference -> showString "generate a unique reference"- Monitor pid -> showString "monitor " . shows pid- Demonitor i -> showString "demonitor " . shows i- Link l -> showString "link " . shows l- Unlink l -> showString "unlink " . shows l- GetProcessState pid -> showString "get the process state of " . shows pid- UpdateProcessDetails l -> showString "update the process details to: " . shows l---- | A short title for a 'Process' for logging purposes.------ @since 0.24.1-newtype ProcessTitle =- MkProcessTitle { _fromProcessTitle :: Text }- deriving (Eq, Ord, NFData, Generic, IsString, Typeable, Semigroup, Monoid)---- | An isomorphism lens for the 'ProcessTitle'------ @since 0.24.1-fromProcessTitle :: Lens' ProcessTitle Text-fromProcessTitle = iso _fromProcessTitle MkProcessTitle--instance Show ProcessTitle where- showsPrec _ (MkProcessTitle t) = showString (T.unpack t)---- | A multi-line text describing the __current__--- state of a process for debugging purposes.------ @since 0.24.1-newtype ProcessDetails =- MkProcessDetails { _fromProcessDetails :: Text }- deriving (Eq, Ord, NFData, Generic, IsString, Typeable, Semigroup, Monoid)---- | An isomorphism lens for the 'ProcessDetails'------ @since 0.24.1-fromProcessDetails :: Lens' ProcessDetails Text-fromProcessDetails = iso _fromProcessDetails MkProcessDetails--instance Show ProcessDetails where- showsPrec _ (MkProcessDetails t) = showString (T.unpack t)---- | A number of micro seconds.------ @since 0.12.0-newtype Timeout = TimeoutMicros {fromTimeoutMicros :: Int}- deriving (NFData, Ord,Eq, Num, Integral, Real, Enum, Typeable)--instance Show Timeout where- showsPrec d (TimeoutMicros t) =- showParen (d >= 10) (showString "timeout: " . shows t . showString " µs")---- | Data flows between 'Process'es via these messages.------ This is just a newtype wrapper around 'Dynamic'.--- The reason this type exists is to force construction through the code in this--- module, which always evaluates a message to /normal form/ __before__--- sending it to another process.------ @since 0.22.0-newtype StrictDynamic where- MkDynamicMessage :: Dynamic -> StrictDynamic- deriving Typeable--instance NFData StrictDynamic where- rnf (MkDynamicMessage d) = d `seq` ()--instance Show StrictDynamic where- show (MkDynamicMessage d) = show d----- | Serialize a @message@ into a 'StrictDynamic' value to be sent via 'sendAnyMessage'.------ This indirection allows, among other things, the composition of--- 'Control.Eff.Concurrent.Protocol.Effectful.Server's.------ @since 0.24.1-newtype Serializer message =- MkSerializer- { runSerializer :: message -> StrictDynamic- } deriving (Typeable)--instance NFData (Serializer message) where- rnf (MkSerializer !s) = s `seq` ()--instance Typeable message => Show (Serializer message) where- showsPrec d _x = showParen (d >= 10) (showSTypeable @message . showString "-serializer")--instance Contravariant Serializer where- contramap f (MkSerializer b) = MkSerializer (b . f)---- | Deeply evaluate the given value and wrap it into a 'StrictDynamic'.------ @since 0.22.0-toStrictDynamic :: (Typeable a, NFData a) => a -> StrictDynamic-toStrictDynamic x = force x `seq` toDyn (force x) `seq` MkDynamicMessage (toDyn (force x))---- | Convert a 'StrictDynamic' back to a value.------ @since 0.22.0-fromStrictDynamic :: Typeable a => StrictDynamic -> Maybe a-fromStrictDynamic (MkDynamicMessage d) = fromDynamic d----- | Convert a 'StrictDynamic' back to an unwrapped 'Dynamic'.------ @since 0.22.0-unwrapStrictDynamic :: StrictDynamic -> Dynamic-unwrapStrictDynamic (MkDynamicMessage d) = d---- | Every 'Process' action returns it's actual result wrapped in this type. It--- will allow to signal errors as well as pass on normal results such as--- incoming messages.-data ResumeProcess v where- -- | The current operation of the process was interrupted with a- -- 'Interrupt'. If 'isRecoverable' holds for the given reason,- -- the process may choose to continue.- Interrupted :: Interrupt 'Recoverable -> ResumeProcess v- -- | The process may resume to do work, using the given result.- ResumeWith ::a -> ResumeProcess a- deriving ( Typeable, Generic, Generic1, Show )--instance NFData a => NFData (ResumeProcess a)--instance NFData1 ResumeProcess---- | A function that decided if the next message will be received by--- 'ReceiveSelectedMessage'. It conveniently is an instance of--- 'Alternative' so the message selector can be combined:--- >--- > selectInt :: MessageSelector Int--- > selectInt = selectMessage--- >--- > selectString :: MessageSelector String--- > selectString = selectMessage--- >--- > selectIntOrString :: MessageSelector (Either Int String)--- > selectIntOrString =--- > Left <$> selectTimeout<|> Right <$> selectString----newtype MessageSelector a =- MessageSelector {runMessageSelector :: StrictDynamic -> Maybe a }- deriving (Semigroup, Monoid, Functor)--instance Applicative MessageSelector where- pure = MessageSelector . pure . pure- (MessageSelector f) <*> (MessageSelector x) =- MessageSelector (\dyn -> f dyn <*> x dyn)--instance Alternative MessageSelector where- empty = MessageSelector (const empty)- (MessageSelector l) <|> (MessageSelector r) =- MessageSelector (\dyn -> l dyn <|> r dyn)---- | Create a message selector for a value that can be obtained by 'fromStrictDynamic'.------ @since 0.9.1-selectMessage :: Typeable t => MessageSelector t-selectMessage = selectDynamicMessage fromStrictDynamic---- | Create a message selector from a predicate.------ @since 0.9.1-filterMessage :: Typeable a => (a -> Bool) -> MessageSelector a-filterMessage predicate = selectDynamicMessage- (\d -> case fromStrictDynamic d of- Just a | predicate a -> Just a- _ -> Nothing- )---- | Select a message of type @a@ and apply the given function to it.--- If the function returns 'Just' The 'ReceiveSelectedMessage' function will--- return the result (sans @Maybe@).------ @since 0.9.1-selectMessageWith- :: Typeable a => (a -> Maybe b) -> MessageSelector b-selectMessageWith f = selectDynamicMessage (fromStrictDynamic >=> f)---- | Create a message selector.------ @since 0.9.1-selectDynamicMessage :: (StrictDynamic -> Maybe a) -> MessageSelector a-selectDynamicMessage = MessageSelector---- | Create a message selector that will match every message. This is /lazy/--- because the result is not 'force'ed.------ @since 0.9.1-selectAnyMessage :: MessageSelector StrictDynamic-selectAnyMessage = MessageSelector Just---- | The state that a 'Process' is currently in.-data ProcessState =- ProcessBooting -- ^ The process has just been started but not- -- scheduled yet.- | ProcessIdle -- ^ The process yielded it's time slice- | ProcessBusy -- ^ The process is busy with a non-blocking operation- | ProcessBusySleeping -- ^ The process is sleeping until the 'Timeout' given to 'Delay'- | ProcessBusyUpdatingDetails -- ^ The process is busy with 'UpdateProcessDetails'- | ProcessBusySending -- ^ The process is busy with sending a message- | ProcessBusySendingShutdown -- ^ The process is busy with killing- | ProcessBusySendingInterrupt -- ^ The process is busy with killing- | ProcessBusyReceiving -- ^ The process blocked by a 'receiveAnyMessage'- | ProcessBusyLinking -- ^ The process blocked by a 'linkProcess'- | ProcessBusyUnlinking -- ^ The process blocked by a 'unlinkProcess'- | ProcessBusyMonitoring -- ^ The process blocked by a 'monitor'- | ProcessBusyDemonitoring -- ^ The process blocked by a 'demonitor'- | ProcessInterrupted -- ^ The process was interrupted- | ProcessShuttingDown -- ^ The process was shutdown or crashed- deriving (Read, Show, Ord, Eq, Enum, Generic)--instance NFData ProcessState--instance Default ProcessState where- def = ProcessBooting---- | This kind is used to indicate if a 'Interrupt' can be treated like--- a short interrupt which can be handled or ignored.-data ExitRecovery = Recoverable | NoRecovery- deriving (Typeable, Ord, Eq, Generic)--instance NFData ExitRecovery--instance Show ExitRecovery where- showsPrec d =- showParen (d >= 10)- . (\case- Recoverable -> showString "recoverable"- NoRecovery -> showString "not recoverable"- )---- | Get the 'ExitRecovery'-toExitRecovery :: Interrupt r -> ExitRecovery-toExitRecovery =- \case- NormalExitRequested -> Recoverable- (NormalExitRequestedWith _) -> Recoverable- (OtherProcessNotRunning _) -> Recoverable- (TimeoutInterrupt _) -> Recoverable- (LinkedProcessCrashed _) -> Recoverable- (InterruptedBy _) -> Recoverable- (ErrorInterrupt _) -> Recoverable- ExitNormally -> NoRecovery- (ExitNormallyWith _) -> NoRecovery- (ExitUnhandledError _) -> NoRecovery- (ExitProcessCancelled _) -> NoRecovery- (ExitOtherProcessNotRunning _) -> NoRecovery---- | This value indicates whether a process exited in way consistent with--- the planned behaviour or not.-data ExitSeverity = NormalExit | Crash- deriving (Typeable, Ord, Eq, Generic)--instance Show ExitSeverity where- showsPrec d =- showParen (d >= 10)- . (\case- NormalExit -> showString "exit success"- Crash -> showString "crash"- )--instance NFData ExitSeverity---- | Get the 'ExitSeverity' of a 'Interrupt'.-toExitSeverity :: Interrupt e -> ExitSeverity-toExitSeverity = \case- ExitNormally -> NormalExit- NormalExitRequested -> NormalExit- _ -> Crash---- | A sum-type with reasons for why a process operation, such as receiving messages,--- is interrupted in the scheduling loop.------ This includes errors, that can occur when scheduling messages.------ @since 0.23.0-data Interrupt (t :: ExitRecovery) where- -- | A process has finished a unit of work and might exit or work on- -- something else. This is primarily used for interrupting infinite- -- server loops, allowing for additional cleanup work before- -- exiting (e.g. with 'ExitNormally')- --- -- @since 0.13.2- NormalExitRequested- :: Interrupt 'Recoverable- -- | Extension of 'ExitNormally' with a custom reason- --- -- @since 0.30.0- NormalExitRequestedWith- :: forall a . (Typeable a, Show a, NFData a) => a -> Interrupt 'Recoverable- -- | A process that should be running was not running.- OtherProcessNotRunning- :: ProcessId -> Interrupt 'Recoverable- -- | A 'Recoverable' timeout has occurred.- TimeoutInterrupt- :: String -> Interrupt 'Recoverable- -- | A linked process is down, see 'Link' for a discussion on linking.- LinkedProcessCrashed- :: ProcessId -> Interrupt 'Recoverable- -- | An exit reason that has an error message and is 'Recoverable'.- ErrorInterrupt- :: String -> Interrupt 'Recoverable- -- | An interrupt with a custom message.- --- -- @since 0.30.0- InterruptedBy- :: forall a . (Typeable a, Show a, NFData a) => a -> Interrupt 'Recoverable- -- | A process function returned or exited without any error.- ExitNormally- :: Interrupt 'NoRecovery- -- | A process function returned or exited without any error, and with a custom message- --- -- @since 0.30.0- ExitNormallyWith- :: forall a . (Typeable a, Show a, NFData a) => a -> Interrupt 'NoRecovery- -- | An error causes the process to exit immediately.- -- For example an unexpected runtime exception was thrown, i.e. an exception- -- derived from 'Control.Exception.Safe.SomeException'- -- Or a 'Recoverable' Interrupt was not recovered.- ExitUnhandledError- :: Text -> Interrupt 'NoRecovery- -- | A process shall exit immediately, without any cleanup was cancelled (e.g. killed, in 'Async.cancel')- ExitProcessCancelled- :: Maybe ProcessId -> Interrupt 'NoRecovery- -- | A process that is vital to the crashed process was not running- ExitOtherProcessNotRunning- :: ProcessId -> Interrupt 'NoRecovery- deriving Typeable---- | Return either 'ExitNormally' or 'interruptToExit' from a 'Recoverable' 'Interrupt';------ If the 'Interrupt' is 'NormalExitRequested' then return 'ExitNormally'-interruptToExit :: Interrupt 'Recoverable -> Interrupt 'NoRecovery-interruptToExit NormalExitRequested = ExitNormally-interruptToExit (NormalExitRequestedWith x) = (ExitNormallyWith x)-interruptToExit x = ExitUnhandledError (pack (show x))--instance Show (Interrupt x) where- showsPrec d =- showParen (d >= 10) .- (\case- NormalExitRequested -> showString "interrupt: A normal exit was requested"- NormalExitRequestedWith p -> showString "interrupt: A normal exit was requested: " . showsPrec 10 p- OtherProcessNotRunning p -> showString "interrupt: Another process is not running: " . showsPrec 10 p- TimeoutInterrupt reason -> showString "interrupt: A timeout occured: " . showString reason- LinkedProcessCrashed m -> showString "interrupt: A linked process " . showsPrec 10 m . showString " crashed"- InterruptedBy reason -> showString "interrupt: " . showsPrec 10 reason- ErrorInterrupt reason -> showString "interrupt: An error occured: " . showString reason- ExitNormally -> showString "exit: Process finished successfully"- ExitNormallyWith reason -> showString "exit: Process finished successfully: " . showsPrec 10 reason- ExitUnhandledError w -> showString "exit: Unhandled " . showString (unpack w)- ExitProcessCancelled Nothing -> showString "exit: The process was cancelled by a runtime exception"- ExitProcessCancelled (Just origin) -> showString "exit: The process was cancelled by: " . shows origin- ExitOtherProcessNotRunning p -> showString "exit: Another process is not running: " . showsPrec 10 p)--instance Exc.Exception (Interrupt 'Recoverable)-instance Exc.Exception (Interrupt 'NoRecovery )--instance NFData (Interrupt x) where- rnf NormalExitRequested = rnf ()- rnf (NormalExitRequestedWith !l) = rnf l- rnf (OtherProcessNotRunning !l) = rnf l- rnf (TimeoutInterrupt !l) = rnf l- rnf (LinkedProcessCrashed !l) = rnf l- rnf (ErrorInterrupt !l) = rnf l- rnf (InterruptedBy !l) = rnf l- rnf ExitNormally = rnf ()- rnf (ExitNormallyWith !l) = rnf l- rnf (ExitUnhandledError !l) = rnf l- rnf (ExitProcessCancelled !o) = rnf o- rnf (ExitOtherProcessNotRunning !l) = rnf l--instance Ord (Interrupt x) where- compare NormalExitRequested NormalExitRequested = EQ- compare NormalExitRequested _ = LT- compare _ NormalExitRequested = GT- compare (NormalExitRequestedWith _) (NormalExitRequestedWith _) = EQ- compare (NormalExitRequestedWith _) _ = LT- compare _ (NormalExitRequestedWith _) = GT- compare (OtherProcessNotRunning l) (OtherProcessNotRunning r) = compare l r- compare (OtherProcessNotRunning _) _ = LT- compare _ (OtherProcessNotRunning _) = GT- compare (TimeoutInterrupt l) (TimeoutInterrupt r) = compare l r- compare (TimeoutInterrupt _) _ = LT- compare _ (TimeoutInterrupt _) = GT- compare (LinkedProcessCrashed l) (LinkedProcessCrashed r) = compare l r- compare (LinkedProcessCrashed _) _ = LT- compare _ (LinkedProcessCrashed _) = GT- compare (InterruptedBy _) (InterruptedBy _) = EQ- compare (InterruptedBy _) _ = LT- compare _ (InterruptedBy _) = GT- compare (ErrorInterrupt l) (ErrorInterrupt r) = compare l r- compare ExitNormally ExitNormally = EQ- compare ExitNormally _ = LT- compare _ ExitNormally = GT- compare (ExitNormallyWith _) (ExitNormallyWith _) = EQ- compare (ExitNormallyWith _ ) _ = LT- compare _ (ExitNormallyWith _) = GT- compare (ExitUnhandledError l) (ExitUnhandledError r) = compare l r- compare (ExitUnhandledError _ ) _ = LT- compare _ (ExitUnhandledError _) = GT- compare (ExitOtherProcessNotRunning l) (ExitOtherProcessNotRunning r) = compare l r- compare (ExitOtherProcessNotRunning _ ) _ = LT- compare _ (ExitOtherProcessNotRunning _) = GT- compare (ExitProcessCancelled l) (ExitProcessCancelled r) = compare l r--instance Eq (Interrupt x) where- (==) NormalExitRequested NormalExitRequested = True- (==) (OtherProcessNotRunning l) (OtherProcessNotRunning r) = (==) l r- (==) ExitNormally ExitNormally = True- (==) (TimeoutInterrupt l) (TimeoutInterrupt r) = l == r- (==) (LinkedProcessCrashed l) (LinkedProcessCrashed r) = l == r- (==) (ErrorInterrupt l) (ErrorInterrupt r) = (==) l r- (==) (ExitUnhandledError l) (ExitUnhandledError r) = (==) l r- (==) (ExitOtherProcessNotRunning l) (ExitOtherProcessNotRunning r) = (==) l r- (==) (ExitProcessCancelled l) (ExitProcessCancelled r) = l == r- (==) _ _ = False---- | A predicate for linked process __crashes__.-isProcessDownInterrupt :: Maybe ProcessId -> Interrupt r -> Bool-isProcessDownInterrupt mOtherProcess =- \case- NormalExitRequested -> False- NormalExitRequestedWith _ -> False- OtherProcessNotRunning _ -> False- TimeoutInterrupt _ -> False- LinkedProcessCrashed p -> maybe True (== p) mOtherProcess- InterruptedBy _ -> False- ErrorInterrupt _ -> False- ExitNormally -> False- ExitNormallyWith _ -> False- ExitUnhandledError _ -> False- ExitProcessCancelled _ -> False- ExitOtherProcessNotRunning _ -> False---- | 'Interrupt's which are 'Recoverable'.-type RecoverableInterrupt = Interrupt 'Recoverable---- | This adds a layer of the 'Interrupts' effect on top of 'Processes'-type Processes e = Interrupts ': SafeProcesses e---- | A constraint for an effect set that requires the presence of 'Processes'.------ This constrains the effect list to look like this:--- @[e1 ... eN, 'Interrupts', 'Process' [e(N+1) .. e(N+k)], e(N+1) .. e(N+k)]@------ It constrains @e@ beyond 'HasSafeProcesses' to encompass 'Interrupts'.------ @since 0.27.1-type HasProcesses e inner = (HasSafeProcesses e inner, Member Interrupts e)---- | /Cons/ 'Process' onto a list of effects. This is called @SafeProcesses@ because--- the the actions cannot be interrupted in.-type SafeProcesses r = Process r ': r---- | A constraint for an effect set that requires the presence of 'SafeProcesses'.------ This constrains the effect list to look like this:--- @[e1 ... eN, 'Process' [e(N+1) .. e(N+k)], e(N+1) .. e(N+k)]@------ It constrains @e@ to support the (only) 'Process' effect.------ This is more relaxed that 'HasProcesses' since it does not require 'Interrupts'.------ @since 0.27.1-type HasSafeProcesses e inner = (SetMember Process (Process inner) e)---- | 'Exc'eptions containing 'Interrupt's.--- See 'handleInterrupts', 'exitOnInterrupt' or 'provideInterrupts'-type Interrupts = Exc (Interrupt 'Recoverable)---- | Handle all 'Interrupt's of an 'Processes' by--- wrapping them up in 'interruptToExit' and then do a process 'Shutdown'.-provideInterruptsShutdown- :: forall e a . Eff (Processes e) a -> Eff (SafeProcesses e) a-provideInterruptsShutdown e = do- res <- provideInterrupts e- case res of- Left ex -> send (Shutdown @e (interruptToExit ex))- Right a -> return a---- | Handle 'Interrupt's arising during process operations, e.g.--- when a linked process crashes while we wait in a 'receiveSelectedMessage'--- via a call to 'interrupt'.-handleInterrupts- :: (HasCallStack, Member Interrupts r)- => (Interrupt 'Recoverable -> Eff r a)- -> Eff r a- -> Eff r a-handleInterrupts = flip catchError---- | Like 'handleInterrupts', but instead of passing the 'Interrupt'--- to a handler function, 'Either' is returned.------ @since 0.13.2-tryUninterrupted- :: (HasCallStack, Member Interrupts r)- => Eff r a- -> Eff r (Either (Interrupt 'Recoverable) a)-tryUninterrupted = handleInterrupts (pure . Left) . fmap Right---- | Handle interrupts by logging them with `logProcessExit` and otherwise--- ignoring them.-logInterrupts- :: forall r- . (Member Logs r, HasCallStack, Member Interrupts r)- => Eff r ()- -> Eff r ()-logInterrupts = handleInterrupts logProcessExit---- | Handle 'Interrupt's arising during process operations, e.g.--- when a linked process crashes while we wait in a 'receiveSelectedMessage'--- via a call to 'interrupt'.-exitOnInterrupt- :: (HasCallStack, HasProcesses r q)- => Eff r a- -> Eff r a-exitOnInterrupt = handleInterrupts (exitBecause . interruptToExit)---- | Handle 'Interrupt's arising during process operations, e.g.--- when a linked process crashes while we wait in a 'receiveSelectedMessage'--- via a call to 'interrupt'.-provideInterrupts- :: HasCallStack => Eff (Interrupts ': r) a -> Eff r (Either (Interrupt 'Recoverable) a)-provideInterrupts = runError----- | Wrap all (left) 'Interrupt's into 'interruptToExit' and--- return the (right) 'NoRecovery' 'Interrupt's as is.-mergeEitherInterruptAndExitReason- :: Either (Interrupt 'Recoverable) (Interrupt 'NoRecovery) -> Interrupt 'NoRecovery-mergeEitherInterruptAndExitReason = either interruptToExit id---- | Throw an 'Interrupt', can be handled by 'handleInterrupts' or--- 'exitOnInterrupt' or 'provideInterrupts'.-interrupt :: (HasCallStack, Member Interrupts r) => Interrupt 'Recoverable -> Eff r a-interrupt = throwError---- | A predicate for crashes. A /crash/ happens when a process exits--- with an 'Interrupt' other than 'ExitNormally'-isCrash :: Interrupt x -> Bool-isCrash NormalExitRequested = False-isCrash ExitNormally = False-isCrash _ = True---- | A predicate for recoverable exit reasons. This predicate defines the--- exit reasons which functions such as 'executeAndResume'-isRecoverable :: Interrupt x -> Bool-isRecoverable (toExitRecovery -> Recoverable) = True-isRecoverable _ = False---- | An existential wrapper around 'Interrupt'-data SomeExitReason where- SomeExitReason ::Interrupt x -> SomeExitReason--instance Ord SomeExitReason where- compare = compare `on` fromSomeExitReason--instance Eq SomeExitReason where- (==) = (==) `on` fromSomeExitReason--instance Show SomeExitReason where- show = show . fromSomeExitReason--instance NFData SomeExitReason where- rnf = rnf . fromSomeExitReason---- | Partition a 'SomeExitReason' back into either a 'NoRecovery'--- or a 'Recoverable' 'Interrupt'-fromSomeExitReason :: SomeExitReason -> Either (Interrupt 'NoRecovery) (Interrupt 'Recoverable)-fromSomeExitReason (SomeExitReason e) =- case e of- recoverable@NormalExitRequested -> Right recoverable- recoverable@(NormalExitRequestedWith _) -> Right recoverable- recoverable@(OtherProcessNotRunning _) -> Right recoverable- recoverable@(TimeoutInterrupt _) -> Right recoverable- recoverable@(LinkedProcessCrashed _) -> Right recoverable- recoverable@(InterruptedBy _) -> Right recoverable- recoverable@(ErrorInterrupt _) -> Right recoverable- noRecovery@ExitNormally -> Left noRecovery- noRecovery@(ExitNormallyWith _) -> Left noRecovery- noRecovery@(ExitUnhandledError _) -> Left noRecovery- noRecovery@(ExitProcessCancelled _) -> Left noRecovery- noRecovery@(ExitOtherProcessNotRunning _) -> Left noRecovery---- | Print a 'Interrupt' to 'Just' a formatted 'String' when 'isCrash'--- is 'True'.--- This can be useful in combination with view patterns, e.g.:------ > logCrash :: Interrupt -> Eff e ()--- > logCrash (toCrashReason -> Just reason) = logError reason--- > logCrash _ = return ()------ Though this can be improved to:------ > logCrash = traverse_ logError . toCrashReason----toCrashReason :: Interrupt x -> Maybe T.Text-toCrashReason e | isCrash e = Just (T.pack (show e))- | otherwise = Nothing---- | Log the 'Interrupt's-logProcessExit- :: forall e x . (Member Logs e, HasCallStack) => Interrupt x -> Eff e ()-logProcessExit (toCrashReason -> Just ex) = withFrozenCallStack (logWarning ex)-logProcessExit ex = withFrozenCallStack (logDebug (fromString (show ex)))----- | Execute a and action and return the result;--- if the process is interrupted by an error or exception, or an explicit--- shutdown from another process, or through a crash of a linked process, i.e.--- whenever the exit reason satisfies 'isRecoverable', return the exit reason.-executeAndResume- :: forall q r v- . (HasSafeProcesses r q, HasCallStack)- => Process q (ResumeProcess v)- -> Eff r (Either (Interrupt 'Recoverable) v)-executeAndResume processAction = do- result <- send processAction- case result of- ResumeWith !value -> return (Right value)- Interrupted r -> return (Left r)---- | Execute a 'Process' action and resume the process, exit--- the process when an 'Interrupts' was raised. Use 'executeAndResume' to catch--- interrupts.-executeAndResumeOrExit- :: forall r q v- . (HasSafeProcesses r q, HasCallStack)- => Process q (ResumeProcess v)- -> Eff r v-executeAndResumeOrExit processAction = do- result <- send processAction- case result of- ResumeWith !value -> return value- Interrupted r -> send (Shutdown @q (interruptToExit r))---- | Execute a 'Process' action and resume the process, exit--- the process when an 'Interrupts' was raised. Use 'executeAndResume' to catch--- interrupts.-executeAndResumeOrThrow- :: forall q r v- . (HasProcesses r q, HasCallStack)- => Process q (ResumeProcess v)- -> Eff r v-executeAndResumeOrThrow processAction = do- result <- send processAction- case result of- ResumeWith !value -> return value- Interrupted r -> interrupt r---- * Process Effects---- | Use 'executeAndResumeOrExit' to execute 'YieldProcess'. Refer to 'YieldProcess'--- for more information.-yieldProcess- :: forall r q- . (HasProcesses r q, HasCallStack)- => Eff r ()-yieldProcess = executeAndResumeOrThrow YieldProcess----- | Simply block until the time in the 'Timeout' has passed.------ @since 0.30.0-delay- :: forall r q- . ( HasProcesses r q- , HasCallStack- )- => Timeout- -> Eff r ()-delay = executeAndResumeOrThrow . Delay---- | Send a message to a process addressed by the 'ProcessId'.--- See 'SendMessage'.------ The message will be reduced to normal form ('rnf') by/in the caller process.-sendMessage- :: forall o r q- . ( HasProcesses r q- , HasCallStack- , Typeable o- , NFData o- )- => ProcessId- -> o- -> Eff r ()-sendMessage pid message =- rnf pid `seq` toStrictDynamic message- `seq` executeAndResumeOrThrow (SendMessage pid (toStrictDynamic message))---- | Send a 'Dynamic' value to a process addressed by the 'ProcessId'.--- See 'SendMessage'.-sendAnyMessage- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessId- -> StrictDynamic- -> Eff r ()-sendAnyMessage pid message =- executeAndResumeOrThrow (SendMessage pid message)---- | Exit a process addressed by the 'ProcessId'. The process will exit,--- it might do some cleanup, but is ultimately unrecoverable.--- See 'SendShutdown'.-sendShutdown- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessId- -> Interrupt 'NoRecovery- -> Eff r ()-sendShutdown pid s =- pid `deepseq` s `deepseq` executeAndResumeOrThrow (SendShutdown pid s)---- | Interrupts a process addressed by the 'ProcessId'. The process might exit,--- or it may continue.--- | Like 'sendInterrupt', but also return @True@ iff the process to exit exists.-sendInterrupt- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessId- -> Interrupt 'Recoverable- -> Eff r ()-sendInterrupt pid s =- pid `deepseq` s `deepseq` executeAndResumeOrThrow (SendInterrupt pid s)---- | Start a new process, the new process will execute an effect, the function--- will return immediately with a 'ProcessId'. If the new process is--- interrupted, the process will 'Shutdown' with the 'Interrupt'--- wrapped in 'interruptToExit'. For specific use cases it might be better to use--- 'spawnRaw'.-spawn- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessTitle- -> Eff (Processes q) ()- -> Eff r ProcessId-spawn t child =- executeAndResumeOrThrow (Spawn @q t (provideInterruptsShutdown child))---- | Like 'spawn' but return @()@.-spawn_- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessTitle- -> Eff (Processes q) ()- -> Eff r ()-spawn_ t child = void (spawn t child)---- | Start a new process, and immediately link to it.------ See 'Link' for a discussion on linking.------ @since 0.12.0-spawnLink- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessTitle- -> Eff (Processes q) ()- -> Eff r ProcessId-spawnLink t child =- executeAndResumeOrThrow (SpawnLink @q t (provideInterruptsShutdown child))---- | Start a new process, the new process will execute an effect, the function--- will return immediately with a 'ProcessId'. The spawned process has only the--- /raw/ 'SafeProcesses' effects. For non-library code 'spawn' might be better--- suited.-spawnRaw- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessTitle- -> Eff (SafeProcesses q) ()- -> Eff r ProcessId-spawnRaw t child = executeAndResumeOrThrow (Spawn @q t child)---- | Like 'spawnRaw' but return @()@.-spawnRaw_- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessTitle- -> Eff (SafeProcesses q) ()- -> Eff r ()-spawnRaw_ t = void . spawnRaw t---- | Return 'True' if the process is alive.------ @since 0.12.0-isProcessAlive- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessId- -> Eff r Bool-isProcessAlive pid = isJust <$> executeAndResumeOrThrow (GetProcessState pid)----- | Return the 'ProcessTitle', 'ProcessDetails' and 'ProcessState',--- for the given process, if the process is alive.------ @since 0.24.1-getProcessState- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessId- -> Eff r (Maybe (ProcessTitle, ProcessDetails, ProcessState))-getProcessState pid = executeAndResumeOrThrow (GetProcessState pid)---- | Replace the 'ProcessDetails' of the process.------ @since 0.24.1-updateProcessDetails- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessDetails- -> Eff r ()-updateProcessDetails pd = executeAndResumeOrThrow (UpdateProcessDetails pd)---- | Block until a message was received.--- See 'ReceiveSelectedMessage' for more documentation.-receiveAnyMessage- :: forall r q- . (HasCallStack, HasProcesses r q)- => Eff r StrictDynamic-receiveAnyMessage =- executeAndResumeOrThrow (ReceiveSelectedMessage selectAnyMessage)---- | Block until a message was received, that is not 'Nothing' after applying--- a callback to it.--- See 'ReceiveSelectedMessage' for more documentation.-receiveSelectedMessage- :: forall r q a- . ( HasCallStack- , Show a- , HasProcesses r q- )- => MessageSelector a- -> Eff r a-receiveSelectedMessage f = executeAndResumeOrThrow (ReceiveSelectedMessage f)---- | Receive and cast the message to some 'Typeable' instance.--- See 'ReceiveSelectedMessage' for more documentation.--- This will wait for a message of the return type using 'receiveSelectedMessage'-receiveMessage- :: forall a r q- . ( HasCallStack- , Typeable a- , NFData a- , Show a- , HasProcesses r q- )- => Eff r a-receiveMessage = receiveSelectedMessage (MessageSelector fromStrictDynamic)---- | Remove and return all messages currently enqueued in the process message--- queue.------ @since 0.12.0-flushMessages- :: forall r q- . (HasCallStack, HasProcesses r q)- => Eff r [StrictDynamic]-flushMessages = executeAndResumeOrThrow @q FlushMessages---- | Enter a loop to receive messages and pass them to a callback, until the--- function returns 'Just' a result.--- Only the messages of the given type will be received.--- If the process is interrupted by an exception of by a 'SendShutdown' from--- another process, with an exit reason that satisfies 'isRecoverable', then--- the callback will be invoked with @'Left' 'Interrupt'@, otherwise the--- process will be exited with the same reason using 'exitBecause'.--- See also 'ReceiveSelectedMessage' for more documentation.-receiveSelectedLoop- :: forall r q a endOfLoopResult- . (HasSafeProcesses r q, HasCallStack)- => MessageSelector a- -> (Either (Interrupt 'Recoverable) a -> Eff r (Maybe endOfLoopResult))- -> Eff r endOfLoopResult-receiveSelectedLoop selector handlers = do- mReq <- send (ReceiveSelectedMessage @q @a selector)- mRes <- case mReq of- Interrupted reason -> handlers (Left reason)- ResumeWith message -> handlers (Right message)- maybe (receiveSelectedLoop selector handlers) return mRes---- | Like 'receiveSelectedLoop' but /not selective/.--- See also 'selectAnyMessage', 'receiveSelectedLoop'.-receiveAnyLoop- :: forall r q endOfLoopResult- . (HasSafeProcesses r q, HasCallStack)- => (Either (Interrupt 'Recoverable) StrictDynamic -> Eff r (Maybe endOfLoopResult))- -> Eff r endOfLoopResult-receiveAnyLoop = receiveSelectedLoop selectAnyMessage---- | Like 'receiveSelectedLoop' but refined to casting to a specific 'Typeable'--- using 'selectMessage'.-receiveLoop- :: forall r q a endOfLoopResult- . (HasSafeProcesses r q, HasCallStack, NFData a, Typeable a)- => (Either (Interrupt 'Recoverable) a -> Eff r (Maybe endOfLoopResult))- -> Eff r endOfLoopResult-receiveLoop = receiveSelectedLoop selectMessage---- | Returns the 'ProcessId' of the current process.-self :: (HasCallStack, HasSafeProcesses r q) => Eff r ProcessId-self = executeAndResumeOrExit SelfPid---- | Generate a unique 'Int' for the current process.-makeReference- :: (HasCallStack, HasProcesses r q)- => Eff r Int-makeReference = executeAndResumeOrThrow MakeReference---- | A value that contains a unique reference of a process--- monitoring.------ @since 0.12.0-data MonitorReference =- MonitorReference { monitorIndex :: Int- , monitoredProcess :: ProcessId- }- deriving (Read, Eq, Ord, Generic, Typeable)--instance NFData MonitorReference--instance Show MonitorReference where- showsPrec d m = showParen- (d >= 10)- (showString "monitor: " . shows (monitorIndex m) . showChar ' ' . shows- (monitoredProcess m)- )---- | Monitor another process. When the monitored process exits a--- 'ProcessDown' is sent to the calling process.--- The return value is a unique identifier for that monitor.--- There can be multiple monitors on the same process,--- and a message for each will be sent.--- If the process is already dead, the 'ProcessDown' message--- will be sent immediately, without exit reason------ @since 0.12.0-monitor- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessId- -> Eff r MonitorReference-monitor = executeAndResumeOrThrow . Monitor . force---- | Remove a monitor created with 'monitor'.------ @since 0.12.0-demonitor- :: forall r q- . (HasCallStack, HasProcesses r q)- => MonitorReference- -> Eff r ()-demonitor = executeAndResumeOrThrow . Demonitor . force---- | 'monitor' another process before while performing an action--- and 'demonitor' afterwards.------ @since 0.12.0-withMonitor- :: (HasCallStack, HasProcesses r q)- => ProcessId- -> (MonitorReference -> Eff r a)- -> Eff r a-withMonitor pid e = monitor pid >>= \ref -> e ref <* demonitor ref---- | A 'MessageSelector' for receiving either a monitor of the--- given process or another message.------ @since 0.12.0-receiveWithMonitor- :: ( HasCallStack- , HasProcesses r q- , Typeable a- , Show a- )- => ProcessId- -> MessageSelector a- -> Eff r (Either ProcessDown a)-receiveWithMonitor pid sel = withMonitor- pid- (\ref ->- receiveSelectedMessage (Left <$> selectProcessDown ref <|> Right <$> sel)- )---- | A monitored process exited.--- This message is sent to a process by the scheduler, when--- a process that was monitored died.------ @since 0.12.0-data ProcessDown =- ProcessDown- { downReference :: !MonitorReference- , downReason :: !(Interrupt 'NoRecovery)- , downProcess :: !ProcessId- }- deriving (Typeable, Generic, Eq, Ord)---- | Make an 'Interrupt' for a 'ProcessDown' message.------ For example: @doSomething >>= either (interrupt . becauseProcessIsDown) return@------ @since 0.12.0-becauseProcessIsDown :: ProcessDown -> Interrupt 'Recoverable-becauseProcessIsDown = OtherProcessNotRunning . monitoredProcess . downReference--instance NFData ProcessDown--instance Show ProcessDown where- showsPrec d =- showParen (d >= 10)- . (\case- ProcessDown ref reason pid ->- showString "down: "- . shows pid- . showChar ' '- . shows ref- . showChar ' '- . showsPrec 11 reason- )---- | A 'MessageSelector' for the 'ProcessDown' message of a specific--- process.------ The parameter is the value obtained by 'monitor'.------ @since 0.12.0-selectProcessDown :: MonitorReference -> MessageSelector ProcessDown-selectProcessDown ref0 =- filterMessage (\(ProcessDown ref _reason _pid) -> ref0 == ref)---- | A 'MessageSelector' for the 'ProcessDown' message. of a specific--- process.------ In contrast to 'selectProcessDown' this function matches the 'ProcessId'.------ @since 0.28.0-selectProcessDownByProcessId :: ProcessId -> MessageSelector ProcessDown-selectProcessDownByProcessId pid0 =- filterMessage (\(ProcessDown _ref _reason pid) -> pid0 == pid)---- | Connect the calling process to another process, such that--- if one of the processes crashes (i.e. 'isCrash' returns 'True'), the other--- is shutdown with the 'Interrupt' 'LinkedProcessCrashed'.------ See 'Link' for a discussion on linking.------ @since 0.12.0-linkProcess- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessId- -> Eff r ()-linkProcess = executeAndResumeOrThrow . Link . force---- | Unlink the calling process from the other process.------ See 'Link' for a discussion on linking.------ @since 0.12.0-unlinkProcess- :: forall r q- . (HasCallStack, HasProcesses r q)- => ProcessId- -> Eff r ()-unlinkProcess = executeAndResumeOrThrow . Unlink . force---- | Exit the process with a 'Interrupt'.-exitBecause- :: forall r q a- . (HasCallStack, HasSafeProcesses r q)- => Interrupt 'NoRecovery- -> Eff r a-exitBecause = send . Shutdown @q . force---- | Exit the process.-exitNormally- :: forall r q a . (HasCallStack, HasSafeProcesses r q) => Eff r a-exitNormally = exitBecause ExitNormally---- | Exit the process with an error.-exitWithError- :: forall r q a- . (HasCallStack,HasSafeProcesses r q)- => String- -> Eff r a-exitWithError = exitBecause . interruptToExit . ErrorInterrupt---- | Each process is identified by a single process id, that stays constant--- throughout the life cycle of a process. Also, message sending relies on these--- values to address messages to processes.-newtype ProcessId = ProcessId { _fromProcessId :: Int }- deriving (Eq,Ord,Typeable,Bounded,Num, Enum, Integral, Real, NFData)--instance Read ProcessId where- readsPrec _ ('!' : rest1) = case reads rest1 of- [(c, rest2)] -> [(ProcessId c, rest2)]- _ -> []- readsPrec _ _ = []--instance Show ProcessId where- showsPrec _ (ProcessId !c) = showChar '!' . shows c--makeLenses ''ProcessId---- | Serialize and send a message to the process in a 'Receiver'.------ EXPERIMENTAL------ @since 0.29.0-sendToReceiver :: (NFData o, HasProcesses r q) => Receiver o -> o -> Eff r ()-sendToReceiver (Receiver pid serializer) message =- rnf message `seq` sendMessage pid (toStrictDynamic (serializer message))---- | A 'ProcessId' and a 'Serializer'. EXPERIMENTAL------ See 'sendToReceiver'.------ @since 0.29.0-data Receiver a =- forall out . (NFData out, Typeable out, Show out) =>- Receiver { _receiverPid :: ProcessId- , _receiverSerializer :: a -> out- }- deriving (Typeable)--instance NFData (Receiver o) where- rnf (Receiver e f) = f `seq` rnf e--instance Eq (Receiver o) where- (==) = (==) `on` _receiverPid--instance Ord (Receiver o) where- compare = compare `on` _receiverPid--instance Contravariant Receiver where- contramap f (Receiver p s) = Receiver p (s . f)--instance Typeable protocol => Show (Receiver protocol) where- showsPrec d (Receiver c _) =- showParen (d>=10)- (showSTypeRep (SomeTypeRep (Type.Reflection.typeRep @protocol)) . showsPrec 10 c)--makeLenses ''Receiver++-- | The message passing effect.+--+-- This module describes an abstract message passing effect, and a process+-- effect, mimicking Erlang's process and message semantics.+--+-- Two __scheduler__ implementations for the 'Process' effect are provided:+--+-- * A scheduler using @forkIO@, i.e. relying on the multi threaded GHC runtime:+-- "Control.Eff.Concurrent.Process.ForkIOScheduler"+--+-- * And a /pure/(rer) coroutine based scheduler in:+-- "Control.Eff.Concurrent.Process.SingleThreadedScheduler"+module Control.Eff.Concurrent.Process+ ( -- * Process Effect+ Process (..),++ -- ** Process Effect Aliases+ SafeProcesses,+ Processes,++ -- ** Process Effect Constraints+ HasProcesses,+ HasSafeProcesses,++ -- ** Process Info+ ProcessTitle (..),+ fromProcessTitle,+ toProcessTitle,+ ProcessDetails (..),+ fromProcessDetails,++ -- ** Process Timer+ Timeout (TimeoutMicros, fromTimeoutMicros),++ -- ** Message Data+ Message (),+ toMessage,+ fromMessage,+ unwrapMessage,+ Serializer (..),++ -- ** ProcessId Type+ ProcessId (..),+ fromProcessId,++ -- ** Process State+ ProcessState (..),++ -- ** Yielding+ yieldProcess,++ -- ** Waiting/Sleeping+ delay,++ -- ** Sending Messages+ sendMessage,+ sendAnyMessage,++ -- ** Utilities+ makeReference,++ -- ** Receiving Messages+ receiveMessage,+ receiveSelectedMessage,+ flushMessages,+ receiveAnyMessage,+ receiveLoop,+ receiveSelectedLoop,+ receiveAnyLoop,++ -- ** Selecting Messages to Receive+ MessageSelector (runMessageSelector),+ selectMessage,+ filterMessage,+ selectMessageWith,+ selectDynamicMessage,+ selectAnyMessage,++ -- ** Process State Reflection+ self,+ isProcessAlive,+ getProcessState,+ updateProcessDetails,++ -- ** Spawning+ spawn,+ spawn_,+ spawnLink,+ spawnRaw,+ spawnRaw_,++ -- ** Process Operation Execution+ ResumeProcess (..),+ executeAndResume,+ executeAndResumeOrExit,+ executeAndResumeOrThrow,++ -- ** Exits and Interrupts++ -- *** Interrupting Processes+ interrupt,+ sendInterrupt,++ -- *** Exiting Processes+ exitBecause,+ exitNormally,+ exitWithError,+ sendShutdown, -- TODO rename to 'sendExit'++ -- *** Linking Processes+ linkProcess,+ unlinkProcess,++ -- *** Monitor Processes+ monitor,+ demonitor,+ ProcessDown (..),+ selectProcessDown,+ selectProcessDownByProcessId,+ becauseOtherProcessNotRunning,+ MonitorReference (..),+ monitorIndex,+ monitoredProcess,+ withMonitor,+ receiveWithMonitor,++ -- *** Exit and Interrupt Reasons+ InterruptReason (..),+ ShutdownReason (..),+ Interrupts,+ interruptToExit,+ ExitSeverity (..),+ InterruptOrShutdown (..),+ UnhandledProcessInterrupt (..),+ UnhandledProcessExit (..),+ toExitSeverity,+ isLinkedProcessCrashed,+ isCrash,+ toCrashReason,+ logProcessExit,++ -- ** Control Flow++ -- *** Process Interrupt Recoverable Handling+ provideInterruptsShutdown,+ handleInterrupts,+ tryUninterrupted,+ exitOnInterrupt,+ logInterrupts,+ provideInterrupts,+ mergeEitherInterruptAndExitReason,+ )+where++import Control.Applicative+import Control.DeepSeq+import Control.Eff+import Control.Eff.Exception+import Control.Eff.Extend+import Control.Eff.Log.Handler+import Control.Eff.Log.Message+import qualified Control.Exception as Exc+import Control.Lens+import Control.Monad+ ( void,+ (>=>),+ )+import Data.Default+import Data.Dynamic+import Data.Functor.Contravariant ()+import Data.Kind+import Data.Maybe+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics+ ( Generic,+ Generic1,+ )+import GHC.Stack++-- | The process effect is the basis for message passing concurrency. This+-- effect describes an interface for concurrent, communicating isolated+-- processes identified uniquely by a process-id.+--+-- Processes can raise exceptions that can be caught, exit gracefully or with an+-- error, or be killed by other processes, with the option of ignoring the+-- shutdown request.+--+-- Process Scheduling is implemented in different modules. All scheduler+-- implementations should follow some basic rules:+--+-- * fair scheduling+--+-- * sending a message does not block+--+-- * receiving a message does block+--+-- * spawning a child blocks only a very moment+--+-- * a newly spawned process shall be scheduled before the parent process after+-- * the spawnRaw+--+-- * when the first process exists, all process should be killed immediately+data Process (r :: [Type -> Type]) b where+ -- | Remove all messages from the process' message queue+ FlushMessages :: Process r (ResumeProcess [Message])+ -- | In cooperative schedulers, this will give processing time to the+ -- scheduler. Every other operation implicitly serves the same purpose.+ --+ -- @since 0.12.0+ YieldProcess :: Process r (ResumeProcess ())+ -- | Simply wait until the time in the given 'Timeout' has elapsed and return.+ --+ -- @since 0.30.0+ Delay :: Timeout -> Process r (ResumeProcess ())+ -- | Return the current 'ProcessId'+ SelfPid :: Process r (ResumeProcess ProcessId)+ -- | Start a new process, the new process will execute an effect, the function+ -- will return immediately with a 'ProcessId'.+ Spawn :: ProcessTitle -> Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)+ -- | Start a new process, and 'Link' to it .+ --+ -- @since 0.12.0+ SpawnLink :: ProcessTitle -> Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)+ -- | Shutdown the process; irregardless of the exit reason, this function never+ -- returns,+ Shutdown :: ShutdownReason -> Process r a+ -- | Shutdown another process immediately, the other process has no way of handling this!+ SendShutdown :: ProcessId -> ShutdownReason -> Process r (ResumeProcess ())+ -- | Request that another a process interrupts. The targeted process is interrupted+ -- and gets an 'Interrupted', the target process may decide to ignore the+ -- interrupt and continue as if nothing happened.+ SendInterrupt :: ProcessId -> InterruptReason -> Process r (ResumeProcess ())+ -- | Send a message to a process addressed by the 'ProcessId'. Sending a+ -- message should __always succeed__ and return __immediately__, even if the+ -- destination process does not exist, or does not accept messages of the+ -- given type.+ SendMessage :: ProcessId -> Message -> Process r (ResumeProcess ())+ -- | Receive a message that matches a criteria.+ -- This should block until an a message was received. The message is returned+ -- as a 'ResumeProcess' value. The function should also return if an exception+ -- was caught or a shutdown was requested.+ ReceiveSelectedMessage :: forall r a. MessageSelector a -> Process r (ResumeProcess a)+ -- | Generate a unique 'Int' for the current process.+ MakeReference :: Process r (ResumeProcess Int)+ -- | Monitor another process. When the monitored process exits a+ -- 'ProcessDown' is sent to the calling process.+ -- The return value is a unique identifier for that monitor.+ -- There can be multiple monitors on the same process,+ -- and a message for each will be sent.+ -- If the process is already dead, the 'ProcessDown' message+ -- will be sent immediately, without exit reason+ --+ -- @since 0.12.0+ Monitor :: ProcessId -> Process r (ResumeProcess MonitorReference)+ -- | Remove a monitor.+ --+ -- @since 0.12.0+ Demonitor :: MonitorReference -> Process r (ResumeProcess ())+ -- | Connect the calling process to another process, such that+ -- if one of the processes crashes (i.e. 'isCrash' returns 'True'), the other+ -- is shutdown with the 'Interrupt' 'LinkedProcessCrashed'.+ --+ -- You might wonder: Why not tearing down the linked process when exiting+ -- normally?+ -- I thought about this. If a process exits normally, it should have the+ -- opportunity to shutdown stuff explicitly.+ -- And if you want to make sure that there are no dangling child processes+ -- after e.g. a broker crash, you can always use 'monitor'.+ --+ -- @since 0.12.0+ Link :: ProcessId -> Process r (ResumeProcess ())+ -- | Unlink the calling process from the other process.+ --+ -- See 'Link' for a discussion on linking.+ --+ -- @since 0.12.0+ Unlink :: ProcessId -> Process r (ResumeProcess ())+ -- | Update the 'ProcessDetails' of a process+ UpdateProcessDetails :: ProcessDetails -> Process r (ResumeProcess ())+ -- | Get the 'ProcessState' (or 'Nothing' if the process is dead)+ GetProcessState :: ProcessId -> Process r (ResumeProcess (Maybe (ProcessTitle, ProcessDetails, ProcessState)))++-- | A short title for a 'Process' for logging purposes.+--+-- @since 0.24.1+newtype ProcessTitle = MkProcessTitle {_fromProcessTitle :: LogMsg}+ deriving (Eq, Ord, NFData, Generic, IsString, Typeable, Semigroup, Monoid)++-- | Construct a 'ProcessTitle' from a 'String'.+--+-- @since 1.0.0+toProcessTitle :: String -> ProcessTitle+toProcessTitle = fromString++-- | An isomorphism lens for the 'ProcessTitle'+--+-- @since 0.24.1+fromProcessTitle :: Lens' ProcessTitle LogMsg+fromProcessTitle = iso _fromProcessTitle MkProcessTitle++instance ToLogMsg ProcessTitle where+ toLogMsg = _fromProcessTitle++instance Show ProcessTitle where+ showsPrec _ (MkProcessTitle (MkLogMsg t)) = showString (T.unpack t)++-- | A multi-line text describing the __current__+-- state of a process for debugging purposes.+--+-- @since 0.24.1+newtype ProcessDetails = MkProcessDetails {_fromProcessDetails :: Text}+ deriving (Eq, Ord, NFData, Generic, IsString, Typeable, Semigroup, Monoid)++-- | An isomorphism lens for the 'ProcessDetails'+--+-- @since 0.24.1+fromProcessDetails :: Lens' ProcessDetails Text+fromProcessDetails = iso _fromProcessDetails MkProcessDetails++instance Show ProcessDetails where+ showsPrec _ (MkProcessDetails t) = showString (T.unpack t)++-- | A number of micro seconds.+--+-- @since 0.12.0+newtype Timeout = TimeoutMicros {fromTimeoutMicros :: Int}+ deriving (NFData, Ord, Eq, Num, Integral, Real, Enum, Typeable, Show)++instance ToLogMsg Timeout where+ toLogMsg (TimeoutMicros u) = packLogMsg (show u ++ "µs")++-- | Data flows between 'Process'es via these messages.+--+-- This is just a newtype wrapper around 'Dynamic'.+-- The reason this type exists is to force construction through the code in this+-- module, which always evaluates a message to /normal form/ __before__+-- sending it to another process.+--+-- @since 0.22.0+newtype Message = MkMessage Dynamic+ deriving (Typeable, Show)++instance ToTypeLogMsg Message where+ toTypeLogMsg _ = packLogMsg "Message"++instance NFData Message where+ rnf (MkMessage d) = d `seq` ()++instance ToLogMsg Message where+ toLogMsg (MkMessage d) = packLogMsg (show d)++-- | Serialize a @message@ into a 'Message' value to be sent via 'sendAnyMessage'.+--+-- This indirection allows, among other things, the composition of+-- 'Control.Eff.Concurrent.Protocol.Effectful.Server's.+--+-- @since 0.24.1+newtype Serializer message = MkSerializer+ { runSerializer :: message -> Message+ }+ deriving (Typeable)++instance NFData (Serializer message) where+ rnf (MkSerializer !s) = s `seq` ()++instance Contravariant Serializer where+ contramap f (MkSerializer b) = MkSerializer (b . f)++-- | Deeply evaluate the given value and wrap it into a 'Message'.+--+-- @since 0.22.0+toMessage :: (Typeable a, NFData a) => a -> Message+toMessage x = force x `seq` toDyn (force x) `seq` MkMessage (toDyn (force x))++-- | Convert a 'Message' back to a value.+--+-- @since 0.22.0+fromMessage :: Typeable a => Message -> Maybe a+fromMessage (MkMessage d) = fromDynamic d++-- | Convert a 'Message' back to an unwrapped 'Dynamic'.+--+-- @since 0.22.0+unwrapMessage :: Message -> Dynamic+unwrapMessage (MkMessage d) = d++-- | Every 'Process' action returns it's actual result wrapped in this type. It+-- will allow to signal errors as well as pass on normal results such as+-- incoming messages.+data ResumeProcess v+ = -- | The current operation of the process was interrupted with a+ -- 'InterruptReason'. The process may choose to continue or exit.+ Interrupted InterruptReason+ | -- | The process may resume to do work, using the given result.+ ResumeWith v+ deriving (Typeable, Generic, Generic1, Show)++instance NFData a => NFData (ResumeProcess a)++instance NFData1 ResumeProcess++-- | A function that decided if the next message will be received by+-- 'ReceiveSelectedMessage'. It conveniently is an instance of+-- 'Alternative' so the message selector can be combined:+-- >+-- > selectInt :: MessageSelector Int+-- > selectInt = selectMessage+-- >+-- > selectString :: MessageSelector String+-- > selectString = selectMessage+-- >+-- > selectIntOrString :: MessageSelector (Either Int String)+-- > selectIntOrString =+-- > Left <$> selectTimeout<|> Right <$> selectString+newtype MessageSelector a = MessageSelector {runMessageSelector :: Message -> Maybe a}+ deriving (Semigroup, Monoid, Functor)++instance Applicative MessageSelector where+ pure = MessageSelector . pure . pure+ (MessageSelector f) <*> (MessageSelector x) =+ MessageSelector (\dyn -> f dyn <*> x dyn)++instance Alternative MessageSelector where+ empty = MessageSelector (const empty)+ (MessageSelector l) <|> (MessageSelector r) =+ MessageSelector (\dyn -> l dyn <|> r dyn)++-- | Create a message selector for a value that can be obtained by 'fromMessage'.+--+-- @since 0.9.1+selectMessage :: Typeable t => MessageSelector t+selectMessage = selectDynamicMessage fromMessage++-- | Create a message selector from a predicate.+--+-- @since 0.9.1+filterMessage :: Typeable a => (a -> Bool) -> MessageSelector a+filterMessage predicate =+ selectDynamicMessage+ ( \d -> case fromMessage d of+ Just a | predicate a -> Just a+ _ -> Nothing+ )++-- | Select a message of type @a@ and apply the given function to it.+-- If the function returns 'Just' The 'ReceiveSelectedMessage' function will+-- return the result (sans @Maybe@).+--+-- @since 0.9.1+selectMessageWith ::+ Typeable a => (a -> Maybe b) -> MessageSelector b+selectMessageWith f = selectDynamicMessage (fromMessage >=> f)++-- | Create a message selector.+--+-- @since 0.9.1+selectDynamicMessage :: (Message -> Maybe a) -> MessageSelector a+selectDynamicMessage = MessageSelector++-- | Create a message selector that will match every message. This is /lazy/+-- because the result is not 'force'ed.+--+-- @since 0.9.1+selectAnyMessage :: MessageSelector Message+selectAnyMessage = MessageSelector Just++-- | The state that a 'Process' is currently in.+data ProcessState+ = -- | The process has just been started but not+ -- scheduled yet.+ ProcessBooting+ | -- | The process yielded it's time slice+ ProcessIdle+ | -- | The process is busy with a non-blocking operation+ ProcessBusy+ | -- | The process is sleeping until the 'Timeout' given to 'Delay'+ ProcessBusySleeping+ | -- | The process is busy with 'UpdateProcessDetails'+ ProcessBusyUpdatingDetails+ | -- | The process is busy with sending a message+ ProcessBusySending+ | -- | The process is busy with killing+ ProcessBusySendingShutdown+ | -- | The process is busy with killing+ ProcessBusySendingInterrupt+ | -- | The process is blocked by 'receiveAnyMessage'+ ProcessBusyReceiving+ | -- | The process is blocked by 'linkProcess'+ ProcessBusyLinking+ | -- | The process is blocked by 'unlinkProcess'+ ProcessBusyUnlinking+ | -- | The process is blocked by 'monitor'+ ProcessBusyMonitoring+ | -- | The process is blocked by 'demonitor'+ ProcessBusyDemonitoring+ | -- | The process was interrupted+ ProcessInterrupted+ | -- | The process was shutdown or crashed+ ProcessShuttingDown+ deriving (Read, Show, Ord, Eq, Enum, Generic)++instance NFData ProcessState++instance Default ProcessState where+ def = ProcessBooting++instance ToLogMsg ProcessState where+ toLogMsg = \case+ ProcessBooting -> packLogMsg "Booting (the process has just been started but not scheduled yet)"+ ProcessIdle -> packLogMsg "Idle (the process yielded it's time slice)"+ ProcessBusy -> packLogMsg "Busy (the process is busy with a non-blocking operation)"+ ProcessBusySleeping -> packLogMsg "BusySleeping (the process is sleeping until the 'Timeout' given to 'Delay')"+ ProcessBusyUpdatingDetails -> packLogMsg "BusyUpdatingDetails (the process is busy with 'UpdateProcessDetails')"+ ProcessBusySending -> packLogMsg "BusySending (the process is busy with sending a message)"+ ProcessBusySendingShutdown -> packLogMsg "BusySendingShutdown (the process is busy with killing)"+ ProcessBusySendingInterrupt -> packLogMsg "BusySendingInterrupt (the process is busy with killing)"+ ProcessBusyReceiving -> packLogMsg "BusyReceiving (the process is waiting for a message)"+ ProcessBusyLinking -> packLogMsg "BusyLinking (the process is blocked by 'linkProcess')"+ ProcessBusyUnlinking -> packLogMsg "BusyUnlinking (the process is blocked by 'unlinkProcess')"+ ProcessBusyMonitoring -> packLogMsg "BusyMonitoring (the process is blocked by 'monitor')"+ ProcessBusyDemonitoring -> packLogMsg "BusyDemonitoring (the process is blocked by 'demonitor')"+ ProcessInterrupted -> packLogMsg "Interrupted (the process was interrupted)"+ ProcessShuttingDown -> packLogMsg "ShuttingDown (the process is shutting down)"++-- | A sum-type with reasons for why a process operation, such as receiving messages,+-- is interrupted in the scheduling loop.+--+-- This includes errors/exceptions that can be handled by the process.+--+-- @since 1.0.0+data InterruptReason where+ -- | A process has finished a unit of work and might exit or work on+ -- something else. This is primarily used for interrupting infinite+ -- server loops, allowing for additional cleanup work before+ -- exiting (e.g. with 'ExitNormally')+ --+ -- @since 0.13.2+ NormalExitRequested ::+ InterruptReason+ -- | A process that should be running was not running.+ OtherProcessNotRunning ::+ ProcessId ->+ InterruptReason+ -- | A 'Recoverable' timeout has occurred.+ TimeoutInterrupt ::+ LogMsg ->+ InterruptReason+ -- | A linked process is down, see 'Link' for a discussion on linking.+ LinkedProcessCrashed ::+ ProcessId ->+ InterruptReason+ -- | An exit reason that has an error message and is 'Recoverable'.+ ErrorInterrupt ::+ LogMsg ->+ InterruptReason+ -- | An interrupt with a custom message.+ --+ -- @since 0.30.0+ InterruptedBy ::+ Message ->+ InterruptReason+ deriving (Show, Typeable)++-- | A sum-type with reasons for why a process should shutdown.+--+-- This includes errors that force a process to exit.+--+-- @since 1.0.0+data ShutdownReason where+ -- | A process function returned or exited without any error.+ ExitNormally ::+ ShutdownReason+ -- | A process function returned or exited without any error, and with a custom message+ --+ -- @since 0.30.0+ ExitNormallyWith ::+ LogMsg ->+ ShutdownReason+ -- | An error causes the process to exit immediately.+ -- For example an unexpected runtime exception was thrown, i.e. an exception+ -- derived from 'Control.Exception.Safe.SomeException'+ -- Or a 'Recoverable' Interrupt was not recovered.+ ExitUnhandledError ::+ LogMsg ->+ ShutdownReason+ -- | A process shall exit immediately, without any cleanup was cancelled (e.g. killed, in 'Async.cancel')+ ExitProcessCancelled ::+ Maybe ProcessId ->+ ShutdownReason+ -- | A process that is vital to the crashed process was not running+ ExitOtherProcessNotRunning ::+ ProcessId ->+ ShutdownReason+ deriving (Eq, Ord, Show, Typeable)++-- | Return either 'ExitNormally' or 'interruptToExit' from a 'Recoverable' 'Interrupt';+--+-- If the 'Interrupt' is 'NormalExitRequested' then return 'ExitNormally'+interruptToExit :: InterruptReason -> ShutdownReason+interruptToExit NormalExitRequested = ExitNormally+interruptToExit x = ExitUnhandledError (toLogMsg x)++instance ToLogMsg InterruptReason where+ toLogMsg =+ \case+ NormalExitRequested -> packLogMsg "interrupt: A normal exit was requested"+ OtherProcessNotRunning p -> packLogMsg "interrupt: Another process is not running: " <> toLogMsg p+ TimeoutInterrupt reason -> packLogMsg "interrupt: A timeout occured: " <> reason+ LinkedProcessCrashed m -> packLogMsg "interrupt: A linked process " <> toLogMsg m <> packLogMsg " crashed"+ InterruptedBy reason -> packLogMsg "interrupt: " <> toLogMsg reason+ ErrorInterrupt reason -> packLogMsg "interrupt: An error occured: " <> reason++instance ToLogMsg ShutdownReason where+ toLogMsg =+ \case+ ExitNormally -> packLogMsg "exit: Process finished successfully"+ ExitNormallyWith reason -> packLogMsg "exit: Process finished successfully: " <> toLogMsg reason+ ExitUnhandledError w -> packLogMsg "exit: Unhandled " <> toLogMsg w+ ExitProcessCancelled Nothing -> packLogMsg "exit: The process was cancelled by a runtime exception"+ ExitProcessCancelled (Just origin) -> packLogMsg "exit: The process was cancelled by: " <> toLogMsg origin+ ExitOtherProcessNotRunning p -> packLogMsg "exit: Another process is not running: " <> toLogMsg p++instance NFData InterruptReason where+ rnf NormalExitRequested = rnf ()+ rnf (OtherProcessNotRunning !l) = rnf l+ rnf (TimeoutInterrupt !l) = rnf l+ rnf (LinkedProcessCrashed !l) = rnf l+ rnf (ErrorInterrupt !l) = rnf l+ rnf (InterruptedBy !l) = rnf l++instance NFData ShutdownReason where+ rnf ExitNormally = rnf ()+ rnf (ExitNormallyWith !l) = rnf l+ rnf (ExitUnhandledError !l) = rnf l+ rnf (ExitProcessCancelled !o) = rnf o+ rnf (ExitOtherProcessNotRunning !l) = rnf l++-- | Classify the 'ExitSeverity' of interrupt or shutdown reasons.+--+-- @since 1.0.0+class IsExitReason a where+ -- | Convert a value to the corresponding 'ExitSeverity'+ toExitSeverity :: a -> ExitSeverity++ -- | Return 'True' of the given reason @a@ indicates a 'Crash'+ isCrash :: a -> Bool+ isCrash x =+ toExitSeverity x == Crash++-- | This value indicates whether a process exited in way consistent with+-- the planned behaviour or not.+data ExitSeverity = ExitSuccess | Crash+ deriving (Typeable, Ord, Eq, Generic, Show)++instance ToLogMsg ExitSeverity where+ toLogMsg =+ \case+ ExitSuccess -> packLogMsg "exit-success"+ Crash -> packLogMsg "crash"++instance NFData ExitSeverity++instance IsExitReason InterruptReason where+ toExitSeverity = \case+ NormalExitRequested -> ExitSuccess+ _ -> Crash++instance IsExitReason ShutdownReason where+ toExitSeverity = \case+ ExitNormally -> ExitSuccess+ ExitNormallyWith _ -> ExitSuccess+ _ -> Crash++-- | Print an 'Interrupt' to 'Just' a formatted 'String' when 'isCrash'+-- is 'True'.+-- This can be useful in combination with view patterns, e.g.:+--+-- > logCrash :: InterruptReason -> Eff e ()+-- > logCrash (toCrashReason -> Just reason) = logError reason+-- > logCrash _ = return ()+--+-- Though this can be improved to:+--+-- > logCrash = traverse_ logError . toCrashReason+toCrashReason :: (ToLogMsg a, IsExitReason a) => a -> Maybe LogMsg+toCrashReason e+ | isCrash e = Just (toLogMsg e)+ | otherwise = Nothing++-- | Log the 'Interrupt's+logProcessExit ::+ forall e x. (Member Logs e, ToLogMsg x, IsExitReason x) => x -> Eff e ()+logProcessExit (toCrashReason -> Just ex) = withFrozenCallStack (logWarning ex)+logProcessExit ex = withFrozenCallStack (logDebug ex)++-- | An existential wrapper around 'Interrupt'+newtype InterruptOrShutdown = InterruptOrShutdown {fromInterruptOrShutdown :: Either ShutdownReason InterruptReason}+ deriving (Show, ToLogMsg, NFData)++-- | A predicate for linked process __crashes__.+isLinkedProcessCrashed :: Maybe ProcessId -> InterruptReason -> Bool+isLinkedProcessCrashed mOtherProcess =+ \case+ NormalExitRequested -> False+ OtherProcessNotRunning _ -> False+ TimeoutInterrupt _ -> False+ LinkedProcessCrashed p -> maybe True (== p) mOtherProcess+ InterruptedBy _ -> False+ ErrorInterrupt _ -> False++-- | A newtype wrapper for 'InterruptReason' to by used for 'Exc.Exception'.+--+-- @since 1.0.0+newtype UnhandledProcessInterrupt = MkUnhandledProcessInterrupt InterruptReason+ deriving (NFData, Typeable, Show)++instance Exc.Exception UnhandledProcessInterrupt++-- | A newtype wrapper for 'ShutdownReason' to by used for 'Exc.Exception'.+--+-- @since 1.0.0+newtype UnhandledProcessExit = MkUnhandledProcessExit ShutdownReason+ deriving (Show, Eq)++instance Exc.Exception UnhandledProcessExit++-- | This adds a layer of the 'Interrupts' effect on top of 'Processes'+type Processes e = Interrupts ': SafeProcesses e++-- | A constraint for an effect set that requires the presence of 'Processes'.+--+-- This constrains the effect list to look like this:+-- @[e1 ... eN, 'Interrupts', 'Process' [e(N+1) .. e(N+k)], e(N+1) .. e(N+k)]@+--+-- It constrains @e@ beyond 'HasSafeProcesses' to encompass 'Interrupts'.+--+-- @since 0.27.1+type HasProcesses e inner = (HasSafeProcesses e inner, Member Interrupts e)++-- | /Cons/ 'Process' onto a list of effects. This is called @SafeProcesses@ because+-- the actions cannot be interrupted through an exception mechanism,+-- and the 'ResumeProcess' value has to be inspected.+type SafeProcesses r = Process r ': r++-- | A constraint for an effect set that requires the presence of 'SafeProcesses'.+--+-- This constrains the effect list to look like this:+-- @[e1 ... eN, 'Process' [e(N+1) .. e(N+k)], e(N+1) .. e(N+k)]@+--+-- It constrains @e@ to support the (only) 'Process' effect.+--+-- This is more relaxed that 'HasProcesses' since it does not require 'Interrupts'.+--+-- @since 0.27.1+type HasSafeProcesses e inner = (SetMember Process (Process inner) e)++-- | 'Exc'eptions containing 'Interrupt's.+-- See 'handleInterrupts', 'exitOnInterrupt' or 'provideInterrupts'+type Interrupts = Exc InterruptReason++-- | Handle all 'Interrupt's of an 'Processes' by+-- wrapping them up in 'interruptToExit' and then do a process 'Shutdown'.+provideInterruptsShutdown ::+ forall e a. Eff (Processes e) a -> Eff (SafeProcesses e) a+provideInterruptsShutdown e = do+ res <- provideInterrupts e+ case res of+ Left ex -> send (Shutdown @e (interruptToExit ex))+ Right a -> return a++-- | Handle 'Interrupt's arising during process operations, e.g.+-- when a linked process crashes while we wait in a 'receiveSelectedMessage'+-- via a call to 'interrupt'.+handleInterrupts ::+ (Member Interrupts r) =>+ (InterruptReason -> Eff r a) ->+ Eff r a ->+ Eff r a+handleInterrupts = flip catchError++-- | Like 'handleInterrupts', but instead of passing the 'Interrupt'+-- to a handler function, 'Either' is returned.+--+-- @since 0.13.2+tryUninterrupted ::+ (Member Interrupts r) =>+ Eff r a ->+ Eff r (Either InterruptReason a)+tryUninterrupted = handleInterrupts (pure . Left) . fmap Right++-- | Handle interrupts by logging them with `logProcessExit` and otherwise+-- ignoring them.+logInterrupts ::+ forall r.+ (Member Logs r, Member Interrupts r) =>+ Eff r () ->+ Eff r ()+logInterrupts = handleInterrupts logProcessExit++-- | Handle 'Interrupt's arising during process operations, e.g.+-- when a linked process crashes while we wait in a 'receiveSelectedMessage'+-- via a call to 'interrupt'.+exitOnInterrupt ::+ HasProcesses r q =>+ Eff r a ->+ Eff r a+exitOnInterrupt = handleInterrupts (exitBecause . interruptToExit)++-- | Handle 'Interrupt's arising during process operations, e.g.+-- when a linked process crashes while we wait in a 'receiveSelectedMessage'+-- via a call to 'interrupt'.+provideInterrupts :: Eff (Interrupts ': r) a -> Eff r (Either InterruptReason a)+provideInterrupts = runError++-- | Wrap all (left) 'Interrupt's into 'interruptToExit' and+-- return the (right) 'NoRecovery' 'Interrupt's as is.+mergeEitherInterruptAndExitReason ::+ Either InterruptReason ShutdownReason -> ShutdownReason+mergeEitherInterruptAndExitReason = either interruptToExit id++-- | Throw an 'Interrupt', can be handled by 'handleInterrupts' or+-- 'exitOnInterrupt' or 'provideInterrupts'.+interrupt :: Member Interrupts r => InterruptReason -> Eff r a+interrupt = throwError++-- | Execute a and action and return the result;+-- if the process is interrupted by an error or exception, or an explicit+-- shutdown from another process, or through a crash of a linked process, i.e.+-- whenever the exit reason satisfies 'isRecoverable', return the exit reason.+executeAndResume ::+ forall q r v.+ HasSafeProcesses r q =>+ Process q (ResumeProcess v) ->+ Eff r (Either InterruptReason v)+executeAndResume processAction = do+ result <- send processAction+ case result of+ ResumeWith !value -> return (Right value)+ Interrupted r -> return (Left r)++-- | Execute a 'Process' action and resume the process, exit+-- the process when an 'Interrupts' was raised. Use 'executeAndResume' to catch+-- interrupts.+executeAndResumeOrExit ::+ forall r q v.+ HasSafeProcesses r q =>+ Process q (ResumeProcess v) ->+ Eff r v+executeAndResumeOrExit processAction = do+ result <- send processAction+ case result of+ ResumeWith !value -> return value+ Interrupted r -> send (Shutdown @q (interruptToExit r))++-- | Execute a 'Process' action and resume the process, exit+-- the process when an 'Interrupts' was raised. Use 'executeAndResume' to catch+-- interrupts.+executeAndResumeOrThrow ::+ forall q r v.+ HasProcesses r q =>+ Process q (ResumeProcess v) ->+ Eff r v+executeAndResumeOrThrow processAction = do+ result <- send processAction+ case result of+ ResumeWith !value -> return value+ Interrupted r -> interrupt r++-- * Process Effects++-- | Use 'executeAndResumeOrExit' to execute 'YieldProcess'. Refer to 'YieldProcess'+-- for more information.+yieldProcess :: forall r q. HasProcesses r q => Eff r ()+yieldProcess = executeAndResumeOrThrow YieldProcess++-- | Simply block until the time in the 'Timeout' has passed.+--+-- @since 0.30.0+delay :: forall r q. HasProcesses r q => Timeout -> Eff r ()+delay = executeAndResumeOrThrow . Delay++-- | Send a message to a process addressed by the 'ProcessId'.+-- See 'SendMessage'.+--+-- The message will be reduced to normal form ('rnf') by/in the caller process.+sendMessage ::+ forall o r q.+ ( HasProcesses r q,+ Typeable o,+ NFData o+ ) =>+ ProcessId ->+ o ->+ Eff r ()+sendMessage pid message =+ rnf pid `seq` toMessage message+ `seq` executeAndResumeOrThrow (SendMessage pid (toMessage message))++-- | Send a 'Dynamic' value to a process addressed by the 'ProcessId'.+-- See 'SendMessage'.+sendAnyMessage ::+ forall r q.+ HasProcesses r q =>+ ProcessId ->+ Message ->+ Eff r ()+sendAnyMessage pid message =+ executeAndResumeOrThrow (SendMessage pid message)++-- | Exit a process addressed by the 'ProcessId'. The process will exit,+-- it might do some cleanup, but is ultimately unrecoverable.+-- See 'SendShutdown'.+sendShutdown ::+ forall r q.+ HasProcesses r q =>+ ProcessId ->+ ShutdownReason ->+ Eff r ()+sendShutdown pid s =+ pid `deepseq` s `deepseq` executeAndResumeOrThrow (SendShutdown pid s)++-- | Interrupts a process addressed by the 'ProcessId'. The process might exit,+-- or it may continue.+-- | Like 'sendInterrupt', but also return @True@ iff the process to exit exists.+sendInterrupt ::+ forall r q.+ HasProcesses r q =>+ ProcessId ->+ InterruptReason ->+ Eff r ()+sendInterrupt pid s =+ pid `deepseq` s `deepseq` executeAndResumeOrThrow (SendInterrupt pid s)++-- | Start a new process, the new process will execute an effect, the function+-- will return immediately with a 'ProcessId'. If the new process is+-- interrupted, the process will 'Shutdown' with the 'Interrupt'+-- wrapped in 'interruptToExit'. For specific use cases it might be better to use+-- 'spawnRaw'.+spawn ::+ forall r q.+ HasProcesses r q =>+ ProcessTitle ->+ Eff (Processes q) () ->+ Eff r ProcessId+spawn t child =+ executeAndResumeOrThrow (Spawn @q t (provideInterruptsShutdown child))++-- | Like 'spawn' but return @()@.+spawn_ ::+ forall r q.+ HasProcesses r q =>+ ProcessTitle ->+ Eff (Processes q) () ->+ Eff r ()+spawn_ t child = void (spawn t child)++-- | Start a new process, and immediately link to it.+--+-- See 'Link' for a discussion on linking.+--+-- @since 0.12.0+spawnLink ::+ forall r q.+ HasProcesses r q =>+ ProcessTitle ->+ Eff (Processes q) () ->+ Eff r ProcessId+spawnLink t child =+ executeAndResumeOrThrow (SpawnLink @q t (provideInterruptsShutdown child))++-- | Start a new process, the new process will execute an effect, the function+-- will return immediately with a 'ProcessId'. The spawned process has only the+-- /raw/ 'SafeProcesses' effects. For non-library code 'spawn' might be better+-- suited.+spawnRaw ::+ forall r q.+ HasProcesses r q =>+ ProcessTitle ->+ Eff (SafeProcesses q) () ->+ Eff r ProcessId+spawnRaw t child = executeAndResumeOrThrow (Spawn @q t child)++-- | Like 'spawnRaw' but return @()@.+spawnRaw_ ::+ forall r q.+ HasProcesses r q =>+ ProcessTitle ->+ Eff (SafeProcesses q) () ->+ Eff r ()+spawnRaw_ t = void . spawnRaw t++-- | Return 'True' if the process is alive.+--+-- @since 0.12.0+isProcessAlive ::+ forall r q.+ HasProcesses r q =>+ ProcessId ->+ Eff r Bool+isProcessAlive pid = isJust <$> executeAndResumeOrThrow (GetProcessState pid)++-- | Return the 'ProcessTitle', 'ProcessDetails' and 'ProcessState',+-- for the given process, if the process is alive.+--+-- @since 0.24.1+getProcessState ::+ forall r q.+ HasProcesses r q =>+ ProcessId ->+ Eff r (Maybe (ProcessTitle, ProcessDetails, ProcessState))+getProcessState pid = executeAndResumeOrThrow (GetProcessState pid)++-- | Replace the 'ProcessDetails' of the process.+--+-- @since 0.24.1+updateProcessDetails ::+ forall r q.+ HasProcesses r q =>+ ProcessDetails ->+ Eff r ()+updateProcessDetails pd = executeAndResumeOrThrow (UpdateProcessDetails pd)++-- | Block until a message was received.+-- See 'ReceiveSelectedMessage' for more documentation.+receiveAnyMessage ::+ forall r q.+ HasProcesses r q =>+ Eff r Message+receiveAnyMessage =+ executeAndResumeOrThrow (ReceiveSelectedMessage selectAnyMessage)++-- | Block until a message was received, that is not 'Nothing' after applying+-- a callback to it.+-- See 'ReceiveSelectedMessage' for more documentation.+receiveSelectedMessage ::+ forall r q a.+ HasProcesses r q =>+ MessageSelector a ->+ Eff r a+receiveSelectedMessage f = executeAndResumeOrThrow (ReceiveSelectedMessage f)++-- | Receive and cast the message to some 'Typeable' instance.+-- See 'ReceiveSelectedMessage' for more documentation.+-- This will wait for a message of the return type using 'receiveSelectedMessage'+receiveMessage ::+ forall a r q.+ ( Typeable a,+ HasProcesses r q+ ) =>+ Eff r a+receiveMessage = receiveSelectedMessage (MessageSelector fromMessage)++-- | Remove and return all messages currently enqueued in the process message+-- queue.+--+-- @since 0.12.0+flushMessages ::+ forall r q.+ HasProcesses r q =>+ Eff r [Message]+flushMessages = executeAndResumeOrThrow @q FlushMessages++-- | Enter a loop to receive messages and pass them to a callback, until the+-- function returns 'Just' a result.+-- Only the messages of the given type will be received.+-- If the process is interrupted by an exception or by a 'SendInterrupt' from+-- another process, then the callback will be invoked with @'Left' 'Interrupt'@,+-- otherwise the process will be exited+--+-- See also 'ReceiveSelectedMessage' for more documentation.+receiveSelectedLoop ::+ forall r q a endOfLoopResult.+ HasSafeProcesses r q =>+ MessageSelector a ->+ (Either InterruptReason a -> Eff r (Maybe endOfLoopResult)) ->+ Eff r endOfLoopResult+receiveSelectedLoop selector handlers = do+ mReq <- send (ReceiveSelectedMessage @q @a selector)+ mRes <- case mReq of+ Interrupted reason -> handlers (Left reason)+ ResumeWith message -> handlers (Right message)+ maybe (receiveSelectedLoop selector handlers) return mRes++-- | Like 'receiveSelectedLoop' but /not selective/.+-- See also 'selectAnyMessage', 'receiveSelectedLoop'.+receiveAnyLoop ::+ forall r q endOfLoopResult.+ HasSafeProcesses r q =>+ (Either InterruptReason Message -> Eff r (Maybe endOfLoopResult)) ->+ Eff r endOfLoopResult+receiveAnyLoop = receiveSelectedLoop selectAnyMessage++-- | Like 'receiveSelectedLoop' but refined to casting to a specific 'Typeable'+-- using 'selectMessage'.+receiveLoop ::+ forall r q a endOfLoopResult.+ (HasSafeProcesses r q, Typeable a) =>+ (Either InterruptReason a -> Eff r (Maybe endOfLoopResult)) ->+ Eff r endOfLoopResult+receiveLoop = receiveSelectedLoop selectMessage++-- | Returns the 'ProcessId' of the current process.+self :: HasSafeProcesses r q => Eff r ProcessId+self = executeAndResumeOrExit SelfPid++-- | Generate a unique 'Int' for the current process.+makeReference ::+ HasProcesses r q =>+ Eff r Int+makeReference = executeAndResumeOrThrow MakeReference++-- | A value that contains a unique reference of a process+-- monitoring.+--+-- @since 0.12.0+data MonitorReference = MkMonitorReference+ { _monitorIndex :: !Int,+ _monitoredProcess :: !ProcessId+ }+ deriving (Read, Eq, Ord, Generic, Typeable, Show)++instance ToLogMsg MonitorReference where+ toLogMsg (MkMonitorReference ref pid) =+ toLogMsg pid <> packLogMsg "_" <> packLogMsg "monitor_" <> toLogMsg (show ref)++instance NFData MonitorReference++-- | Monitor another process. When the monitored process exits a+-- 'ProcessDown' is sent to the calling process.+-- The return value is a unique identifier for that monitor.+-- There can be multiple monitors on the same process,+-- and a message for each will be sent.+-- If the process is already dead, the 'ProcessDown' message+-- will be sent immediately, without exit reason+--+-- @since 0.12.0+monitor ::+ forall r q.+ HasProcesses r q =>+ ProcessId ->+ Eff r MonitorReference+monitor = executeAndResumeOrThrow . Monitor . force++-- | Remove a monitor created with 'monitor'.+--+-- @since 0.12.0+demonitor ::+ forall r q.+ HasProcesses r q =>+ MonitorReference ->+ Eff r ()+demonitor = executeAndResumeOrThrow . Demonitor . force++-- | 'monitor' another process before while performing an action+-- and 'demonitor' afterwards.+--+-- @since 0.12.0+withMonitor ::+ HasProcesses r q =>+ ProcessId ->+ (MonitorReference -> Eff r a) ->+ Eff r a+withMonitor pid e = monitor pid >>= \ref -> e ref <* demonitor ref++-- | A 'MessageSelector' for receiving either a monitor of the+-- given process or another message.+--+-- @since 0.12.0+receiveWithMonitor ::+ HasProcesses r q =>+ ProcessId ->+ MessageSelector a ->+ Eff r (Either ProcessDown a)+receiveWithMonitor pid sel =+ withMonitor+ pid+ ( \ref ->+ receiveSelectedMessage (Left <$> selectProcessDown ref <|> Right <$> sel)+ )++-- | A monitored process exited.+-- This message is sent to a process by the scheduler, when+-- a process that was monitored died.+--+-- @since 0.12.0+data ProcessDown = ProcessDown+ { downReference :: !MonitorReference,+ downReason :: !ShutdownReason,+ downProcess :: !ProcessId+ }+ deriving (Typeable, Generic, Eq, Ord, Show)++instance ToTypeLogMsg ProcessDown where+ toTypeLogMsg _ = "ProcessDown"++instance ToLogMsg ProcessDown where+ toLogMsg (ProcessDown ref reason pid) =+ toLogMsg ref <> packLogMsg " " <> toLogMsg reason <> packLogMsg " " <> toLogMsg pid++-- | Make an 'Interrupt' for a 'ProcessDown' message.+--+-- For example: @doSomething >>= either (interrupt . becauseOtherProcessNotRunning) return@+--+-- @since 1.0.0+becauseOtherProcessNotRunning :: ProcessDown -> InterruptReason+becauseOtherProcessNotRunning = OtherProcessNotRunning . _monitoredProcess . downReference++instance NFData ProcessDown++-- | A 'MessageSelector' for the 'ProcessDown' message of a specific+-- process.+--+-- The parameter is the value obtained by 'monitor'.+--+-- @since 0.12.0+selectProcessDown :: MonitorReference -> MessageSelector ProcessDown+selectProcessDown ref0 =+ filterMessage (\(ProcessDown ref _reason _pid) -> ref0 == ref)++-- | A 'MessageSelector' for the 'ProcessDown' message. of a specific+-- process.+--+-- In contrast to 'selectProcessDown' this function matches the 'ProcessId'.+--+-- @since 0.28.0+selectProcessDownByProcessId :: ProcessId -> MessageSelector ProcessDown+selectProcessDownByProcessId pid0 =+ filterMessage (\(ProcessDown _ref _reason pid) -> pid0 == pid)++-- | Connect the calling process to another process, such that+-- if one of the processes crashes (i.e. 'isCrash' returns 'True'), the other+-- is shutdown with the 'Interrupt' 'LinkedProcessCrashed'.+--+-- See 'Link' for a discussion on linking.+--+-- @since 0.12.0+linkProcess ::+ forall r q.+ HasProcesses r q =>+ ProcessId ->+ Eff r ()+linkProcess = executeAndResumeOrThrow . Link . force++-- | Unlink the calling process from the other process.+--+-- See 'Link' for a discussion on linking.+--+-- @since 0.12.0+unlinkProcess ::+ forall r q.+ HasProcesses r q =>+ ProcessId ->+ Eff r ()+unlinkProcess = executeAndResumeOrThrow . Unlink . force++-- | Exit the process with a 'Interrupt'.+exitBecause ::+ forall r q a.+ HasSafeProcesses r q =>+ ShutdownReason ->+ Eff r a+exitBecause = send . Shutdown @q . force++-- | Exit the process.+exitNormally ::+ forall r q a. HasSafeProcesses r q => Eff r a+exitNormally = exitBecause ExitNormally++-- | Exit the process with an error.+exitWithError ::+ forall r q a.+ HasSafeProcesses r q =>+ String ->+ Eff r a+exitWithError = exitBecause . interruptToExit . ErrorInterrupt . fromString++-- | Each process is identified by a single process id, that stays constant+-- throughout the life cycle of a process. Also, message sending relies on these+-- values to address messages to processes.+newtype ProcessId = ProcessId {_fromProcessId :: Int}+ deriving (Eq, Ord, Typeable, Bounded, Num, Enum, Integral, Real, NFData)++instance ToLogMsg ProcessId where+ toLogMsg (ProcessId !p) = packLogMsg ('!' : show p)++instance Read ProcessId where+ readsPrec _ ('!' : rest1) = case reads rest1 of+ [(c, rest2)] -> [(ProcessId c, rest2)]+ _ -> []+ readsPrec _ _ = []++instance Show ProcessId where+ showsPrec _ (ProcessId !c) = showChar '!' . shows c++makeLenses ''ProcessId++makeLenses ''MonitorReference
src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs view
@@ -9,825 +9,870 @@ -- At the core is a /main process/ that enters 'schedule' -- and creates all of the internal state stored in 'STM.TVar's -- to manage processes with message queues.----module Control.Eff.Concurrent.Process.ForkIOScheduler- ( schedule- , defaultMain- , defaultMainWithLogWriter- , SafeEffects- , Effects- , BaseEffects- , HasBaseEffects- )-where--import Control.Concurrent ( yield, threadDelay, forkIO, killThread )-import qualified Control.Concurrent.Async as Async-import Control.Concurrent.Async ( Async(..) )-import Control.Concurrent.STM as STM-import Control.Eff-import Control.Eff.Concurrent.Process-import qualified Control.Eff.ExceptionExtra as ExcExtra- ( )-import Control.Eff.Extend-import Control.Eff.Log-import Control.Eff.LogWriter.Console-import Control.Eff.LogWriter.Async-import Control.Eff.Reader.Strict as Reader-import Control.Exception.Safe as Safe-import Control.Lens-import Control.Monad ( void- , when, unless- )-import Control.Monad.Trans.Control ( MonadBaseControl(..)- , control- )-import Data.Default-import Data.Foldable-import Data.Function ( fix )-import Data.Kind ( )-import Data.Map ( Map )-import qualified Data.Map as Map-import Data.Maybe-import Data.Sequence ( Seq(..) )-import qualified Data.Sequence as Seq-import Data.Set ( Set )-import qualified Data.Set as Set-import qualified Data.Text as T-import GHC.Stack-import System.Timeout---- * Process Types---- | A message queue of a process, contains the actual queue and maybe an--- exit reason. The message queue is backed by a 'Seq' sequence with 'StrictDynamic' values.-data MessageQ = MessageQ- { _incomingMessages :: Seq StrictDynamic- , _shutdownRequests :: Maybe SomeExitReason- }--instance Default MessageQ where- def = MessageQ def def--makeLenses ''MessageQ---- | Return any '_shutdownRequests' from a 'MessageQ' in a 'TVar' and--- reset the '_shutdownRequests' field to 'Nothing' in the 'TVar'.-tryTakeNextShutdownRequestSTM :: TVar MessageQ -> STM (Maybe SomeExitReason)-tryTakeNextShutdownRequestSTM mqVar = do- mq <- readTVar mqVar- when (isJust (mq ^. shutdownRequests))- (writeTVar mqVar (mq & shutdownRequests .~ Nothing))- return (mq ^. shutdownRequests)---- | Information about a process, needed to implement--- 'Process' handlers. The message queue is backed by a 'STM.TVar' that contains--- a 'MessageQ'.-data ProcessInfo = ProcessInfo- { _processId :: ProcessId- , _processTitle :: ProcessTitle- , _processState :: TVar (ProcessDetails, ProcessState)- , _messageQ :: TVar MessageQ- , _processLinks :: TVar (Set ProcessId)- }--makeLenses ''ProcessInfo---- * Scheduler Types---- | Contains all process info'elements, as well as the state needed to implement--- inter-process communication.-data SchedulerState = SchedulerState- { _nextPid :: TVar ProcessId- , _processTable :: TVar (Map ProcessId ProcessInfo)- , _processCancellationTable :: TVar (Map ProcessId (Async (Interrupt 'NoRecovery)))- , _processMonitors :: TVar (Set (MonitorReference, ProcessId)) -- ^ Set of monitors and monitor owners- , _nextMonitorIndex :: TVar Int- }--makeLenses ''SchedulerState--renderSchedulerState :: SchedulerState -> IO ProcessDetails-renderSchedulerState s = do- (np, pt, pct, pm, nm) <- atomically $ do- np <- T.pack . show <$> readTVar (s ^. nextPid)- pt <- T.pack . show . Map.size <$> readTVar (s ^. processTable)- pct <- T.pack . show . Map.size <$> readTVar (s ^. processCancellationTable)- pm <- T.pack . show . Set.size <$> readTVar (s ^. processMonitors)- nm <- T.pack . show <$> readTVar (s ^. nextMonitorIndex)- return (np, pt, pct, pm, nm)- return- $ MkProcessDetails- $ T.unlines- [ "ForkIO Scheduler nextPid: " <> np- , "ForkIO Scheduler process table entries: " <> pt- , "ForkIO Scheduler process cancellation table entries: " <> pct- , "ForkIO Scheduler process monitors entries: " <> pm- , "ForkIO Scheduler nextMonitorIndex: " <> nm- ]---- | Allocate a new 'MonitorReference'-nextMonitorReference :: ProcessId -> SchedulerState -> STM MonitorReference-nextMonitorReference target schedulerState = do- aNewMonitorIndex <- readTVar (schedulerState ^. nextMonitorIndex)- modifyTVar' (schedulerState ^. nextMonitorIndex) (+ 1)- return (MonitorReference aNewMonitorIndex target)---- | Add monitor: If the process is dead, enqueue a 'ProcessDown' message into the--- owners message queue-addMonitoring- :: HasCallStack => MonitorReference -> ProcessId -> SchedulerState -> STM Int-addMonitoring monitorRef@(MonitorReference _ target) owner schedulerState =- if target == owner then pure 0- else- do- pt <- readTVar (schedulerState ^. processTable)- case Map.lookup target pt of- Just targetProcessInfo ->- do (_, targetState) <- readTVar (targetProcessInfo ^. processState)- check ( targetState == ProcessShuttingDown- || targetState == ProcessBusyReceiving- || targetState == ProcessIdle)- if targetState /= ProcessShuttingDown then- insertMonitoringReference >> pure 1- else- processAlreadyDead >> pure 2- Nothing ->- processAlreadyDead >> pure 3-- where- insertMonitoringReference =- modifyTVar' (schedulerState ^. processMonitors)- (Set.insert (monitorRef, owner))-- processAlreadyDead = do- let processDownMessage =- ProcessDown monitorRef (ExitOtherProcessNotRunning target) target- wasEnqueued <- enqueueMessageOtherProcess owner- (toStrictDynamic processDownMessage)- schedulerState- check wasEnqueued--triggerAndRemoveMonitor- :: ProcessId -> Interrupt 'NoRecovery -> SchedulerState -> STM [ProcessId]-triggerAndRemoveMonitor downPid reason schedulerState = do- -- remove the monitor entries that the downPid process owned:- modifyTVar' (schedulerState ^. processMonitors)- (Set.filter (\(_, downPid') -> downPid' /= downPid))- -- now send the process down message and remove the entries that monitor- -- the downPid process:- monRefs <- readTVar (schedulerState ^. processMonitors)- catMaybes <$> traverse go (toList monRefs)- where- go (mr, owner) =- if monitoredProcess mr == downPid- then do- let processDownMessage = ProcessDown mr reason downPid- wasEnqueued <-- enqueueMessageOtherProcess- owner- (toStrictDynamic processDownMessage)- schedulerState- removeMonitoring mr schedulerState- pure $ if wasEnqueued then Nothing else Just owner- else- pure Nothing--removeMonitoring :: MonitorReference -> SchedulerState -> STM ()-removeMonitoring monitorRef schedulerState = modifyTVar'- (schedulerState ^. processMonitors)- (Set.filter (\(ref, _) -> ref /= monitorRef))----- * Process Implementation-instance Show ProcessInfo where- show p = "process info: " ++ show (p ^. processId)---- | Create a new 'ProcessInfo'-newProcessInfo :: HasCallStack => ProcessId -> ProcessTitle -> STM ProcessInfo-newProcessInfo a t =- ProcessInfo a t <$> newTVar (mempty, ProcessBooting) <*> newTVar def <*> newTVar def---- * Scheduler Implementation---- | Create a new 'SchedulerState'-newSchedulerState :: HasCallStack => STM SchedulerState-newSchedulerState =- SchedulerState- <$> newTVar 1- <*> newTVar def- <*> newTVar def- <*> newTVar def- <*> newTVar def---- | Create a new 'SchedulerState' run an IO action, catching all exceptions,--- and when the actions returns, clean up and kill all processes.-withNewSchedulerState :: HasCallStack => Eff BaseEffects () -> Eff LoggingAndIo ()-withNewSchedulerState mainProcessAction = Safe.bracketWithError- (lift (atomically newSchedulerState))- (\exceptions schedulerState -> do- traverse_- ( logError- . ("scheduler setup crashed with: " <>)- . T.pack- . Safe.displayException- )- exceptions- logDebug "scheduler cleanup begin"- runReader schedulerState tearDownScheduler- )- (\schedulerState -> do- logDebug "scheduler loop entered"- x <- runReader schedulerState mainProcessAction- logDebug "scheduler loop returned"- return x- )- where- tearDownScheduler :: Eff BaseEffects ()- tearDownScheduler = do- schedulerState <- getSchedulerState- let cancelTableVar = schedulerState ^. processCancellationTable- -- cancel all processes- allProcesses <- lift- (atomically (readTVar cancelTableVar <* writeTVar cancelTableVar def))- logNotice- ( "cancelling processes: "- <> T.pack (show (toListOf (ifolded . asIndex) allProcesses))- )- void- (liftBaseWith- (\runS -> timeout- 5_000_000- ( Async.mapConcurrently- (\a -> do- Async.cancel a- runS- (logNotice- ("process cancelled: " <> T.pack (show (asyncThreadId a)))- )- )- allProcesses- >> runS (logNotice "all processes cancelled")- )- )- )---- | The concrete list of 'Eff'ects of processes compatible with this scheduler.--- This builds upon 'BaseEffects'.------ @since 0.25.0-type SafeEffects = SafeProcesses BaseEffects---- | The 'Eff'ects for interruptable, concurrent processes, scheduled via 'forkIO'.------ @since 0.25.0-type Effects = Processes BaseEffects---- | Type class constraint to indicate that an effect union contains the--- effects required by every process and the scheduler implementation itself.------ @since 0.25.0-type HasBaseEffects r = (HasCallStack, Lifted IO r, BaseEffects <:: r)---- | The concrete list of 'Eff'ects for this scheduler implementation.------ @since 0.25.0-type BaseEffects = Reader SchedulerState : LoggingAndIo---- | Start the message passing concurrency system then execute a 'Process' on--- top of 'BaseEffects' effect. All logging is sent to standard output.-defaultMain :: HasCallStack => Eff Effects () -> IO ()-defaultMain e = do- lw <- consoleLogWriter- defaultMainWithLogWriter lw e---- | Start the message passing concurrency system then execute a 'Process' on--- top of 'BaseEffects' effect. All logging is sent to standard output.-defaultMainWithLogWriter- :: HasCallStack => LogWriter -> Eff Effects () -> IO ()-defaultMainWithLogWriter lw =- runLift . withLogging lw . withAsyncLogWriter (1024 :: Int) . schedule---- ** Process Execution--handleProcess- :: (HasCallStack)- => ProcessInfo- -> Eff SafeEffects (Interrupt 'NoRecovery)- -> Eff BaseEffects (Interrupt 'NoRecovery)-handleProcess myProcessInfo actionToRun = fix- (handle_relay' singleStep (\er _nextRef -> setMyProcessState ProcessShuttingDown >> return er))- actionToRun- 0- where- singleStep- :: (Eff SafeEffects xx -> (Int -> Eff BaseEffects (Interrupt 'NoRecovery)))- -> Arrs SafeEffects x xx- -> Process BaseEffects x- -> (Int -> Eff BaseEffects (Interrupt 'NoRecovery))- singleStep k q p !nextRef = stepProcessInterpreter- nextRef- p- (\nextNextRef x -> k (qApp q x) nextNextRef)- return- myPid = myProcessInfo ^. processId- myProcessStateVar = myProcessInfo ^. processState- setMyProcessState = lift . atomically . setMyProcessStateSTM--- DEBUG variant:--- setMyProcessState st = do--- oldSt <- lift (atomically (readTVar myProcessStateVar <* setMyProcessStateSTM st))--- logDebug ("state change: "<> show oldSt <> " -> " <> show st)- setMyProcessStateSTM = modifyTVar myProcessStateVar . set _2- setMyProcessDetailsSTM = modifyTVar myProcessStateVar . set _1- myMessageQVar = myProcessInfo ^. messageQ- kontinueWith- :: forall s v a- . HasCallStack- => (s -> Arr BaseEffects v a)- -> (s -> Arr BaseEffects v a)- kontinueWith kontinue !nextRef !result = do- setMyProcessState ProcessIdle- lift yield- kontinue nextRef result- diskontinueWith- :: forall a- . HasCallStack- => Arr BaseEffects (Interrupt 'NoRecovery) a- -> Arr BaseEffects (Interrupt 'NoRecovery) a- diskontinueWith diskontinue !reason = do- setMyProcessState ProcessShuttingDown- diskontinue reason- stepProcessInterpreter- :: forall v a- . HasCallStack- => Int- -> Process BaseEffects v- -> (Int -> Arr BaseEffects v a)- -> Arr BaseEffects (Interrupt 'NoRecovery) a- -> Eff BaseEffects a- stepProcessInterpreter !nextRef !request kontinue diskontinue =- tryTakeNextShutdownRequest >>= maybe- noShutdownRequested- (either onShutdownRequested onInterruptRequested . fromSomeExitReason)- -- handle process shutdown requests:- -- 1. take process exit reason- -- 2. set process state to ProcessShuttingDown- -- 3. apply kontinue to (Right Interrupted)- --- where- tryTakeNextShutdownRequest =- lift (atomically (tryTakeNextShutdownRequestSTM myMessageQVar))- onShutdownRequested shutdownRequest = do- setMyProcessState ProcessShuttingDown- interpretRequestAfterShutdownRequest (diskontinueWith diskontinue)- shutdownRequest- request- onInterruptRequested interruptRequest = do- setMyProcessState ProcessShuttingDown- interpretRequestAfterInterruptRequest (kontinueWith kontinue nextRef)- (diskontinueWith diskontinue)- interruptRequest- request- noShutdownRequested = do- setMyProcessState ProcessBusy- interpretRequest (kontinueWith kontinue)- (diskontinueWith diskontinue)- nextRef- request--- This gets no nextRef and may not pass a Left value to the continuation.--- This forces the caller to defer the process exit to the next request--- and hence ensures that the scheduler code cannot forget to allow the--- client code to react to a shutdown request.- interpretRequestAfterShutdownRequest- :: forall v a- . HasCallStack- => Arr BaseEffects (Interrupt 'NoRecovery) a- -> Interrupt 'NoRecovery- -> Process BaseEffects v- -> Eff BaseEffects a- interpretRequestAfterShutdownRequest diskontinue shutdownRequest = \case- SendMessage _ _ -> diskontinue shutdownRequest- SendInterrupt _ _ -> diskontinue shutdownRequest- SendShutdown toPid r ->- if toPid == myPid then diskontinue r else diskontinue shutdownRequest- Spawn _ _ -> diskontinue shutdownRequest- SpawnLink _ _ -> diskontinue shutdownRequest- ReceiveSelectedMessage _ -> diskontinue shutdownRequest- FlushMessages -> diskontinue shutdownRequest- SelfPid -> diskontinue shutdownRequest- MakeReference -> diskontinue shutdownRequest- YieldProcess -> diskontinue shutdownRequest- Delay _ -> diskontinue shutdownRequest- Shutdown r -> diskontinue r- GetProcessState _ -> diskontinue shutdownRequest- UpdateProcessDetails _ -> diskontinue shutdownRequest- Monitor _ -> diskontinue shutdownRequest- Demonitor _ -> diskontinue shutdownRequest- Link _ -> diskontinue shutdownRequest- Unlink _ -> diskontinue shutdownRequest- interpretRequestAfterInterruptRequest- :: forall v a- . HasCallStack- => Arr BaseEffects v a- -> Arr BaseEffects (Interrupt 'NoRecovery) a- -> Interrupt 'Recoverable- -> Process BaseEffects v- -> Eff BaseEffects a- interpretRequestAfterInterruptRequest kontinue diskontinue interruptRequest =- \case- SendMessage _ _ -> kontinue (Interrupted interruptRequest)- SendInterrupt _ _ -> kontinue (Interrupted interruptRequest)- SendShutdown toPid r -> if toPid == myPid- then diskontinue r- else kontinue (Interrupted interruptRequest)- Spawn _ _ -> kontinue (Interrupted interruptRequest)- SpawnLink _ _ -> kontinue (Interrupted interruptRequest)- ReceiveSelectedMessage _ -> kontinue (Interrupted interruptRequest)- FlushMessages -> kontinue (Interrupted interruptRequest)- SelfPid -> kontinue (Interrupted interruptRequest)- MakeReference -> kontinue (Interrupted interruptRequest)- YieldProcess -> kontinue (Interrupted interruptRequest)- Delay _ -> kontinue (Interrupted interruptRequest)- Shutdown r -> diskontinue r- GetProcessState _ -> kontinue (Interrupted interruptRequest)- UpdateProcessDetails _ -> kontinue (Interrupted interruptRequest)- Monitor _ -> kontinue (Interrupted interruptRequest)- Demonitor _ -> kontinue (Interrupted interruptRequest)- Link _ -> kontinue (Interrupted interruptRequest)- Unlink _ -> kontinue (Interrupted interruptRequest)- interpretRequest- :: forall v a- . HasCallStack- => (Int -> Arr BaseEffects v a)- -> Arr BaseEffects (Interrupt 'NoRecovery) a- -> Int- -> Process BaseEffects v- -> Eff BaseEffects a- interpretRequest kontinue diskontinue nextRef = \case- SendMessage toPid msg ->- void (interpretSend toPid msg) >>= kontinue nextRef . ResumeWith- SendInterrupt toPid msg -> if toPid == myPid- then kontinue nextRef (Interrupted msg)- else- interpretSendShutdownOrInterrupt toPid (SomeExitReason msg)- >>= kontinue nextRef- . ResumeWith- SendShutdown toPid msg -> if toPid == myPid- then diskontinue msg- else- interpretSendShutdownOrInterrupt toPid (SomeExitReason msg)- >>= kontinue nextRef- . ResumeWith- Spawn title child ->- spawnNewProcess Nothing title child >>= kontinue nextRef . ResumeWith . fst- SpawnLink title child ->- spawnNewProcess (Just myProcessInfo) title child- >>= kontinue nextRef- . ResumeWith- . fst- ReceiveSelectedMessage f -> do- recvRes <- interpretReceive f- either diskontinue (kontinue nextRef) recvRes- Shutdown r -> diskontinue r- FlushMessages -> interpretFlush >>= kontinue nextRef- SelfPid -> kontinue nextRef (ResumeWith myPid)- MakeReference -> kontinue (nextRef + 1) (ResumeWith nextRef)- YieldProcess -> kontinue nextRef (ResumeWith ())- Delay t ->- interpretDelay t >>= either diskontinue (kontinue nextRef)- GetProcessState toPid ->- interpretGetProcessState toPid >>= kontinue nextRef . ResumeWith- UpdateProcessDetails d ->- interpretUpdateDetails d >>= kontinue nextRef . ResumeWith- Monitor target ->- interpretMonitor target >>= kontinue nextRef . ResumeWith- Demonitor ref -> interpretDemonitor ref >>= kontinue nextRef . ResumeWith- Link toPid ->- interpretLink toPid >>= kontinue nextRef . either Interrupted ResumeWith- Unlink toPid -> interpretUnlink toPid >>= kontinue nextRef . ResumeWith- where- interpretMonitor !target = do- setMyProcessState ProcessBusyMonitoring- schedulerState <- getSchedulerState- monitoringReference <- lift (atomically (nextMonitorReference target schedulerState))- void $ lift (atomically (addMonitoring monitoringReference myPid schedulerState))- return monitoringReference- interpretDemonitor !ref = do- setMyProcessState ProcessBusyMonitoring- schedulerState <- getSchedulerState- lift (atomically (removeMonitoring ref schedulerState))- interpretUnlink !toPid = do- setMyProcessState ProcessBusyUnlinking- schedulerState <- getSchedulerState- let procInfoVar = schedulerState ^. processTable- lift $ atomically $ do- procInfo <- readTVar procInfoVar- traverse_- (\toProcInfo ->- modifyTVar' (toProcInfo ^. processLinks) (Set.delete myPid)- )- (procInfo ^. at toPid)- modifyTVar' (myProcessInfo ^. processLinks) (Set.delete toPid)- interpretGetProcessState !toPid = do- setMyProcessState ProcessBusy- schedulerState <- getSchedulerState- let procInfoVar = schedulerState ^. processTable- initPd <- if toPid == 1- then Just <$> lift (renderSchedulerState schedulerState)- else pure Nothing- lift $ atomically $ do- procInfoTable <- readTVar procInfoVar- traverse (\toProcInfo -> do- (pDetails, pState) <- readTVar (toProcInfo ^. processState)- let pDetails' = fromMaybe pDetails initPd- return (toProcInfo ^. processTitle, pDetails', pState))- (procInfoTable ^. at toPid)- interpretUpdateDetails !td = do- setMyProcessState ProcessBusyUpdatingDetails- lift $ atomically $ setMyProcessDetailsSTM td- interpretLink !toPid = do- setMyProcessState ProcessBusyLinking- schedulerState <- getSchedulerState- let procInfoVar = schedulerState ^. processTable- lift $ atomically $ do- procInfoTable <- readTVar procInfoVar- case procInfoTable ^. at toPid of- Just toProcInfo -> do- modifyTVar' (toProcInfo ^. processLinks) (Set.insert myPid)- modifyTVar' (myProcessInfo ^. processLinks) (Set.insert toPid)- return (Right ())- Nothing -> return (Left (LinkedProcessCrashed toPid))- interpretSend !toPid msg =- setMyProcessState ProcessBusySending- *> getSchedulerState- >>= lift- . atomically- . enqueueMessageOtherProcess toPid msg- interpretSendShutdownOrInterrupt !toPid !msg =- setMyProcessState- (either (const ProcessBusySendingShutdown)- (const ProcessBusySendingInterrupt)- (fromSomeExitReason msg)- )- *> getSchedulerState- >>= lift- . atomically- . enqueueShutdownRequest toPid msg- interpretFlush :: Eff BaseEffects (ResumeProcess [StrictDynamic])- interpretFlush = do- setMyProcessState ProcessBusyReceiving- lift $ atomically $ do- myMessageQ <- readTVar myMessageQVar- modifyTVar' myMessageQVar (incomingMessages .~ Seq.Empty)- return (ResumeWith (toList (myMessageQ ^. incomingMessages)))- interpretDelay- :: Timeout- -> Eff BaseEffects (Either (Interrupt 'NoRecovery) (ResumeProcess ()))- interpretDelay (TimeoutMicros t) = do- setMyProcessState ProcessBusySleeping- lift $ do- timeoutTVar <- newTVarIO False- newDelayThreadId <- forkIO $ do- atomically $ writeTVar timeoutTVar False- threadDelay t- atomically $ writeTVar timeoutTVar True- (elapsed, res) <- atomically $ do- myMessageQ <- readTVar myMessageQVar- case myMessageQ ^. shutdownRequests of- Nothing -> do- done <- readTVar timeoutTVar- unless done retry- return (True, Right (ResumeWith ()))- Just shutdownRequest -> do- modifyTVar' myMessageQVar (shutdownRequests .~ Nothing)- case fromSomeExitReason shutdownRequest of- Left sr -> return (False, Left sr)- Right ir -> return (False, Right (Interrupted ir))- unless elapsed (killThread newDelayThreadId)- return res- interpretReceive- :: MessageSelector b- -> Eff BaseEffects (Either (Interrupt 'NoRecovery) (ResumeProcess b))- interpretReceive f = do- setMyProcessState ProcessBusyReceiving- lift $ atomically $ do- myMessageQ <- readTVar myMessageQVar- case myMessageQ ^. shutdownRequests of- Nothing ->- case- partitionMessages (myMessageQ ^. incomingMessages) Seq.Empty- of- Nothing -> retry- Just (selectedMessage, otherMessages) -> do- modifyTVar' myMessageQVar (incomingMessages .~ otherMessages)- return (Right (ResumeWith selectedMessage))- Just shutdownRequest -> do- modifyTVar' myMessageQVar (shutdownRequests .~ Nothing)- case fromSomeExitReason shutdownRequest of- Left sr -> return (Left sr)- Right ir -> return (Right (Interrupted ir))- where- partitionMessages Seq.Empty _acc = Nothing- partitionMessages (m :<| msgRest) acc = maybe- (partitionMessages msgRest (acc :|> m))- (\res -> Just (res, acc Seq.>< msgRest))- (runMessageSelector f m)---- | This is the main entry point to running a message passing concurrency--- application. This function takes a 'Process' on top of the 'BaseEffects'--- effect for concurrent logging.-schedule :: (HasCallStack) => Eff Effects () -> Eff LoggingAndIo ()-schedule procEff =- liftBaseWith- (\runS -> Async.withAsync- (runS $ withNewSchedulerState $ do- (_, mainProcAsync) <- spawnNewProcess Nothing "init" $ do- logNotice "++++++++ main process started ++++++++"- provideInterruptsShutdown procEff- logNotice "++++++++ main process returned ++++++++"- lift (void (Async.wait mainProcAsync))- )- (\ast -> runS $ do- a <- restoreM ast- void $ lift (Async.wait a)- )- )- >>= restoreM--spawnNewProcess- :: (HasCallStack)- => Maybe ProcessInfo- -> ProcessTitle- -> Eff SafeEffects ()- -> Eff BaseEffects (ProcessId, Async (Interrupt 'NoRecovery))-spawnNewProcess mLinkedParent title mfa = do- schedulerState <- getSchedulerState- procInfo <- allocateProcInfo schedulerState- traverse_ (linkToParent procInfo) mLinkedParent- procAsync <- doForkProc procInfo schedulerState- return (procInfo ^. processId, procAsync)- where- allocateProcInfo schedulerState = lift- (atomically- (do- let nextPidVar = schedulerState ^. nextPid- processInfoVar = schedulerState ^. processTable- pid <- readTVar nextPidVar- modifyTVar' nextPidVar (+ 1)- procInfo <- newProcessInfo pid title- modifyTVar' processInfoVar (at pid ?~ procInfo)- return procInfo- )- )- linkToParent toProcInfo parent = do- let toPid = toProcInfo ^. processId- parentPid = parent ^. processId- logDebug' ("linked to new child: " <> show toPid)- lift $ atomically $ do- modifyTVar' (toProcInfo ^. processLinks) (Set.insert parentPid)- modifyTVar' (parent ^. processLinks) (Set.insert toPid)- logAppendProcInfo pid =- let addProcessId = over- lmProcessId- (maybe (Just (T.pack (show title ++ show pid))) Just)- in censorLogs addProcessId- triggerProcessLinksAndMonitors- :: ProcessId -> Interrupt 'NoRecovery -> TVar (Set ProcessId) -> Eff BaseEffects ()- triggerProcessLinksAndMonitors !pid !reason !linkSetVar = do- schedulerState <- getSchedulerState- let exitSeverity = toExitSeverity reason- sendIt !linkedPid = do- let msg = SomeExitReason (LinkedProcessCrashed pid)- lift $ atomically $ do- procInfoTable <- readTVar (schedulerState ^. processTable)- let mLinkedProcInfo = procInfoTable ^? ix linkedPid- case mLinkedProcInfo of- Nothing -> return (Left linkedPid)- Just linkedProcInfo ->- let linkedMsgQVar = linkedProcInfo ^. messageQ- linkedLinkSetVar = linkedProcInfo ^. processLinks- in do- linkedLinkSet <- readTVar linkedLinkSetVar- if Set.member pid linkedLinkSet- then do- writeTVar linkedLinkSetVar- (Set.delete pid linkedLinkSet)- if exitSeverity == Crash then do- modifyTVar' linkedMsgQVar- (shutdownRequests ?~ msg)- return (Right (Left linkedPid))- else- return (Right (Right linkedPid))- else return (Left linkedPid)- downMessageSendResults <- lift . atomically $ triggerAndRemoveMonitor pid reason schedulerState- linkedPids <- lift- (atomically- (do- linkSet <- readTVar linkSetVar- writeTVar linkSetVar def- return linkSet- )- )- res <- traverse sendIt (toList linkedPids)- traverse_- (either- (logNotice . ("linked process not found: " <>) . T.pack . show)- (either- (logWarning . ("process crashed, interrupting linked process: " <>) . T.pack . show)- (logDebug . ("linked process exited peacefully, not sending shutdown to linked process: " <>) . T.pack . show)- )- )- res- unless (null downMessageSendResults) $- logWarning- ( "failed to enqueue monitor down messages for: "- <> T.pack(show downMessageSendResults)- )- doForkProc- :: ProcessInfo- -> SchedulerState- -> Eff BaseEffects (Async (Interrupt 'NoRecovery))- doForkProc procInfo schedulerState = control- (\inScheduler -> do- let cancellationsVar = schedulerState ^. processCancellationTable- processInfoVar = schedulerState ^. processTable- pid = procInfo ^. processId- procAsync <- Async.async- (inScheduler- (logAppendProcInfo- pid- (Safe.bracketWithError- (logDebug "enter process")- (\mExc () -> do- lift- (atomically- (do- modifyTVar' processInfoVar (at pid .~ Nothing)- modifyTVar' cancellationsVar (at pid .~ Nothing)- )- )- traverse_- (\exc -> logExitAndTriggerLinksAndMonitors- (exitReasonFromException exc)- pid- )- mExc- )- (const- (do- res <- handleProcess procInfo (mfa >> return ExitNormally)- logExitAndTriggerLinksAndMonitors res pid- )- )- )- )- )- atomically (modifyTVar' cancellationsVar (at pid ?~ procAsync))- return procAsync- )- where- exitReasonFromException exc = case Safe.fromException exc of- Just Async.AsyncCancelled -> ExitProcessCancelled Nothing- Nothing -> ExitUnhandledError ( "runtime exception:\n"- <> T.pack (prettyCallStack callStack)- <> "\n"- <> T.pack (Safe.displayException exc)- )- logExitAndTriggerLinksAndMonitors reason pid = do- (_, currentState) <-- lift (atomically- (readTVar (procInfo ^. processState)- <* modifyTVar' (procInfo ^. processState) (_2 .~ ProcessShuttingDown)))- when (currentState /= ProcessShuttingDown)- (logNotice ("aborted in state: "- <> T.pack (show currentState)- <> " by: "- <> T.pack (show reason)- ))- triggerProcessLinksAndMonitors pid reason (procInfo ^. processLinks)- logProcessExit reason- return reason---- * Scheduler Accessor-getSchedulerState :: HasBaseEffects r => Eff r SchedulerState-getSchedulerState = ask--enqueueMessageOtherProcess- :: HasCallStack => ProcessId -> StrictDynamic -> SchedulerState -> STM Bool-enqueueMessageOtherProcess toPid msg schedulerState =- view (at toPid) <$> readTVar (schedulerState ^. processTable) >>= maybe- (return False)- (\toProcessTable -> do- modifyTVar' (toProcessTable ^. messageQ) (incomingMessages %~ (:|> msg))- return True- )--enqueueShutdownRequest- :: HasCallStack => ProcessId -> SomeExitReason -> SchedulerState -> STM ()-enqueueShutdownRequest toPid msg schedulerState =- view (at toPid) <$> readTVar (schedulerState ^. processTable) >>= maybe- (return ())- (\toProcessTable -> do- modifyTVar' (toProcessTable ^. messageQ) (shutdownRequests ?~ msg)- return ()- )+module Control.Eff.Concurrent.Process.ForkIOScheduler+ ( schedule,+ defaultMain,+ defaultMainWithLogWriter,+ SafeEffects,+ Effects,+ BaseEffects,+ HasBaseEffects,+ )+where++import Control.Concurrent (forkIO, killThread, threadDelay, yield)+import Control.Concurrent.Async (Async (..))+import qualified Control.Concurrent.Async as Async+import Control.Concurrent.STM as STM+import Control.Eff+import Control.Eff.Concurrent.Process+import qualified Control.Eff.ExceptionExtra as ExcExtra+ (+ )+import Control.Eff.Extend+import Control.Eff.Log+import Control.Eff.LogWriter.Async+import Control.Eff.LogWriter.Console+import Control.Eff.Reader.Strict as Reader+import Control.Exception.Safe as Safe+import Control.Lens+import Control.Monad+ ( unless,+ void,+ when,+ )+import Control.Monad.Trans.Control+ ( MonadBaseControl (..),+ control,+ )+import Data.Default+import Data.Foldable+import Data.Function (fix)+import Data.Kind ()+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Sequence (Seq (..))+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import GHC.Stack+import qualified System.Timeout as System++-- * Process Types++-- | A message queue of a process, contains the actual queue and maybe an+-- exit reason. The message queue is backed by a 'Seq' sequence with 'Message' values.+data MessageQ = MessageQ+ { _incomingMessages :: Seq Message,+ _shutdownRequests :: Maybe InterruptOrShutdown+ }++instance Default MessageQ where+ def = MessageQ def def++makeLenses ''MessageQ++-- | Return any '_shutdownRequests' from a 'MessageQ' in a 'TVar' and+-- reset the '_shutdownRequests' field to 'Nothing' in the 'TVar'.+tryTakeNextShutdownRequestSTM :: TVar MessageQ -> STM (Maybe InterruptOrShutdown)+tryTakeNextShutdownRequestSTM mqVar = do+ mq <- readTVar mqVar+ when+ (isJust (mq ^. shutdownRequests))+ (writeTVar mqVar (mq & shutdownRequests .~ Nothing))+ return (mq ^. shutdownRequests)++-- | Information about a process, needed to implement+-- 'Process' handlers. The message queue is backed by a 'STM.TVar' that contains+-- a 'MessageQ'.+data ProcessInfo = ProcessInfo+ { _processId :: ProcessId,+ _processTitle :: ProcessTitle,+ _processState :: TVar (ProcessDetails, ProcessState),+ _messageQ :: TVar MessageQ,+ _processLinks :: TVar (Set ProcessId)+ }++makeLenses ''ProcessInfo++-- * Scheduler Types++-- | Contains all process info'elements, as well as the state needed to implement+-- inter-process communication.+data SchedulerState = SchedulerState+ { _nextPid :: TVar ProcessId,+ _processTable :: TVar (Map ProcessId ProcessInfo),+ _processCancellationTable :: TVar (Map ProcessId (Async ShutdownReason)),+ -- | Set of monitors and monitor owners+ _processMonitors :: TVar (Set (MonitorReference, ProcessId)),+ _nextMonitorIndex :: TVar Int+ }++makeLenses ''SchedulerState++renderSchedulerState :: SchedulerState -> IO ProcessDetails+renderSchedulerState s = do+ (np, pt, pct, pm, nm) <- atomically $ do+ np <- T.pack . show <$> readTVar (s ^. nextPid)+ pt <- T.pack . show . Map.size <$> readTVar (s ^. processTable)+ pct <- T.pack . show . Map.size <$> readTVar (s ^. processCancellationTable)+ pm <- T.pack . show . Set.size <$> readTVar (s ^. processMonitors)+ nm <- T.pack . show <$> readTVar (s ^. nextMonitorIndex)+ return (np, pt, pct, pm, nm)+ return $+ MkProcessDetails $+ T.unlines+ [ T.pack "ForkIO Scheduler nextPid: " <> np,+ T.pack "ForkIO Scheduler process table entries: " <> pt,+ T.pack "ForkIO Scheduler process cancellation table entries: " <> pct,+ T.pack "ForkIO Scheduler process monitors entries: " <> pm,+ T.pack "ForkIO Scheduler nextMonitorIndex: " <> nm+ ]++-- | Allocate a new 'MonitorReference'+nextMonitorReference :: ProcessId -> SchedulerState -> STM MonitorReference+nextMonitorReference target schedulerState = do+ aNewMonitorIndex <- readTVar (schedulerState ^. nextMonitorIndex)+ modifyTVar' (schedulerState ^. nextMonitorIndex) (+ 1)+ return (MkMonitorReference aNewMonitorIndex target)++-- | Add monitor: If the process is dead, enqueue a 'ProcessDown' message into the+-- owners message queue+addMonitoring :: MonitorReference -> ProcessId -> SchedulerState -> STM Int+addMonitoring monitorRef@(MkMonitorReference _ target) owner schedulerState =+ if target == owner+ then pure 0+ else do+ pt <- readTVar (schedulerState ^. processTable)+ case Map.lookup target pt of+ Just targetProcessInfo ->+ do+ (_, targetState) <- readTVar (targetProcessInfo ^. processState)+ check+ ( targetState == ProcessShuttingDown+ || targetState == ProcessBusyReceiving+ || targetState == ProcessIdle+ )+ if targetState /= ProcessShuttingDown+ then insertMonitoringReference >> pure 1+ else processAlreadyDead >> pure 2+ Nothing ->+ processAlreadyDead >> pure 3+ where+ insertMonitoringReference =+ modifyTVar'+ (schedulerState ^. processMonitors)+ (Set.insert (monitorRef, owner))+ processAlreadyDead = do+ let processDownMessage =+ ProcessDown monitorRef (ExitOtherProcessNotRunning target) target+ wasEnqueued <-+ enqueueMessageOtherProcess+ owner+ (toMessage processDownMessage)+ schedulerState+ check wasEnqueued++triggerAndRemoveMonitor ::+ ProcessId -> ShutdownReason -> SchedulerState -> STM [ProcessId]+triggerAndRemoveMonitor downPid reason schedulerState = do+ -- remove the monitor entries that the downPid process owned:+ modifyTVar'+ (schedulerState ^. processMonitors)+ (Set.filter (\(_, downPid') -> downPid' /= downPid))+ -- now send the process down message and remove the entries that monitor+ -- the downPid process:+ monRefs <- readTVar (schedulerState ^. processMonitors)+ catMaybes <$> traverse go (toList monRefs)+ where+ go (mr, owner) =+ if view monitoredProcess mr == downPid+ then do+ let processDownMessage = ProcessDown mr reason downPid+ wasEnqueued <-+ enqueueMessageOtherProcess+ owner+ (toMessage processDownMessage)+ schedulerState+ removeMonitoring mr schedulerState+ pure $ if wasEnqueued then Nothing else Just owner+ else pure Nothing++removeMonitoring :: MonitorReference -> SchedulerState -> STM ()+removeMonitoring monitorRef schedulerState =+ modifyTVar'+ (schedulerState ^. processMonitors)+ (Set.filter (\(ref, _) -> ref /= monitorRef))++-- * Process Implementation++instance Show ProcessInfo where+ show p = "process info: " ++ show (p ^. processId)++-- | Create a new 'ProcessInfo'+newProcessInfo :: ProcessId -> ProcessTitle -> STM ProcessInfo+newProcessInfo a t =+ ProcessInfo a t <$> newTVar (mempty, ProcessBooting) <*> newTVar def <*> newTVar def++-- * Scheduler Implementation++-- | Create a new 'SchedulerState'+newSchedulerState :: STM SchedulerState+newSchedulerState =+ SchedulerState+ <$> newTVar 1+ <*> newTVar def+ <*> newTVar def+ <*> newTVar def+ <*> newTVar def++-- | Create a new 'SchedulerState' run an IO action, catching all exceptions,+-- and when the actions returns, clean up and kill all processes.+withNewSchedulerState :: HasCallStack => Eff BaseEffects () -> Eff LoggingAndIo ()+withNewSchedulerState mainProcessAction =+ Safe.bracketWithError+ (lift (atomically newSchedulerState))+ ( \exceptions schedulerState -> do+ traverse_+ ( logError+ . LABEL "scheduler setup crashed with"+ . packLogMsg+ . Safe.displayException+ )+ exceptions+ logDebug (MSG "scheduler cleanup begin")+ runReader schedulerState tearDownScheduler+ )+ ( \schedulerState -> do+ logDebug (MSG "scheduler loop entered")+ x <- runReader schedulerState mainProcessAction+ logDebug (MSG "scheduler loop returned")+ return x+ )+ where+ tearDownScheduler :: Eff BaseEffects ()+ tearDownScheduler = do+ schedulerState <- getSchedulerState+ let cancelTableVar = schedulerState ^. processCancellationTable+ -- cancel all processes+ allProcesses <-+ lift+ (atomically (readTVar cancelTableVar <* writeTVar cancelTableVar def))+ logNotice+ ( LABEL+ "cancelling processes"+ (show (toListOf (ifolded . asIndex) allProcesses))+ )+ void+ ( liftBaseWith+ ( \runS ->+ System.timeout+ 5_000_000+ ( Async.mapConcurrently+ ( \a -> do+ Async.cancel a+ runS+ ( logNotice+ ( LABEL+ "process cancelled"+ (packLogMsg (show (asyncThreadId a)))+ )+ )+ )+ allProcesses+ >> runS (logNotice (MSG "all processes cancelled"))+ )+ )+ )++-- | The concrete list of 'Eff'ects of processes compatible with this scheduler.+-- This builds upon 'BaseEffects'.+--+-- @since 0.25.0+type SafeEffects = SafeProcesses BaseEffects++-- | The 'Eff'ects for interruptable, concurrent processes, scheduled via 'forkIO'.+--+-- @since 0.25.0+type Effects = Processes BaseEffects++-- | Type class constraint to indicate that an effect union contains the+-- effects required by every process and the scheduler implementation itself.+--+-- @since 0.25.0+type HasBaseEffects r = (HasCallStack, Lifted IO r, BaseEffects <:: r)++-- | The concrete list of 'Eff'ects for this scheduler implementation.+--+-- @since 0.25.0+type BaseEffects = Reader SchedulerState : LoggingAndIo++-- | Start the message passing concurrency system then execute a 'Process' on+-- top of 'BaseEffects' effect. All logging is sent to standard output.+defaultMain :: HasCallStack => Eff Effects () -> IO ()+defaultMain e = do+ lw <- consoleLogWriter+ defaultMainWithLogWriter lw e++-- | Start the message passing concurrency system then execute a 'Process' on+-- top of 'BaseEffects' effect. All logging is sent to standard output.+defaultMainWithLogWriter ::+ HasCallStack => LogWriter -> Eff Effects () -> IO ()+defaultMainWithLogWriter lw =+ runLift . withLogging lw . withAsyncLogWriter (1024 :: Int) . schedule++-- ** Process Execution++handleProcess ::+ HasCallStack =>+ ProcessInfo ->+ Eff SafeEffects ShutdownReason ->+ Eff BaseEffects ShutdownReason+handleProcess myProcessInfo actionToRun =+ fix+ (handle_relay' singleStep (\er _nextRef -> setMyProcessState ProcessShuttingDown >> return er))+ actionToRun+ 0+ where+ singleStep ::+ (Eff SafeEffects xx -> (Int -> Eff BaseEffects ShutdownReason)) ->+ Arrs SafeEffects x xx ->+ Process BaseEffects x ->+ (Int -> Eff BaseEffects ShutdownReason)+ singleStep k q p !nextRef =+ stepProcessInterpreter+ nextRef+ p+ (\nextNextRef x -> k (qApp q x) nextNextRef)+ return+ myPid = myProcessInfo ^. processId+ myProcessStateVar = myProcessInfo ^. processState+ setMyProcessState = lift . atomically . setMyProcessStateSTM+ -- DEBUG variant:+ -- setMyProcessState st = do+ -- oldSt <- lift (atomically (readTVar myProcessStateVar <* setMyProcessStateSTM st))+ -- logDebug ("state change: "<> show oldSt <> " -> " <> show st)+ setMyProcessStateSTM = modifyTVar myProcessStateVar . set _2+ setMyProcessDetailsSTM = modifyTVar myProcessStateVar . set _1+ myMessageQVar = myProcessInfo ^. messageQ+ kontinueWith ::+ forall s v a.+ (s -> Arr BaseEffects v a) ->+ (s -> Arr BaseEffects v a)+ kontinueWith kontinue !nextRef !result = do+ setMyProcessState ProcessIdle+ lift yield+ kontinue nextRef result+ diskontinueWith ::+ forall a.+ Arr BaseEffects ShutdownReason a ->+ Arr BaseEffects ShutdownReason a+ diskontinueWith diskontinue !reason = do+ setMyProcessState ProcessShuttingDown+ diskontinue reason+ stepProcessInterpreter ::+ forall v a.+ HasCallStack =>+ Int ->+ Process BaseEffects v ->+ (Int -> Arr BaseEffects v a) ->+ Arr BaseEffects ShutdownReason a ->+ Eff BaseEffects a+ stepProcessInterpreter !nextRef !request kontinue diskontinue =+ tryTakeNextShutdownRequest+ >>= maybe+ noShutdownRequested+ (either onShutdownRequested onInterruptRequested . fromInterruptOrShutdown)+ where+ -- handle process shutdown requests:+ -- 1. take process exit reason+ -- 2. set process state to ProcessShuttingDown+ -- 3. apply kontinue to (Right Interrupted)+ --++ tryTakeNextShutdownRequest =+ lift (atomically (tryTakeNextShutdownRequestSTM myMessageQVar))+ onShutdownRequested shutdownRequest = do+ setMyProcessState ProcessShuttingDown+ interpretRequestAfterShutdownRequest+ (diskontinueWith diskontinue)+ shutdownRequest+ request+ onInterruptRequested interruptRequest = do+ setMyProcessState ProcessShuttingDown+ interpretRequestAfterInterruptRequest+ (kontinueWith kontinue nextRef)+ (diskontinueWith diskontinue)+ interruptRequest+ request+ noShutdownRequested = do+ setMyProcessState ProcessBusy+ interpretRequest+ (kontinueWith kontinue)+ (diskontinueWith diskontinue)+ nextRef+ request+ -- This gets no nextRef and may not pass a Left value to the continuation.+ -- This forces the caller to defer the process exit to the next request+ -- and hence ensures that the scheduler code cannot forget to allow the+ -- client code to react to a shutdown request.+ interpretRequestAfterShutdownRequest ::+ forall v a.+ Arr BaseEffects ShutdownReason a ->+ ShutdownReason ->+ Process BaseEffects v ->+ Eff BaseEffects a+ interpretRequestAfterShutdownRequest diskontinue shutdownRequest = \case+ SendMessage _ _ -> diskontinue shutdownRequest+ SendInterrupt _ _ -> diskontinue shutdownRequest+ SendShutdown toPid r ->+ if toPid == myPid then diskontinue r else diskontinue shutdownRequest+ Spawn _ _ -> diskontinue shutdownRequest+ SpawnLink _ _ -> diskontinue shutdownRequest+ ReceiveSelectedMessage _ -> diskontinue shutdownRequest+ FlushMessages -> diskontinue shutdownRequest+ SelfPid -> diskontinue shutdownRequest+ MakeReference -> diskontinue shutdownRequest+ YieldProcess -> diskontinue shutdownRequest+ Delay _ -> diskontinue shutdownRequest+ Shutdown r -> diskontinue r+ GetProcessState _ -> diskontinue shutdownRequest+ UpdateProcessDetails _ -> diskontinue shutdownRequest+ Monitor _ -> diskontinue shutdownRequest+ Demonitor _ -> diskontinue shutdownRequest+ Link _ -> diskontinue shutdownRequest+ Unlink _ -> diskontinue shutdownRequest+ interpretRequestAfterInterruptRequest ::+ forall v a.+ Arr BaseEffects v a ->+ Arr BaseEffects ShutdownReason a ->+ InterruptReason ->+ Process BaseEffects v ->+ Eff BaseEffects a+ interpretRequestAfterInterruptRequest kontinue diskontinue interruptRequest =+ \case+ SendMessage _ _ -> kontinue (Interrupted interruptRequest)+ SendInterrupt _ _ -> kontinue (Interrupted interruptRequest)+ SendShutdown toPid r ->+ if toPid == myPid+ then diskontinue r+ else kontinue (Interrupted interruptRequest)+ Spawn _ _ -> kontinue (Interrupted interruptRequest)+ SpawnLink _ _ -> kontinue (Interrupted interruptRequest)+ ReceiveSelectedMessage _ -> kontinue (Interrupted interruptRequest)+ FlushMessages -> kontinue (Interrupted interruptRequest)+ SelfPid -> kontinue (Interrupted interruptRequest)+ MakeReference -> kontinue (Interrupted interruptRequest)+ YieldProcess -> kontinue (Interrupted interruptRequest)+ Delay _ -> kontinue (Interrupted interruptRequest)+ Shutdown r -> diskontinue r+ GetProcessState _ -> kontinue (Interrupted interruptRequest)+ UpdateProcessDetails _ -> kontinue (Interrupted interruptRequest)+ Monitor _ -> kontinue (Interrupted interruptRequest)+ Demonitor _ -> kontinue (Interrupted interruptRequest)+ Link _ -> kontinue (Interrupted interruptRequest)+ Unlink _ -> kontinue (Interrupted interruptRequest)+ interpretRequest ::+ forall v a.+ HasCallStack =>+ (Int -> Arr BaseEffects v a) ->+ Arr BaseEffects ShutdownReason a ->+ Int ->+ Process BaseEffects v ->+ Eff BaseEffects a+ interpretRequest kontinue diskontinue nextRef = \case+ SendMessage toPid msg ->+ void (interpretSend toPid msg) >>= kontinue nextRef . ResumeWith+ SendInterrupt toPid msg ->+ if toPid == myPid+ then kontinue nextRef (Interrupted msg)+ else+ interpretSendShutdownOrInterrupt toPid (InterruptOrShutdown (Right msg))+ >>= kontinue nextRef+ . ResumeWith+ SendShutdown toPid msg ->+ if toPid == myPid+ then diskontinue msg+ else+ interpretSendShutdownOrInterrupt toPid (InterruptOrShutdown (Left msg))+ >>= kontinue nextRef+ . ResumeWith+ Spawn title child ->+ spawnNewProcess Nothing title child >>= kontinue nextRef . ResumeWith . fst+ SpawnLink title child ->+ spawnNewProcess (Just myProcessInfo) title child+ >>= kontinue nextRef+ . ResumeWith+ . fst+ ReceiveSelectedMessage f -> do+ recvRes <- interpretReceive f+ either diskontinue (kontinue nextRef) recvRes+ Shutdown r -> diskontinue r+ FlushMessages -> interpretFlush >>= kontinue nextRef+ SelfPid -> kontinue nextRef (ResumeWith myPid)+ MakeReference -> kontinue (nextRef + 1) (ResumeWith nextRef)+ YieldProcess -> kontinue nextRef (ResumeWith ())+ Delay t ->+ interpretDelay t >>= either diskontinue (kontinue nextRef)+ GetProcessState toPid ->+ interpretGetProcessState toPid >>= kontinue nextRef . ResumeWith+ UpdateProcessDetails d ->+ interpretUpdateDetails d >>= kontinue nextRef . ResumeWith+ Monitor target ->+ interpretMonitor target >>= kontinue nextRef . ResumeWith+ Demonitor ref -> interpretDemonitor ref >>= kontinue nextRef . ResumeWith+ Link toPid ->+ interpretLink toPid >>= kontinue nextRef . either Interrupted ResumeWith+ Unlink toPid -> interpretUnlink toPid >>= kontinue nextRef . ResumeWith+ where+ interpretMonitor !target = do+ setMyProcessState ProcessBusyMonitoring+ schedulerState <- getSchedulerState+ monitoringReference <- lift (atomically (nextMonitorReference target schedulerState))+ void $ lift (atomically (addMonitoring monitoringReference myPid schedulerState))+ return monitoringReference+ interpretDemonitor !ref = do+ setMyProcessState ProcessBusyMonitoring+ schedulerState <- getSchedulerState+ lift (atomically (removeMonitoring ref schedulerState))+ interpretUnlink !toPid = do+ setMyProcessState ProcessBusyUnlinking+ schedulerState <- getSchedulerState+ let procInfoVar = schedulerState ^. processTable+ lift $+ atomically $ do+ procInfo <- readTVar procInfoVar+ traverse_+ ( \toProcInfo ->+ modifyTVar' (toProcInfo ^. processLinks) (Set.delete myPid)+ )+ (procInfo ^. at toPid)+ modifyTVar' (myProcessInfo ^. processLinks) (Set.delete toPid)+ interpretGetProcessState !toPid = do+ setMyProcessState ProcessBusy+ schedulerState <- getSchedulerState+ let procInfoVar = schedulerState ^. processTable+ initPd <-+ if toPid == 1+ then Just <$> lift (renderSchedulerState schedulerState)+ else pure Nothing+ lift $+ atomically $ do+ procInfoTable <- readTVar procInfoVar+ traverse+ ( \toProcInfo -> do+ (pDetails, pState) <- readTVar (toProcInfo ^. processState)+ let pDetails' = fromMaybe pDetails initPd+ return (toProcInfo ^. processTitle, pDetails', pState)+ )+ (procInfoTable ^. at toPid)+ interpretUpdateDetails !td = do+ setMyProcessState ProcessBusyUpdatingDetails+ lift $ atomically $ setMyProcessDetailsSTM td+ interpretLink !toPid = do+ setMyProcessState ProcessBusyLinking+ schedulerState <- getSchedulerState+ let procInfoVar = schedulerState ^. processTable+ lift $+ atomically $ do+ procInfoTable <- readTVar procInfoVar+ case procInfoTable ^. at toPid of+ Just toProcInfo -> do+ modifyTVar' (toProcInfo ^. processLinks) (Set.insert myPid)+ modifyTVar' (myProcessInfo ^. processLinks) (Set.insert toPid)+ return (Right ())+ Nothing -> return (Left (LinkedProcessCrashed toPid))+ interpretSend !toPid msg =+ setMyProcessState ProcessBusySending+ *> getSchedulerState+ >>= lift+ . atomically+ . enqueueMessageOtherProcess toPid msg+ interpretSendShutdownOrInterrupt !toPid !msg =+ setMyProcessState+ ( either+ (const ProcessBusySendingShutdown)+ (const ProcessBusySendingInterrupt)+ (fromInterruptOrShutdown msg)+ )+ *> getSchedulerState+ >>= lift+ . atomically+ . enqueueShutdownRequest toPid msg+ interpretFlush :: Eff BaseEffects (ResumeProcess [Message])+ interpretFlush = do+ setMyProcessState ProcessBusyReceiving+ lift $+ atomically $ do+ myMessageQ <- readTVar myMessageQVar+ modifyTVar' myMessageQVar (incomingMessages .~ Seq.Empty)+ return (ResumeWith (toList (myMessageQ ^. incomingMessages)))+ interpretDelay ::+ Timeout ->+ Eff BaseEffects (Either ShutdownReason (ResumeProcess ()))+ interpretDelay (TimeoutMicros t) = do+ setMyProcessState ProcessBusySleeping+ lift $ do+ timeoutTVar <- newTVarIO False+ newDelayThreadId <- forkIO $ do+ atomically $ writeTVar timeoutTVar False+ threadDelay t+ atomically $ writeTVar timeoutTVar True+ (elapsed, res) <- atomically $ do+ myMessageQ <- readTVar myMessageQVar+ case myMessageQ ^. shutdownRequests of+ Nothing -> do+ done <- readTVar timeoutTVar+ unless done retry+ return (True, Right (ResumeWith ()))+ Just shutdownRequest -> do+ modifyTVar' myMessageQVar (shutdownRequests .~ Nothing)+ case fromInterruptOrShutdown shutdownRequest of+ Left sr -> return (False, Left sr)+ Right ir -> return (False, Right (Interrupted ir))+ unless elapsed (killThread newDelayThreadId)+ return res+ interpretReceive ::+ MessageSelector b ->+ Eff BaseEffects (Either ShutdownReason (ResumeProcess b))+ interpretReceive f = do+ setMyProcessState ProcessBusyReceiving+ lift $+ atomically $ do+ myMessageQ <- readTVar myMessageQVar+ case myMessageQ ^. shutdownRequests of+ Nothing ->+ case partitionMessages (myMessageQ ^. incomingMessages) Seq.Empty of+ Nothing -> retry+ Just (selectedMessage, otherMessages) -> do+ modifyTVar' myMessageQVar (incomingMessages .~ otherMessages)+ return (Right (ResumeWith selectedMessage))+ Just shutdownRequest -> do+ modifyTVar' myMessageQVar (shutdownRequests .~ Nothing)+ case fromInterruptOrShutdown shutdownRequest of+ Left sr -> return (Left sr)+ Right ir -> return (Right (Interrupted ir))+ where+ partitionMessages Seq.Empty _acc = Nothing+ partitionMessages (m :<| msgRest) acc =+ maybe+ (partitionMessages msgRest (acc :|> m))+ (\res -> Just (res, acc Seq.>< msgRest))+ (runMessageSelector f m)++-- | This is the main entry point to running a message passing concurrency+-- application. This function takes a 'Process' on top of the 'BaseEffects'+-- effect for concurrent logging.+schedule :: HasCallStack => Eff Effects () -> Eff LoggingAndIo ()+schedule procEff =+ liftBaseWith+ ( \runS ->+ Async.withAsync+ ( runS $+ withNewSchedulerState $ do+ (_, mainProcAsync) <- spawnNewProcess Nothing (toProcessTitle "init") $ do+ logNotice (MSG "++++++++ main process started ++++++++")+ provideInterruptsShutdown procEff+ logNotice (MSG "++++++++ main process returned ++++++++")+ lift (void (Async.wait mainProcAsync))+ )+ ( \ast -> runS $ do+ a <- restoreM ast+ void $ lift (Async.wait a)+ )+ )+ >>= restoreM++spawnNewProcess ::+ HasCallStack =>+ Maybe ProcessInfo ->+ ProcessTitle ->+ Eff SafeEffects () ->+ Eff BaseEffects (ProcessId, Async ShutdownReason)+spawnNewProcess mLinkedParent title mfa = do+ schedulerState <- getSchedulerState+ procInfo <- allocateProcInfo schedulerState+ traverse_ (linkToParent procInfo) mLinkedParent+ procAsync <- doForkProc procInfo schedulerState+ return (procInfo ^. processId, procAsync)+ where+ allocateProcInfo schedulerState =+ lift+ ( atomically+ ( do+ let nextPidVar = schedulerState ^. nextPid+ processInfoVar = schedulerState ^. processTable+ pid <- readTVar nextPidVar+ modifyTVar' nextPidVar (+ 1)+ procInfo <- newProcessInfo pid title+ modifyTVar' processInfoVar (at pid ?~ procInfo)+ return procInfo+ )+ )+ linkToParent toProcInfo parent = do+ let toPid = toProcInfo ^. processId+ parentPid = parent ^. processId+ logDebug (LABEL "linked to new child" toPid)+ lift $+ atomically $ do+ modifyTVar' (toProcInfo ^. processLinks) (Set.insert parentPid)+ modifyTVar' (parent ^. processLinks) (Set.insert toPid)+ logAppendProcInfo pid =+ let addProcessId =+ over+ logEventProcessId+ (maybe (Just (T.pack (show title ++ show pid))) Just)+ in censorLogs addProcessId+ triggerProcessLinksAndMonitors ::+ ProcessId -> ShutdownReason -> TVar (Set ProcessId) -> Eff BaseEffects ()+ triggerProcessLinksAndMonitors !pid !reason !linkSetVar = do+ schedulerState <- getSchedulerState+ let exitSeverity = toExitSeverity reason+ sendIt !linkedPid = do+ let msg = InterruptOrShutdown (Right (LinkedProcessCrashed pid))+ lift $+ atomically $ do+ procInfoTable <- readTVar (schedulerState ^. processTable)+ let mLinkedProcInfo = procInfoTable ^? ix linkedPid+ case mLinkedProcInfo of+ Nothing -> return (Left linkedPid)+ Just linkedProcInfo ->+ let linkedMsgQVar = linkedProcInfo ^. messageQ+ linkedLinkSetVar = linkedProcInfo ^. processLinks+ in do+ linkedLinkSet <- readTVar linkedLinkSetVar+ if Set.member pid linkedLinkSet+ then do+ writeTVar+ linkedLinkSetVar+ (Set.delete pid linkedLinkSet)+ if exitSeverity == Crash+ then do+ modifyTVar'+ linkedMsgQVar+ (shutdownRequests ?~ msg)+ return (Right (Left linkedPid))+ else return (Right (Right linkedPid))+ else return (Left linkedPid)+ downMessageSendResults <- lift . atomically $ triggerAndRemoveMonitor pid reason schedulerState+ linkedPids <-+ lift+ ( atomically+ ( do+ linkSet <- readTVar linkSetVar+ writeTVar linkSetVar def+ return linkSet+ )+ )+ res <- traverse sendIt (toList linkedPids)+ traverse_+ ( either+ (logNotice . LABEL "linked process not found")+ ( either+ (logWarning . LABEL "process crashed, interrupting linked process")+ (logDebug . LABEL "linked process exited peacefully, not sending shutdown to linked process")+ )+ )+ res+ unless (null downMessageSendResults) $+ traverse_+ (logWarning . LABEL "failed to enqueue monitor down messages for")+ downMessageSendResults+ doForkProc ::+ ProcessInfo ->+ SchedulerState ->+ Eff BaseEffects (Async ShutdownReason)+ doForkProc procInfo schedulerState =+ control+ ( \inScheduler -> do+ let cancellationsVar = schedulerState ^. processCancellationTable+ processInfoVar = schedulerState ^. processTable+ pid = procInfo ^. processId+ procAsync <-+ Async.async+ ( inScheduler+ ( logAppendProcInfo+ pid+ ( Safe.bracketWithError+ (logDebug (MSG "enter process"))+ ( \mExc () -> do+ lift+ ( atomically+ ( do+ modifyTVar' processInfoVar (at pid .~ Nothing)+ modifyTVar' cancellationsVar (at pid .~ Nothing)+ )+ )+ traverse_+ ( \exc ->+ logExitAndTriggerLinksAndMonitors+ (exitReasonFromException exc)+ pid+ )+ mExc+ )+ ( const+ ( do+ res <- handleProcess procInfo (mfa >> return ExitNormally)+ logExitAndTriggerLinksAndMonitors res pid+ )+ )+ )+ )+ )+ atomically (modifyTVar' cancellationsVar (at pid ?~ procAsync))+ return procAsync+ )+ where+ exitReasonFromException exc = case Safe.fromException exc of+ Just Async.AsyncCancelled -> ExitProcessCancelled Nothing+ Nothing ->+ ExitUnhandledError+ ( packLogMsg "runtime exception: "+ <> packLogMsg (prettyCallStack callStack)+ <> packLogMsg " "+ <> packLogMsg (Safe.displayException exc)+ )+ logExitAndTriggerLinksAndMonitors reason pid = do+ (_, currentState) <-+ lift+ ( atomically+ ( readTVar (procInfo ^. processState)+ <* modifyTVar' (procInfo ^. processState) (_2 .~ ProcessShuttingDown)+ )+ )+ when+ (currentState /= ProcessShuttingDown)+ (logNotice reason (LABEL "state" currentState))+ triggerProcessLinksAndMonitors pid reason (procInfo ^. processLinks)+ logProcessExit reason+ return reason++-- * Scheduler Accessor++getSchedulerState :: HasBaseEffects r => Eff r SchedulerState+getSchedulerState = ask++enqueueMessageOtherProcess :: ProcessId -> Message -> SchedulerState -> STM Bool+enqueueMessageOtherProcess toPid msg schedulerState =+ readTVar (schedulerState ^. processTable)+ >>= maybe+ (return False)+ ( \toProcessTable -> do+ modifyTVar' (toProcessTable ^. messageQ) (incomingMessages %~ (:|> msg))+ return True+ )+ . view (at toPid)++enqueueShutdownRequest :: ProcessId -> InterruptOrShutdown -> SchedulerState -> STM ()+enqueueShutdownRequest toPid msg schedulerState =+ readTVar (schedulerState ^. processTable)+ >>= maybe+ (return ())+ ( \toProcessTable -> do+ modifyTVar' (toProcessTable ^. messageQ) (shutdownRequests ?~ msg)+ return ()+ )+ . view (at toPid)
src/Control/Eff/Concurrent/Process/Interactive.hs view
@@ -12,7 +12,7 @@ -- -- >>> s <- forkInteractiveScheduler Control.Eff.Concurrent.Process.SingleThreadedScheduler.defaultMain ----- >>> fooPid <- submit s (spawn (foreverCheap (receiveAnyMessage SP >>= (logMsg . fromMaybe "Huh!??" . fromDynamic))))+-- >>> fooPid <- submit s (spawn (foreverCheap (receiveAnyMessage SP >>= (sendLogEvent . fromMaybe "Huh!??" . fromDynamic)))) -- -- >>> fooPid -- <0.1.0>@@ -26,131 +26,131 @@ -- -- @since 0.3.0.1 module Control.Eff.Concurrent.Process.Interactive- ( SchedulerSession()- , forkInteractiveScheduler- , killInteractiveScheduler- , submit- , submitCast- , submitCall+ ( SchedulerSession (),+ forkInteractiveScheduler,+ killInteractiveScheduler,+ submit,+ submitCast,+ submitCall, ) where -import Control.Concurrent-import Control.Concurrent.STM-import Control.Eff-import Control.Eff.Concurrent.Protocol-import Control.Eff.Concurrent.Protocol.Client-import Control.Eff.Concurrent.Process-import Control.Monad-import Data.Foldable-import System.Timeout+import Control.Concurrent+import Control.Concurrent.STM+import Control.Eff+import Control.Eff.Concurrent.Process+import Control.Eff.Concurrent.Protocol+import Control.Eff.Concurrent.Protocol.Client+import Control.Monad+import Data.Foldable+import System.Timeout -- | Contains the communication channels to interact with a scheduler running in -- its' own thread. newtype SchedulerSession r = SchedulerSession (TMVar (SchedulerQueue r)) -newtype SchedulerQueue r =- SchedulerQueue (TChan (Eff (Processes r) (Maybe String)))+newtype SchedulerQueue r+ = SchedulerQueue (TChan (Eff (Processes r) (Maybe String))) -- | Fork a scheduler with a process that communicates with it via 'MVar', -- which is also the reason for the @Lift IO@ constraint.-forkInteractiveScheduler- :: forall r- . (SetMember Lift (Lift IO) r)- => (Eff (Processes r) () -> IO ())- -> IO (SchedulerSession r)+forkInteractiveScheduler ::+ forall r.+ (SetMember Lift (Lift IO) r) =>+ (Eff (Processes r) () -> IO ()) ->+ IO (SchedulerSession r) forkInteractiveScheduler ioScheduler = do- inQueue <- newTChanIO+ inQueue <- newTChanIO queueVar <- newEmptyTMVarIO- void $ forkIO- (do- ioScheduler- (do- lift (atomically (putTMVar queueVar (SchedulerQueue inQueue)))- readEvalPrintLoop queueVar- )- atomically (void (takeTMVar queueVar))- )+ void $+ forkIO+ ( do+ ioScheduler+ ( do+ lift (atomically (putTMVar queueVar (SchedulerQueue inQueue)))+ readEvalPrintLoop queueVar+ )+ atomically (void (takeTMVar queueVar))+ ) return (SchedulerSession queueVar)- where- readEvalPrintLoop- :: TMVar (SchedulerQueue r) -> Eff (Processes r) ()- readEvalPrintLoop queueVar = do- nextActionOrExit <- readAction- case nextActionOrExit of- Left True -> return ()- Left False -> readEvalPrintLoop queueVar- Right nextAction -> do- res <- nextAction- traverse_ (lift . putStrLn . (">>> " ++)) res- yieldProcess- readEvalPrintLoop queueVar- where- readAction = lift $ atomically $ do- mInQueue <- tryReadTMVar queueVar- case mInQueue of- Nothing -> return (Left True)- Just (SchedulerQueue inQueue) -> do- mNextAction <- tryReadTChan inQueue- case mNextAction of- Nothing -> return (Left False)- Just nextAction -> return (Right nextAction)+ where+ readEvalPrintLoop ::+ TMVar (SchedulerQueue r) -> Eff (Processes r) ()+ readEvalPrintLoop queueVar = do+ nextActionOrExit <- readAction+ case nextActionOrExit of+ Left True -> return ()+ Left False -> readEvalPrintLoop queueVar+ Right nextAction -> do+ res <- nextAction+ traverse_ (lift . putStrLn . (">>> " ++)) res+ yieldProcess+ readEvalPrintLoop queueVar+ where+ readAction = lift $+ atomically $ do+ mInQueue <- tryReadTMVar queueVar+ case mInQueue of+ Nothing -> return (Left True)+ Just (SchedulerQueue inQueue) -> do+ mNextAction <- tryReadTChan inQueue+ case mNextAction of+ Nothing -> return (Left False)+ Just nextAction -> return (Right nextAction) -- | Exit the scheduler immediately using an asynchronous exception. killInteractiveScheduler :: SchedulerSession r -> IO () killInteractiveScheduler (SchedulerSession qVar) = atomically (void (tryTakeTMVar qVar))- + -- | Send a 'Process' effect to the main process of a scheduler, this blocks -- until the effect is executed.-submit- :: forall r a- . (SetMember Lift (Lift IO) r)- => SchedulerSession r- -> Eff (Processes r) a- -> IO a+submit ::+ forall r a.+ (SetMember Lift (Lift IO) r) =>+ SchedulerSession r ->+ Eff (Processes r) a ->+ IO a submit (SchedulerSession qVar) theAction = do- mResVar <- timeout 5000000 $ atomically- (do- SchedulerQueue inQueue <- readTMVar qVar- resVar <- newEmptyTMVar- writeTChan inQueue (runAndPutResult resVar)- return resVar- )-+ mResVar <-+ timeout 5000000 $+ atomically+ ( do+ SchedulerQueue inQueue <- readTMVar qVar+ resVar <- newEmptyTMVar+ writeTChan inQueue (runAndPutResult resVar)+ return resVar+ ) case mResVar of Just resVar -> atomically (takeTMVar resVar)- Nothing -> fail "ERROR: No Scheduler"- where- runAndPutResult resVar = do- res <- theAction- lift (atomically (putTMVar resVar $! res))- return Nothing+ Nothing -> fail "ERROR: No Scheduler"+ where+ runAndPutResult resVar = do+ res <- theAction+ lift (atomically (putTMVar resVar $! res))+ return Nothing -- | Combination of 'submit' and 'cast'.-submitCast- :: forall o r- . ( SetMember Lift (Lift IO) r- , HasPdu o- , Tangible (Pdu o 'Asynchronous)- , Member Interrupts r)- => SchedulerSession r- -> Endpoint o- -> Pdu o 'Asynchronous- -> IO ()+submitCast ::+ forall o r.+ ( SetMember Lift (Lift IO) r,+ TangiblePdu o 'Asynchronous+ ) =>+ SchedulerSession r ->+ Endpoint o ->+ Pdu o 'Asynchronous ->+ IO () submitCast sc svr request = submit sc (cast svr request) -- | Combination of 'submit' and 'cast'.-submitCall- :: forall o q r- . ( SetMember Lift (Lift IO) r- , Member Interrupts r- , Tangible (Pdu o ('Synchronous q))- , HasPdu o- , Tangible q- )- => SchedulerSession r- -> Endpoint o- -> Pdu o ( 'Synchronous q)- -> IO q+submitCall ::+ forall o q r.+ ( SetMember Lift (Lift IO) r,+ TangiblePdu o ('Synchronous q),+ Tangible q+ ) =>+ SchedulerSession r ->+ Endpoint o ->+ Pdu o ('Synchronous q) ->+ IO q submitCall sc svr request = submit sc (call svr request)
src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs view
@@ -1,106 +1,112 @@+{-# LANGUAGE BangPatterns #-}+ -- | A coroutine based, single threaded scheduler for 'Process'es.+-- TODO: REMOVE module Control.Eff.Concurrent.Process.SingleThreadedScheduler- ( scheduleM- , scheduleMonadIOEff- , scheduleIOWithLogging- , schedulePure- , PureEffects- , PureSafeEffects- , PureBaseEffects- , HasPureBaseEffects- , defaultMain- , defaultMainWithLogWriter- , scheduleIO- , EffectsIo- , SafeEffectsIo- , BaseEffectsIo- , HasBaseEffectsIo+ ( scheduleM,+ scheduleMonadIOEff,+ scheduleIOWithLogging,+ schedulePure,+ PureEffects,+ PureSafeEffects,+ PureBaseEffects,+ HasPureBaseEffects,+ defaultMain,+ defaultMainWithLogWriter,+ scheduleIO,+ EffectsIo,+ SafeEffectsIo,+ BaseEffectsIo,+ HasBaseEffectsIo, ) where -import Control.Concurrent ( yield )-import Control.Eff-import Control.Eff.Extend-import Control.Eff.Concurrent.Misc-import Control.Eff.Concurrent.Process-import Control.Eff.Log-import Control.Eff.LogWriter.Console-import Control.Lens hiding ( (|>)- , Empty- )-import Control.Monad ( void- , when- , foldM- )-import Control.Monad.IO.Class-import qualified Data.Sequence as Seq-import Data.Sequence ( Seq(..) )-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import GHC.Stack-import Data.Kind ( )-import Data.Foldable-import Data.Monoid-import qualified Control.Monad.State.Strict as State-import Data.Function ( fix)-import Data.Dynamic ( dynTypeRep )+import Control.Concurrent (yield)+import Control.Eff+import Control.Eff.Concurrent.Process+import Control.Eff.Extend+import Control.Eff.Log+import Control.Eff.LogWriter.Console+import Control.Lens hiding+ ( Empty,+ (|>),+ )+import Control.Monad+ ( foldM,+ void,+ when,+ )+import Control.Monad.IO.Class+import qualified Control.Monad.State.Strict as State+import Data.Coerce+import Data.Foldable+import Data.Function (fix)+import Data.Kind ()+import qualified Data.Map.Strict as Map+import Data.Monoid+import Data.Sequence (Seq (..))+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import Data.String (IsString (fromString))+import GHC.Stack -- ----------------------------------------------------------------------------- -- STS and ProcessInfo -- ----------------------------------------------------------------------------- -data ProcessInfo =- MkProcessInfo- { _processInfoTitle :: !ProcessTitle- , _processInfoDetails :: !ProcessDetails- , _processInfoMessageQ :: !(Seq StrictDynamic)+data ProcessInfo = MkProcessInfo+ { _processInfoTitle :: !ProcessTitle,+ _processInfoDetails :: !ProcessDetails,+ _processInfoMessageQ :: !(Seq Message) } instance Show ProcessInfo where showsPrec d (MkProcessInfo pTitle pDetails pQ) = showParen (d >= 10)- (appEndo- (Endo (showChar ' ' . shows pTitle . showString ": ") <>- foldMap (Endo . showSTypeRep . dynTypeRep . unwrapStrictDynamic) (toList pQ) <>- Endo (shows pDetails))+ ( appEndo+ ( Endo (showChar ' ' . shows pTitle . showString ": ")+ <> Endo (showString " enqueued messages: " . shows (length pQ))+ <> Endo (shows pDetails)+ ) ) makeLenses ''ProcessInfo newProcessInfo :: ProcessTitle -> ProcessInfo-newProcessInfo t = MkProcessInfo t "" Seq.empty+newProcessInfo t = MkProcessInfo t (fromString "") Seq.empty data STS r m = STS- { _nextPid :: !ProcessId- , _nextRef :: !Int- , _msgQs :: !(Map.Map ProcessId ProcessInfo)- , _monitors :: !(Set.Set (MonitorReference, ProcessId))- , _processLinks :: !(Set.Set (ProcessId, ProcessId))- , _runEff :: forall a . Eff r a -> m a- , _yieldEff :: m ()+ { _nextPid :: !ProcessId,+ _nextRef :: !Int,+ _msgQs :: !(Map.Map ProcessId ProcessInfo),+ _monitors :: !(Set.Set (MonitorReference, ProcessId)),+ _processLinks :: !(Set.Set (ProcessId, ProcessId)),+ _runEff :: forall a. Eff r a -> m a,+ _yieldEff :: m () } -initStsMainProcess :: (forall a . Eff r a -> m a) -> m () -> STS r m-initStsMainProcess = STS 1 0 (Map.singleton 0 (newProcessInfo "init" )) Set.empty Set.empty+initStsMainProcess :: (forall a. Eff r a -> m a) -> m () -> STS r m+initStsMainProcess = STS 1 0 (Map.singleton 0 (newProcessInfo (fromString "init"))) Set.empty Set.empty makeLenses ''STS instance Show (STS r m) where- showsPrec d sts = showParen- (d >= 10)- ( showString "STS "- . showString "nextRef: "- . shows (_nextRef sts)- . showString " msgQs: "- . appEndo- (foldMap- (\(pid, p) ->- Endo (showChar ' ' . shows pid . showChar ' ' . shows p)- )- (sts ^.. msgQs . itraversed . withIndex)- )- )+ showsPrec d sts =+ showParen+ (d >= 10)+ ( showString "STS "+ . showString "nextRef: "+ . shows (_nextRef sts)+ . showString " msgQs: "+ . appEndo+ ( foldMap+ ( \(pid, p) ->+ Endo (showChar ' ' . shows pid . showChar ' ' . shows p)+ )+ (sts ^.. msgQs . itraversed . withIndex)+ )+ ) dropMsgQ :: ProcessId -> STS r m -> STS r m dropMsgQ pid = msgQs . at pid .~ Nothing@@ -109,44 +115,46 @@ getProcessStateFromScheduler pid sts = toPS <$> sts ^. msgQs . at pid where toPS p =- ( p ^. processInfoTitle- , p ^. processInfoDetails- , case p ^. processInfoMessageQ -- TODO get more detailed state- of+ ( p ^. processInfoTitle,+ p ^. processInfoDetails,+ case p ^. processInfoMessageQ of -- TODO get more detailed state _ :<| _ -> ProcessBusy- _ -> ProcessIdle)+ _ -> ProcessIdle+ ) incRef :: STS r m -> (Int, STS r m) incRef sts = (sts ^. nextRef, sts & nextRef %~ (+ 1)) -enqueueMsg :: ProcessId -> StrictDynamic -> STS r m -> STS r m+enqueueMsg :: ProcessId -> Message -> STS r m -> STS r m enqueueMsg toPid msg = msgQs . ix toPid . processInfoMessageQ %~ (:|> msg) newProcessQ :: Maybe ProcessId -> ProcessTitle -> STS r m -> (ProcessId, STS r m) newProcessQ parentLink title sts =- ( sts ^. nextPid- , let stsQ = sts & nextPid %~ (+ 1) & msgQs . at (sts ^. nextPid) ?~ newProcessInfo title+ ( sts ^. nextPid,+ let stsQ = sts & nextPid %~ (+ 1) & msgQs . at (sts ^. nextPid) ?~ newProcessInfo title in case parentLink of Nothing -> stsQ Just pid ->- let (Nothing, stsQL) = addLink pid (sts ^. nextPid) stsQ- in stsQL)+ case addLink pid (sts ^. nextPid) stsQ of+ (Nothing, stQL) -> stQL+ (Just _, _) -> error "TODO handle 'Just interrupt'"+ ) -flushMsgs :: ProcessId -> STS m r -> ([StrictDynamic], STS m r)+flushMsgs :: ProcessId -> STS m r -> ([Message], STS m r) flushMsgs pid = State.runState $ do msgs <- msgQs . ix pid . processInfoMessageQ <<.= Empty return (toList msgs) -receiveMsg- :: ProcessId -> MessageSelector a -> STS m r -> Maybe (Maybe (a, STS m r))+receiveMsg ::+ ProcessId -> MessageSelector a -> STS m r -> Maybe (Maybe (a, STS m r)) receiveMsg pid messageSelector sts = case sts ^? msgQs . at pid . _Just . processInfoMessageQ of Nothing -> Nothing Just msgQ -> Just $- case partitionMessages msgQ Empty of- Nothing -> Nothing- Just (result, otherMessages) -> Just (result, sts & msgQs . ix pid . processInfoMessageQ .~ otherMessages)+ case partitionMessages msgQ Empty of+ Nothing -> Nothing+ Just (result, otherMessages) -> Just (result, sts & msgQs . ix pid . processInfoMessageQ .~ otherMessages) where partitionMessages Empty _acc = Nothing partitionMessages (m :<| msgRest) acc =@@ -157,35 +165,37 @@ -- | Add monitor: If the process is dead, enqueue a 'ProcessDown' message into the -- owners message queue-addMonitoring- :: ProcessId -> ProcessId -> STS m r -> (MonitorReference, STS m r)+addMonitoring ::+ ProcessId -> ProcessId -> STS m r -> (MonitorReference, STS m r) addMonitoring owner target = State.runState $ do mi <- State.state incRef- let mref = MonitorReference mi target+ let mref = MkMonitorReference mi target when (target /= owner) $ do pt <- use msgQs if Map.member target pt then monitors %= Set.insert (mref, owner)- else let pdown = ProcessDown mref (ExitOtherProcessNotRunning target) target- in State.modify' (enqueueMsg owner (toStrictDynamic pdown))+ else+ let pdown = ProcessDown mref (ExitOtherProcessNotRunning target) target+ in State.modify' (enqueueMsg owner (toMessage pdown)) return mref removeMonitoring :: MonitorReference -> STS m r -> STS m r removeMonitoring mref = monitors %~ Set.filter (\(ref, _) -> ref /= mref) -triggerAndRemoveMonitor :: ProcessId -> Interrupt 'NoRecovery -> STS m r -> STS m r+triggerAndRemoveMonitor :: ProcessId -> ShutdownReason -> STS m r -> STS m r triggerAndRemoveMonitor downPid reason = State.execState $ do monRefs <- use monitors traverse_ go monRefs- where- go (mr, owner) = when- (monitoredProcess mr == downPid)- (let pdown = ProcessDown mr reason downPid- in State.modify' (enqueueMsg owner (toStrictDynamic pdown) . removeMonitoring mr)- )+ where+ go (mr, owner) =+ when+ (view monitoredProcess mr == downPid)+ ( let pdown = ProcessDown mr reason downPid+ in State.modify' (enqueueMsg owner (toMessage pdown) . removeMonitoring mr)+ ) -addLink :: ProcessId -> ProcessId -> STS m r -> (Maybe (Interrupt 'Recoverable), STS m r)+addLink :: ProcessId -> ProcessId -> STS m r -> (Maybe InterruptReason, STS m r) addLink fromPid toPid = State.runState $ do hasToPid <- use (msgQs . to (Map.member toPid)) if hasToPid@@ -207,7 +217,7 @@ kontinue :: STS r m -> (ResumeProcess a -> Eff r a1) -> a -> m a1 kontinue sts k x = (sts ^. runEff) (k (ResumeWith x)) -diskontinue :: STS r m -> (ResumeProcess v -> Eff r a) -> Interrupt 'Recoverable -> m a+diskontinue :: STS r m -> (ResumeProcess v -> Eff r a) -> InterruptReason -> m a diskontinue sts k e = (sts ^. runEff) (k (Interrupted e)) -- -----------------------------------------------------------------------------@@ -218,31 +228,32 @@ -- @schedulePure == runIdentity . 'scheduleM' (Identity . run) (return ())@ -- -- @since 0.3.0.2-schedulePure- :: Eff (Processes PureBaseEffects) a- -> Either (Interrupt 'NoRecovery) a+schedulePure ::+ Eff (Processes PureBaseEffects) a ->+ Either ShutdownReason a schedulePure e = run (scheduleM withoutLogging (return ()) e) -- | Invoke 'scheduleM' with @lift 'Control.Concurrent.yield'@ as yield effect. -- @scheduleIO runEff == 'scheduleM' (runLift . runEff) (liftIO 'yield')@ -- -- @since 0.4.0.0-scheduleIO- :: MonadIO m- => (forall b . Eff r b -> Eff '[Lift m] b)- -> Eff (Processes r) a- -> m (Either (Interrupt 'NoRecovery) a)+scheduleIO ::+ MonadIO m =>+ (forall b. Eff r b -> Eff '[Lift m] b) ->+ Eff (Processes r) a ->+ m (Either ShutdownReason a) scheduleIO r = scheduleM (runLift . r) (liftIO yield) -- | Invoke 'scheduleM' with @lift 'Control.Concurrent.yield'@ as yield effect. -- @scheduleMonadIOEff == 'scheduleM' id (liftIO 'yield')@ -- -- @since 0.3.0.2-scheduleMonadIOEff- :: MonadIO (Eff r)- => Eff (Processes r) a- -> Eff r (Either (Interrupt 'NoRecovery) a)-scheduleMonadIOEff = -- schedule (lift yield)+scheduleMonadIOEff ::+ MonadIO (Eff r) =>+ Eff (Processes r) a ->+ Eff r (Either ShutdownReason a)+scheduleMonadIOEff =+ -- schedule (lift yield) scheduleM id (liftIO yield) -- | Run processes that have the 'Logs' and the 'Lift' effects.@@ -253,11 +264,10 @@ -- @scheduleIOWithLogging == 'scheduleIO' . 'withLogging'@ -- -- @since 0.4.0.0-scheduleIOWithLogging- :: HasCallStack- => LogWriter- -> Eff EffectsIo a- -> IO (Either (Interrupt 'NoRecovery) a)+scheduleIOWithLogging ::+ LogWriter ->+ Eff EffectsIo a ->+ IO (Either ShutdownReason a) scheduleIOWithLogging h = scheduleIO (withLogging h) -- | Handle the 'Process' effect, as well as all lower effects using an effect handler function.@@ -276,15 +286,16 @@ -- endlessly. -- -- @since 0.4.0.0-scheduleM- :: forall m r a- . Monad m- => (forall b . Eff r b -> m b)- -> m () -- ^ An that performs a __yield__ w.r.t. the underlying effect+scheduleM ::+ forall m r a.+ Monad m =>+ (forall b. Eff r b -> m b) ->+ -- | An that performs a __yield__ w.r.t. the underlying effect -- @r@. E.g. if @Lift IO@ is present, this might be: -- @lift 'Control.Concurrent.yield'.- -> Eff (Processes r) a- -> m (Either (Interrupt 'NoRecovery) a)+ m () ->+ Eff (Processes r) a ->+ m (Either ShutdownReason a) scheduleM r y e = do c <- runAsCoroutinePure r (provideInterruptsShutdown e) handleProcess (initStsMainProcess r y) (Seq.singleton (c, 0))@@ -292,123 +303,138 @@ -- | Internal data structure that is part of the coroutine based scheduler -- implementation. data OnYield r a where- OnFlushMessages :: (ResumeProcess [StrictDynamic] -> Eff r (OnYield r a))- -> OnYield r a- OnYield :: (ResumeProcess () -> Eff r (OnYield r a))- -> OnYield r a- OnDelay :: Timeout- -> (ResumeProcess () -> Eff r (OnYield r a))- -> OnYield r a- OnSelf :: (ResumeProcess ProcessId -> Eff r (OnYield r a))- -> OnYield r a- OnSpawn :: Bool- -> ProcessTitle- -> Eff (Process r ': r) ()- -> (ResumeProcess ProcessId -> Eff r (OnYield r a))- -> OnYield r a+ OnFlushMessages ::+ (ResumeProcess [Message] -> Eff r (OnYield r a)) ->+ OnYield r a+ OnYield ::+ (ResumeProcess () -> Eff r (OnYield r a)) ->+ OnYield r a+ OnDelay ::+ Timeout ->+ (ResumeProcess () -> Eff r (OnYield r a)) ->+ OnYield r a+ OnSelf ::+ (ResumeProcess ProcessId -> Eff r (OnYield r a)) ->+ OnYield r a+ OnSpawn ::+ Bool ->+ ProcessTitle ->+ Eff (Process r ': r) () ->+ (ResumeProcess ProcessId -> Eff r (OnYield r a)) ->+ OnYield r a OnDone :: !a -> OnYield r a- OnShutdown :: Interrupt 'NoRecovery -> OnYield r a- OnInterrupt :: Interrupt 'Recoverable- -> (ResumeProcess b -> Eff r (OnYield r a))- -> OnYield r a- OnSend :: !ProcessId -> !StrictDynamic- -> (ResumeProcess () -> Eff r (OnYield r a))- -> OnYield r a- OnRecv :: MessageSelector b -> (ResumeProcess b -> Eff r (OnYield r a))- -> OnYield r a- OnGetProcessState- :: ProcessId- -> (ResumeProcess (Maybe (ProcessTitle, ProcessDetails, ProcessState)) -> Eff r (OnYield r a))- -> OnYield r a- OnUpdateProcessDetails- :: ProcessDetails- -> (ResumeProcess () -> Eff r (OnYield r a))- -> OnYield r a- OnSendShutdown :: !ProcessId -> Interrupt 'NoRecovery- -> (ResumeProcess () -> Eff r (OnYield r a)) -> OnYield r a- OnSendInterrupt :: !ProcessId -> Interrupt 'Recoverable- -> (ResumeProcess () -> Eff r (OnYield r a)) -> OnYield r a+ OnShutdown :: ShutdownReason -> OnYield r a+ OnInterrupt ::+ InterruptReason ->+ (ResumeProcess b -> Eff r (OnYield r a)) ->+ OnYield r a+ OnSend ::+ !ProcessId ->+ !Message ->+ (ResumeProcess () -> Eff r (OnYield r a)) ->+ OnYield r a+ OnRecv ::+ MessageSelector b ->+ (ResumeProcess b -> Eff r (OnYield r a)) ->+ OnYield r a+ OnGetProcessState ::+ ProcessId ->+ (ResumeProcess (Maybe (ProcessTitle, ProcessDetails, ProcessState)) -> Eff r (OnYield r a)) ->+ OnYield r a+ OnUpdateProcessDetails ::+ ProcessDetails ->+ (ResumeProcess () -> Eff r (OnYield r a)) ->+ OnYield r a+ OnSendShutdown ::+ !ProcessId ->+ ShutdownReason ->+ (ResumeProcess () -> Eff r (OnYield r a)) ->+ OnYield r a+ OnSendInterrupt ::+ !ProcessId ->+ InterruptReason ->+ (ResumeProcess () -> Eff r (OnYield r a)) ->+ OnYield r a OnMakeReference :: (ResumeProcess Int -> Eff r (OnYield r a)) -> OnYield r a- OnMonitor- :: ProcessId- -> (ResumeProcess MonitorReference -> Eff r (OnYield r a))- -> OnYield r a- OnDemonitor- :: MonitorReference- -> (ResumeProcess () -> Eff r (OnYield r a))- -> OnYield r a- OnLink- :: ProcessId- -> (ResumeProcess () -> Eff r (OnYield r a))- -> OnYield r a- OnUnlink- :: ProcessId- -> (ResumeProcess () -> Eff r (OnYield r a))- -> OnYield r a+ OnMonitor ::+ ProcessId ->+ (ResumeProcess MonitorReference -> Eff r (OnYield r a)) ->+ OnYield r a+ OnDemonitor ::+ MonitorReference ->+ (ResumeProcess () -> Eff r (OnYield r a)) ->+ OnYield r a+ OnLink ::+ ProcessId ->+ (ResumeProcess () -> Eff r (OnYield r a)) ->+ OnYield r a+ OnUnlink ::+ ProcessId ->+ (ResumeProcess () -> Eff r (OnYield r a)) ->+ OnYield r a -instance Show (OnYield r a) where- show = \case- OnFlushMessages _ -> "OnFlushMessages"- OnYield _ -> "OnYield"- OnDelay t _ -> "OnDelay " ++ show t- OnSelf _ -> "OnSelf"- OnSpawn False t _ _ -> "OnSpawn " ++ show t- OnSpawn True t _ _ -> "OnSpawn (link) " ++ show t- OnDone _ -> "OnDone"- OnShutdown e -> "OnShutdown " ++ show e- OnInterrupt e _ -> "OnInterrupt " ++ show e- OnSend toP _ _ -> "OnSend " ++ show toP- OnRecv _ _ -> "OnRecv"- OnGetProcessState p _ -> "OnGetProcessState " ++ show p- OnUpdateProcessDetails p _ -> "OnUpdateProcessDetails " ++ show p- OnSendShutdown p e _ -> "OnSendShutdow " ++ show p ++ " " ++ show e- OnSendInterrupt p e _ -> "OnSendInterrupt " ++ show p ++ " " ++ show e- OnMakeReference _ -> "OnMakeReference"- OnMonitor p _ -> "OnMonitor " ++ show p- OnDemonitor p _ -> "OnDemonitor " ++ show p- OnLink p _ -> "OnLink " ++ show p- OnUnlink p _ -> "OnUnlink " ++ show p+instance ToLogMsg (OnYield r a) where+ toLogMsg = \case+ OnFlushMessages _ -> packLogMsg "OnFlushMessages"+ OnYield _ -> packLogMsg "OnYield"+ OnDelay t _ -> packLogMsg "OnDelay " <> toLogMsg t+ OnSelf _ -> packLogMsg "OnSelf"+ OnSpawn False t _ _ -> packLogMsg "OnSpawn " <> toLogMsg t+ OnSpawn True t _ _ -> packLogMsg "OnSpawn (link) " <> toLogMsg t+ OnDone _ -> packLogMsg "OnDone"+ OnShutdown e -> packLogMsg "OnShutdown " <> toLogMsg e+ OnInterrupt e _ -> packLogMsg "OnInterrupt " <> toLogMsg e+ OnSend toP _ _ -> packLogMsg "OnSend " <> toLogMsg toP+ OnRecv _ _ -> packLogMsg "OnRecv"+ OnGetProcessState p _ -> packLogMsg "OnGetProcessState " <> toLogMsg p+ OnUpdateProcessDetails p _ -> packLogMsg "OnUpdateProcessDetails " <> coerce p+ OnSendShutdown p e _ -> packLogMsg "OnSendShutdow " <> toLogMsg p <> packLogMsg " " <> toLogMsg e+ OnSendInterrupt p e _ -> packLogMsg "OnSendInterrupt " <> toLogMsg p <> packLogMsg " " <> toLogMsg e+ OnMakeReference _ -> packLogMsg "OnMakeReference"+ OnMonitor p _ -> packLogMsg "OnMonitor " <> toLogMsg p+ OnDemonitor p _ -> packLogMsg "OnDemonitor " <> toLogMsg p+ OnLink p _ -> packLogMsg "OnLink " <> toLogMsg p+ OnUnlink p _ -> packLogMsg "OnUnlink " <> toLogMsg p -runAsCoroutinePure- :: forall v r m- . Monad m- => (forall a . Eff r a -> m a)- -> Eff (SafeProcesses r) v- -> m (OnYield r v)+runAsCoroutinePure ::+ forall v r m.+ (forall a. Eff r a -> m a) ->+ Eff (SafeProcesses r) v ->+ m (OnYield r v) runAsCoroutinePure r = r . fix (handle_relay' cont (return . OnDone))- where- cont :: (Eff (SafeProcesses r) v -> Eff r (OnYield r v))- -> Arrs (SafeProcesses r) x v- -> Process r x- -> Eff r (OnYield r v)- cont k q FlushMessages = return (OnFlushMessages (k . qApp q))- cont k q YieldProcess = return (OnYield (k . qApp q))- cont k q (Delay t) = return (OnDelay t (k . qApp q))- cont k q SelfPid = return (OnSelf (k . qApp q))- cont k q (Spawn t e ) = return (OnSpawn False t e (k . qApp q))- cont k q (SpawnLink t e ) = return (OnSpawn True t e (k . qApp q))- cont _ _ (Shutdown !sr ) = return (OnShutdown sr)- cont k q (SendMessage !tp !msg ) = return (OnSend tp msg (k . qApp q))- cont k q (ReceiveSelectedMessage f ) = return (OnRecv f (k . qApp q))- cont k q (GetProcessState !tp) = return (OnGetProcessState tp (k . qApp q))- cont k q (UpdateProcessDetails !td) = return (OnUpdateProcessDetails td (k . qApp q))- cont k q (SendInterrupt !tp !er ) = return (OnSendInterrupt tp er (k . qApp q))- cont k q (SendShutdown !pid !sr ) = return (OnSendShutdown pid sr (k . qApp q))- cont k q MakeReference = return (OnMakeReference (k . qApp q))- cont k q (Monitor !pid) = return (OnMonitor pid (k . qApp q))- cont k q (Demonitor !ref) = return (OnDemonitor ref (k . qApp q))- cont k q (Link !pid) = return (OnLink pid (k . qApp q))- cont k q (Unlink !pid) = return (OnUnlink pid (k . qApp q))+ where+ cont ::+ (Eff (SafeProcesses r) v -> Eff r (OnYield r v)) ->+ Arrs (SafeProcesses r) x v ->+ Process r x ->+ Eff r (OnYield r v)+ cont k q FlushMessages = return (OnFlushMessages (k . qApp q))+ cont k q YieldProcess = return (OnYield (k . qApp q))+ cont k q (Delay t) = return (OnDelay t (k . qApp q))+ cont k q SelfPid = return (OnSelf (k . qApp q))+ cont k q (Spawn t e) = return (OnSpawn False t e (k . qApp q))+ cont k q (SpawnLink t e) = return (OnSpawn True t e (k . qApp q))+ cont _ _ (Shutdown !sr) = return (OnShutdown sr)+ cont k q (SendMessage !tp !msg) = return (OnSend tp msg (k . qApp q))+ cont k q (ReceiveSelectedMessage f) = return (OnRecv f (k . qApp q))+ cont k q (GetProcessState !tp) = return (OnGetProcessState tp (k . qApp q))+ cont k q (UpdateProcessDetails !td) = return (OnUpdateProcessDetails td (k . qApp q))+ cont k q (SendInterrupt !tp !er) = return (OnSendInterrupt tp er (k . qApp q))+ cont k q (SendShutdown !pid !sr) = return (OnSendShutdown pid sr (k . qApp q))+ cont k q MakeReference = return (OnMakeReference (k . qApp q))+ cont k q (Monitor !pid) = return (OnMonitor pid (k . qApp q))+ cont k q (Demonitor !ref) = return (OnDemonitor ref (k . qApp q))+ cont k q (Link !pid) = return (OnLink pid (k . qApp q))+ cont k q (Unlink !pid) = return (OnUnlink pid (k . qApp q)) -- | Internal 'Process' handler function.-handleProcess- :: Monad m- => STS r m- -> Seq (OnYield r finalResult, ProcessId)- -> m (Either (Interrupt 'NoRecovery) finalResult)+handleProcess ::+ Monad m =>+ STS r m ->+ Seq (OnYield r finalResult, ProcessId) ->+ m (Either ShutdownReason finalResult) handleProcess _sts Empty =- return $ Left (interruptToExit (ErrorInterrupt "no main process"))-+ return $ Left (interruptToExit (ErrorInterrupt (fromString "no main process"))) handleProcess sts allProcs@((!processState, !pid) :<| rest) = let handleExit res = if pid == 0@@ -424,20 +450,23 @@ Right _ -> return ps' Left er -> case toExitSeverity er of- NormalExit -> return ps'- Crash -> sendInterruptToOtherPid dPid reason ps'-+ ExitSuccess -> return ps'+ Crash -> sendInterruptToOtherPid dPid reason ps' let allButMe = Seq.filter (\(_, p) -> p /= pid) rest nextTargets <- unlinkLoop linkedPids allButMe handleProcess- (dropMsgQ- pid- (triggerAndRemoveMonitor+ ( dropMsgQ pid- (either- id- (const ExitNormally) res)- stsNew))+ ( triggerAndRemoveMonitor+ pid+ ( either+ id+ (const ExitNormally)+ res+ )+ stsNew+ )+ ) nextTargets in case processState of OnDone r -> handleExit (Right r)@@ -503,9 +532,10 @@ OnSpawn link title f k -> do let (newPid, newSts) = newProcessQ- (if link- then Just pid- else Nothing)+ ( if link+ then Just pid+ else Nothing+ ) title sts fk <- runAsCoroutinePure (newSts ^. runEff) (f >> exitNormally)@@ -516,20 +546,20 @@ nextK <- kontinue newSts k msgs handleProcess newSts (rest :|> (nextK, pid)) OnDelay t k ->- if t <= 0 then do- nextK <- kontinue sts k ()- handleProcess sts (rest :|> (nextK, pid))- else- handleProcess sts (rest :|> (OnDelay (t - 1) k, pid))+ if t <= 0+ then do+ nextK <- kontinue sts k ()+ handleProcess sts (rest :|> (nextK, pid))+ else handleProcess sts (rest :|> (OnDelay (t - 1) k, pid)) recv@(OnRecv messageSelector k) -> case receiveMsg pid messageSelector sts of Nothing -> do- nextK <- diskontinue sts k (ErrorInterrupt (show pid ++ " has no message queue"))+ nextK <- diskontinue sts k (ErrorInterrupt (toLogMsg pid <> packLogMsg " has no message queue")) handleProcess sts (rest :|> (nextK, pid)) Just Nothing -> if Seq.length rest == 0 then do- nextK <- diskontinue sts k (ErrorInterrupt (show pid ++ " deadlocked"))+ nextK <- diskontinue sts k (ErrorInterrupt (toLogMsg pid <> packLogMsg " deadlocked")) handleProcess sts (rest :|> (nextK, pid)) else handleProcess sts (rest :|> (recv, pid)) Just (Just (result, newSts)) -> do@@ -598,28 +628,27 @@ -- All logging is written to the console using 'consoleLogWriter'. -- -- To use another 'LogWriter' use 'defaultMainWithLogWriter' instead.-defaultMain :: HasCallStack => Eff EffectsIo () -> IO ()+defaultMain :: Eff EffectsIo () -> IO () defaultMain e =- consoleLogWriter >>=- (\lw ->- void- . runLift- . withLogging lw- . scheduleMonadIOEff- $ e)-+ consoleLogWriter+ >>= ( \lw ->+ void+ . runLift+ . withLogging lw+ . scheduleMonadIOEff+ $ e+ ) -- | Execute a 'Process' using 'scheduleM' on top of 'Lift' @IO@. -- All logging is written using the given 'LogWriter'. -- -- @since 0.25.0-defaultMainWithLogWriter :: HasCallStack => LogWriter -> Eff EffectsIo () -> IO ()+defaultMainWithLogWriter :: LogWriter -> Eff EffectsIo () -> IO () defaultMainWithLogWriter lw = void . runLift . withLogging lw . scheduleMonadIOEff- -- | The effect list for 'Process' effects in the single threaded pure scheduler. --
src/Control/Eff/Concurrent/Process/Timer.hs view
@@ -1,51 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+ -- | Functions for receive timeouts and delayed messages sending. -- -- Based on the 'delay' function. -- -- @since 0.12.0 module Control.Eff.Concurrent.Process.Timer- ( TimerReference()- , TimerElapsed(fromTimerElapsed)- , sendAfter- , startTimer- , sendAfterWithTitle- , startTimerWithTitle- , cancelTimer- , selectTimerElapsed- , receiveAfter- , receiveSelectedAfter- , receiveSelectedWithMonitorAfter- , receiveAfterWithTitle- , receiveSelectedAfterWithTitle- , receiveSelectedWithMonitorAfterWithTitle+ ( TimerReference (),+ TimerElapsed (fromTimerElapsed),+ sendAfter,+ startTimer,+ sendAfterWithTitle,+ sendAfterWithTitleAndLogMsg,+ startTimerWithTitle,+ cancelTimer,+ selectTimerElapsed,+ receiveAfter,+ receiveSelectedAfter,+ receiveSelectedWithMonitorAfter,+ receiveAfterWithTitle,+ receiveSelectedAfterWithTitle,+ receiveSelectedWithMonitorAfterWithTitle, )- where -import Control.Eff.Concurrent.Process-import Control.Eff.Concurrent.Misc-import Control.Eff-import Control.DeepSeq-import Data.Typeable-import Data.Text as T-import Control.Applicative-import GHC.Stack+import Control.Applicative+import Control.DeepSeq+import Control.Eff+import Control.Eff.Concurrent.Process+import Control.Eff.Log.Handler+import Control.Eff.Log.Message+import Data.Foldable+import Data.Proxy+import Data.Typeable+import GHC.Stack -- | Wait for a message of the given type for the given time. When no message -- arrives in time, return 'Nothing'. This is based on -- 'receiveSelectedAfter'. -- -- @since 0.12.0-receiveAfter- :: forall a r q- . ( HasCallStack- , HasProcesses r q- , Typeable a- , NFData a- , Show a- )- => Timeout- -> Eff r (Maybe a)+receiveAfter ::+ forall a r q.+ ( HasCallStack,+ HasProcesses r q,+ Member Logs q,+ Typeable a+ ) =>+ Timeout ->+ Eff r (Maybe a) receiveAfter t = either (const Nothing) Just <$> receiveSelectedAfter (selectMessage @a) t @@ -54,73 +58,64 @@ -- 'selectTimerElapsed' and 'startTimer'. -- -- @since 0.12.0-receiveSelectedAfter- :: forall a r q- . ( HasCallStack- , HasProcesses r q- , Show a- , Typeable a- )- => MessageSelector a- -> Timeout- -> Eff r (Either TimerElapsed a)+receiveSelectedAfter ::+ forall a r q.+ ( HasCallStack,+ HasProcesses r q,+ Member Logs q+ ) =>+ MessageSelector a ->+ Timeout ->+ Eff r (Either TimerElapsed a) receiveSelectedAfter sel t = do- let timerTitle =- MkProcessTitle- ("receive-timer-"- <> pack (showSTypeable @a "")- <> "-"- <> pack (show t)- )+ let timerTitle = MkProcessTitle "receive-timer" timerRef <- startTimerWithTitle timerTitle t- res <- receiveSelectedMessage- (Left <$> selectTimerElapsed timerRef <|> Right <$> sel)+ res <-+ receiveSelectedMessage+ (Left <$> selectTimerElapsed timerRef <|> Right <$> sel) cancelTimer timerRef return res -- | Like 'receiveWithMonitor' combined with 'receiveSelectedAfter'. -- -- @since 0.22.0-receiveSelectedWithMonitorAfter- :: forall a r q- . ( HasCallStack- , HasProcesses r q- , Show a- , Typeable a- )- => ProcessId- -> MessageSelector a- -> Timeout- -> Eff r (Either (Either ProcessDown TimerElapsed) a)-receiveSelectedWithMonitorAfter pid sel t =- let timerTitle =- MkProcessTitle- ("receive-timer-"- <> pack (showSTypeable @a "")- <> "-monitoring-"- <> pack (show pid)- <> "-"- <> pack (show t)- )- in receiveSelectedWithMonitorAfterWithTitle pid sel t timerTitle-+receiveSelectedWithMonitorAfter ::+ forall a r q.+ ( HasCallStack,+ HasProcesses r q,+ Member Logs q,+ Member Logs r,+ ToTypeLogMsg a+ ) =>+ ProcessId ->+ MessageSelector a ->+ Timeout ->+ Eff r (Either (Either ProcessDown TimerElapsed) a)+receiveSelectedWithMonitorAfter pid sel t = do+ fromPid <- self+ let timerTitle = MkProcessTitle "receive-timeout"+ initialLog =+ packLogMsg "receice-timeout receiver: "+ <> toLogMsg fromPid+ <> packLogMsg " expected message type: "+ <> toTypeLogMsg (Proxy @a)+ receiveSelectedWithMonitorAfterWithTitle pid sel t timerTitle initialLog -- | Wait for a message of the given type for the given time. When no message -- arrives in time, return 'Nothing'. This is based on -- 'receiveSelectedAfterWithTitle'. -- -- @since 0.12.0-receiveAfterWithTitle- :: forall a r q- . ( HasCallStack- , HasProcesses r q- , Typeable a- , NFData a- , Show a- )- => Timeout- -> ProcessTitle- -> Eff r (Maybe a)+receiveAfterWithTitle ::+ forall a r q.+ ( HasCallStack,+ HasProcesses r q,+ Member Logs q,+ Typeable a+ ) =>+ Timeout ->+ ProcessTitle ->+ Eff r (Maybe a) receiveAfterWithTitle t timerTitle = either (const Nothing) Just <$> receiveSelectedAfterWithTitle (selectMessage @a) t timerTitle @@ -129,47 +124,50 @@ -- 'selectTimerElapsed' and 'startTimerWithTitle'. -- -- @since 0.12.0-receiveSelectedAfterWithTitle- :: forall a r q- . ( HasCallStack- , HasProcesses r q- , Show a- , Typeable a- )- => MessageSelector a- -> Timeout- -> ProcessTitle- -> Eff r (Either TimerElapsed a)+receiveSelectedAfterWithTitle ::+ forall a r q.+ ( HasCallStack,+ HasProcesses r q,+ Member Logs q+ ) =>+ MessageSelector a ->+ Timeout ->+ ProcessTitle ->+ Eff r (Either TimerElapsed a) receiveSelectedAfterWithTitle sel t timerTitle = do timerRef <- startTimerWithTitle timerTitle t- res <- receiveSelectedMessage- (Left <$> selectTimerElapsed timerRef <|> Right <$> sel)+ res <-+ receiveSelectedMessage+ (Left <$> selectTimerElapsed timerRef <|> Right <$> sel) cancelTimer timerRef return res -- | Like 'receiveWithMonitorWithTitle' combined with 'receiveSelectedAfterWithTitle'. -- -- @since 0.30.0-receiveSelectedWithMonitorAfterWithTitle- :: forall a r q- . ( HasCallStack- , HasProcesses r q- , Show a- , Typeable a- )- => ProcessId- -> MessageSelector a- -> Timeout- -> ProcessTitle- -> Eff r (Either (Either ProcessDown TimerElapsed) a)-receiveSelectedWithMonitorAfterWithTitle pid sel t timerTitle = do+receiveSelectedWithMonitorAfterWithTitle ::+ forall a r q.+ ( HasCallStack,+ HasProcesses r q,+ Member Logs q,+ Member Logs r+ ) =>+ ProcessId ->+ MessageSelector a ->+ Timeout ->+ ProcessTitle ->+ LogMsg ->+ Eff r (Either (Either ProcessDown TimerElapsed) a)+receiveSelectedWithMonitorAfterWithTitle pid sel t timerTitle initialLogMsg = do timerRef <- startTimerWithTitle timerTitle t- res <- withMonitor pid $ \pidMon -> do- receiveSelectedMessage- ( Left . Left <$> selectProcessDown pidMon- <|> Left . Right <$> selectTimerElapsed timerRef- <|> Right <$> sel- )+ logDebug (LABEL "started" timerRef)+ logDebug initialLogMsg+ res <- withMonitor pid $ \pidMon -> do+ receiveSelectedMessage+ ( Left . Left <$> selectProcessDown pidMon+ <|> Left . Right <$> selectTimerElapsed timerRef+ <|> Right <$> sel+ ) cancelTimer timerRef return res @@ -186,41 +184,43 @@ -- -- @since 0.12.0 newtype TimerReference = TimerReference ProcessId- deriving (NFData, Ord,Eq, Num, Integral, Real, Enum, Typeable)+ deriving (NFData, Ord, Eq, Num, Integral, Real, Enum, Typeable) -instance Show TimerReference where- showsPrec d (TimerReference t) =- showParen (d >= 10) (showString "timer: " . shows t)+instance ToLogMsg TimerReference where+ toLogMsg (TimerReference p) = "timer-ref" <> toLogMsg p -- | A value to be sent when timer started with 'startTimer' has elapsed. -- -- @since 0.12.0 newtype TimerElapsed = TimerElapsed {fromTimerElapsed :: TimerReference}- deriving (NFData, Ord,Eq, Typeable)+ deriving (NFData, Ord, Eq, Typeable) -instance Show TimerElapsed where- showsPrec d (TimerElapsed t) =- showParen (d >= 10) (shows t . showString " elapsed")--+instance ToTypeLogMsg TimerElapsed where+ toTypeLogMsg _ = "timer-elapsed" +instance ToLogMsg TimerElapsed where+ toLogMsg x = packLogMsg "elapsed: " <> toLogMsg (fromTimerElapsed x)+ -- | Send a message to a given process after waiting. The message is created by -- applying the function parameter to the 'TimerReference', such that the -- message can directly refer to the timer. -- -- @since 0.12.0-sendAfter- :: forall r q message- . ( HasCallStack- , HasProcesses r q- , Typeable message- , NFData message- )- => ProcessId- -> Timeout- -> (TimerReference -> message)- -> Eff r TimerReference+sendAfter ::+ forall r q message.+ ( HasCallStack,+ HasProcesses r q,+ Typeable message,+ NFData message,+ Member Logs q+ ) =>+ ProcessId ->+ Timeout ->+ (TimerReference -> message) ->+ Eff r TimerReference sendAfter pid t mkMsg = sendAfterWithTitle- (MkProcessTitle ("send-after-timer-" <> T.pack (show t) <> "-" <> T.pack (showSTypeable @message "") <> "-" <> T.pack (show pid)))+ (MkProcessTitle "send-after-timer") pid t mkMsg@@ -228,26 +228,73 @@ -- | Like 'sendAfter' but with a user provided name for the timer process. -- -- @since 0.30.0-sendAfterWithTitle- :: forall r q message- . ( HasCallStack- , HasProcesses r q- , Typeable message- , NFData message- )- => ProcessTitle- -> ProcessId- -> Timeout- -> (TimerReference -> message)- -> Eff r TimerReference-sendAfterWithTitle title pid t mkMsg =- TimerReference <$>- (spawn- title- (delay t- >> self- >>= (sendMessage pid . force . mkMsg . TimerReference)))+sendAfterWithTitle ::+ forall r q message.+ ( HasCallStack,+ HasProcesses r q,+ Typeable message,+ NFData message,+ Member Logs q+ ) =>+ ProcessTitle ->+ ProcessId ->+ Timeout ->+ (TimerReference -> message) ->+ Eff r TimerReference+sendAfterWithTitle = sendAfterWithTitleAndMaybeLogMsg Nothing +-- | Like 'sendAfterWithTitle' but with a user provided initial debug `LogMsg`.+--+-- @since 1.0.0+sendAfterWithTitleAndLogMsg ::+ forall r q message.+ ( HasCallStack,+ HasProcesses r q,+ Member Logs q,+ Typeable message,+ NFData message+ ) =>+ LogMsg ->+ ProcessTitle ->+ ProcessId ->+ Timeout ->+ (TimerReference -> message) ->+ Eff r TimerReference+sendAfterWithTitleAndLogMsg =+ sendAfterWithTitleAndMaybeLogMsg . Just++-- | Like 'sendAfterWithTitle' but with a user provided, optional initial debug `LogMsg`.+--+-- @since 1.0.0+sendAfterWithTitleAndMaybeLogMsg ::+ forall r q message.+ ( HasCallStack,+ HasProcesses r q,+ Member Logs q,+ Typeable message,+ NFData message+ ) =>+ Maybe LogMsg ->+ ProcessTitle ->+ ProcessId ->+ Timeout ->+ (TimerReference -> message) ->+ Eff r TimerReference+sendAfterWithTitleAndMaybeLogMsg initialLogMsg title pid t mkMsg =+ TimerReference+ <$> ( spawn+ title+ ( do+ traverse_ logDebug initialLogMsg+ me <- self+ let meRef = TimerReference me+ logDebug (LABEL "timer started" title) pid t meRef+ delay t+ logDebug (LABEL "timer elapsed" title) pid t meRef+ sendMessage pid (force (mkMsg meRef))+ )+ )+ -- | Start a new timer, after the time has elapsed, 'TimerElapsed' is sent to -- calling process. The message also contains the 'TimerReference' returned by -- this function. Use 'cancelTimer' to cancel the timer. Use@@ -258,14 +305,15 @@ -- message. -- -- @since 0.30.0-startTimerWithTitle- :: forall r q- . ( HasCallStack- , HasProcesses r q- )- => ProcessTitle- -> Timeout- -> Eff r TimerReference -- TODO add a parameter to the TimerReference+startTimerWithTitle ::+ forall r q.+ ( HasCallStack,+ Member Logs q,+ HasProcesses r q+ ) =>+ ProcessTitle ->+ Timeout ->+ Eff r TimerReference -- TODO add a parameter to the TimerReference startTimerWithTitle title t = do p <- self sendAfterWithTitle title p t TimerElapsed@@ -279,13 +327,14 @@ -- Calls 'sendAfter' under the hood. -- -- @since 0.12.0-startTimer- :: forall r q- . ( HasCallStack- , HasProcesses r q- )- => Timeout- -> Eff r TimerReference -- TODO add a parameter to the TimerReference+startTimer ::+ forall r q.+ ( HasCallStack,+ HasProcesses r q,+ Member Logs q+ ) =>+ Timeout ->+ Eff r TimerReference -- TODO add a parameter to the TimerReference startTimer t = do p <- self sendAfter p t TimerElapsed@@ -293,11 +342,6 @@ -- | Cancel a timer started with 'startTimer'. -- -- @since 0.12.0-cancelTimer- :: forall r q- . ( HasCallStack- , HasProcesses r q- )- => TimerReference- -> Eff r ()+cancelTimer ::+ forall r q. HasProcesses r q => TimerReference -> Eff r () cancelTimer (TimerReference tr) = sendShutdown tr ExitNormally
src/Control/Eff/Concurrent/Protocol.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+ -- | Types and functions for type-safe(er) interaction between processes. -- -- All messages sent between processes are eventually converted to 'Dynamic' values@@ -33,36 +36,31 @@ -- -- To enable a process to use such a /service/, the functions provided in -- "Control.Eff.Concurrent.Protocol.Client" should be used.--- module Control.Eff.Concurrent.Protocol- ( HasPdu(..)- , deserializePdu- , Embeds- , Pdu(..)- , Synchronicity(..)- , ProtocolReply- , Tangible- , TangiblePdu- , Endpoint(..)- , fromEndpoint- , proxyAsEndpoint- , asEndpoint- , HasPduPrism(..)- , toEmbeddedEndpoint- , fromEmbeddedEndpoint+ ( HasPdu (..),+ deserializePdu,+ Embeds,+ Pdu (..),+ Synchronicity (..),+ ProtocolReply,+ Tangible,+ TangiblePdu,+ Endpoint (..),+ fromEndpoint,+ proxyAsEndpoint,+ asEndpoint,+ HasPduPrism (..), ) where -import Control.Eff.Concurrent.Misc-import Control.DeepSeq-import Control.Eff.Concurrent.Process-import Control.Lens-import Data.Dynamic-import Data.Kind-import Data.Typeable ()-import Data.Type.Pretty-import Type.Reflection-+import Control.DeepSeq+import Control.Eff.Concurrent.Process+import Control.Eff.Log.Message+import Control.Lens+import Data.Dynamic+import Data.Kind+import Data.Proxy+import Data.Typeable () -- | A server process for /protocol/. --@@ -75,14 +73,16 @@ -- -- As a metaphor, communication between processes can be thought of waiting for -- and sending __protocol data units__ belonging to some protocol.-newtype Endpoint protocol = Endpoint { _fromEndpoint :: ProcessId }- deriving (Eq,Ord,Typeable, NFData)+newtype Endpoint protocol = Endpoint {_fromEndpoint :: ProcessId}+ deriving (Eq, Ord, Typeable, NFData) -instance Typeable protocol => Show (Endpoint protocol) where- showsPrec d (Endpoint c) =- showParen (d>=10)- (showSTypeRep (SomeTypeRep (typeRep @protocol)) . showsPrec 10 c)+instance forall protocol. ToTypeLogMsg protocol => ToTypeLogMsg (Endpoint protocol) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @protocol) <> "_ep" +instance ToTypeLogMsg protocol => ToLogMsg (Endpoint protocol) where+ toLogMsg (Endpoint pid) =+ toTypeLogMsg (Proxy @protocol) <> toLogMsg pid+ -- | This type class and the associated data family defines the -- __protocol data units__ (PDU) of a /protocol/. --@@ -92,7 +92,7 @@ -- The first parameter is usually a user defined type that identifies the -- protocol that uses the 'Pdu's are. It maybe a /phantom/ type. ----- The second parameter specifies if a specific constructor of an (GADT-like)+-- The second parameter of the 'Pdu' family specifies if a specific constructor of an (GADT-like) -- @Pdu@ instance is 'Synchronous', i.e. returns a result and blocks the caller -- or if it is 'Asynchronous' --@@ -101,7 +101,7 @@ -- > -- > data BookShop deriving Typeable -- >--- > instance Typeable r => HasPdu BookShop r where+-- > instance HasPdu BookShop where -- > data instance Pdu BookShop r where -- > RentBook :: BookId -> Pdu BookShop ('Synchronous (Either RentalError RentalId)) -- > BringBack :: RentalId -> Pdu BookShop 'Asynchronous@@ -111,7 +111,17 @@ -- > type RentalId = Int -- > type RentalError = String -- >+-- > instance ToTypeLogMsg BookShop+-- >+-- > instance ToLogMsg (Pdu BookShop r) where+-- > toLogMsg = \case+-- > RentBook bId -> packLogMsg "rent: " <> toLogMsg bId+-- > BringBack bId -> packLogMsg "return: " <> toLogMsg bId+-- > --+-- Note the 'ToTypeLogMsg' and 'ToLogMsg' instances.+-- These are often required in many places throughout this library.+-- -- @since 0.25.1 class Typeable protocol => HasPdu (protocol :: Type) where -- | A type level list Protocol phantom types included in the associated 'Pdu' instance.@@ -120,11 +130,12 @@ -- It relies on 'Embeds' to add the constraint 'HasPduPrism'. -- -- @since 0.29.0- type family EmbeddedPduList protocol :: [Type]- type instance EmbeddedPduList protocol = '[]+ type EmbeddedPduList protocol :: [Type] + type EmbeddedPduList protocol = '[]+ -- | The __protocol data unit__ type for the given protocol.- data family Pdu protocol (reply :: Synchronicity)+ data Pdu protocol (reply :: Synchronicity) -- | Deserialize a 'Pdu' from a 'Dynamic' i.e. from a message received by a process. --@@ -149,9 +160,9 @@ -- -- @since 0.29.1 type Embeds outer inner =- ( HasPduPrism outer inner- , CheckEmbeds outer inner- , HasPdu outer+ ( HasPduPrism outer inner,+ CheckEmbeds outer inner,+ HasPdu outer ) -- ---------- Type Machinery:@@ -162,30 +173,22 @@ inner (EmbeddedPduList outer) (EmbeddedPduList outer)- ~ 'IsEmbeddedProtocol+ ~ 'IsEmbeddedProtocol -data IsEmbeddedProtocol k = IsEmbeddedProtocol | IsNotAnEmbeddedProtocol k [k]+data IsEmbeddedProtocol k = IsEmbeddedProtocol | IsNotAnEmbeddedProtocol k [k] type family IsProtocolOneOf (x :: k) (xs :: [k]) (orig :: [k]) :: IsEmbeddedProtocol k where IsProtocolOneOf x '[] orig = 'IsNotAnEmbeddedProtocol x orig IsProtocolOneOf x (x ': xs) orig = 'IsEmbeddedProtocol IsProtocolOneOf x (y ': xs) orig = IsProtocolOneOf x xs orig --- -----------------------------type instance ToPretty (Pdu x y) =- PrettySurrounded (PutStr "<") (PutStr ">") ("protocol" <:> ToPretty x <+> ToPretty y)---- | A set of constraints for types that can evaluated via 'NFData', compared via 'Ord' and presented--- dynamically via 'Typeable', and represented both as values--- via 'Show'.+-- | A set of constraints for types that can evaluated via 'NFData' and presented+-- dynamically via 'Typeable'. -- -- @since 0.23.0 type Tangible i =- ( NFData i- , Typeable i- , Show i+ ( NFData i,+ Typeable i ) -- | A 'Constraint' that bundles the requirements for the@@ -196,20 +199,24 @@ -- -- @since 0.24.0 type TangiblePdu p r =- ( Typeable p- , Typeable r- , Tangible (Pdu p r)- , HasPdu p+ ( Typeable p,+ Typeable r,+ Tangible (Pdu p r),+ HasPdu p,+ ToTypeLogMsg p,+ ToLogMsg (Pdu p r) ) -- | The (promoted) constructors of this type specify (at the type level) the -- reply behavior of a specific constructor of an @Pdu@ instance.-data Synchronicity =- Synchronous Type -- ^ Specify that handling a request is a blocking operation- -- with a specific return type, e.g. @('Synchronous (Either- -- RentalError RentalId))@- | Asynchronous -- ^ Non-blocking, asynchronous, request handling- deriving Typeable+data Synchronicity+ = -- | Specify that handling a request is a blocking operation+ -- with a specific return type, e.g. @('Synchronous (Either+ -- RentalError RentalId))@+ Synchronous Type+ | -- | Non-blocking, asynchronous, request handling+ Asynchronous+ deriving (Typeable) -- | This type function takes an 'Pdu' and analysis the reply type, i.e. the 'Synchronicity' -- and evaluates to either @t@ for an@@ -220,39 +227,58 @@ ProtocolReply ('Synchronous t) = t ProtocolReply 'Asynchronous = () -type instance ToPretty (Endpoint a) = ToPretty a <+> PutStr "endpoint"-- instance (HasPdu a1, HasPdu a2) => HasPdu (a1, a2) where- type instance EmbeddedPduList (a1, a2) = '[a1, a2]- data instance Pdu (a1, a2) r where- ToPduLeft :: Pdu a1 r -> Pdu (a1, a2) r- ToPduRight :: Pdu a2 r -> Pdu (a1, a2) r+ type EmbeddedPduList (a1, a2) = '[a1, a2]+ data Pdu (a1, a2) r where+ ToPduLeft :: Pdu a1 r -> Pdu (a1, a2) r+ ToPduRight :: Pdu a2 r -> Pdu (a1, a2) r +instance (ToLogMsg (Pdu a1 r), ToLogMsg (Pdu a2 r)) => ToLogMsg (Pdu (a1, a2) r) where+ toLogMsg (ToPduLeft a1) = toLogMsg a1+ toLogMsg (ToPduRight a2) = toLogMsg a2+ instance (HasPdu a1, HasPdu a2, HasPdu a3) => HasPdu (a1, a2, a3) where- type instance EmbeddedPduList (a1, a2, a3) = '[a1, a2, a3]- data instance Pdu (a1, a2, a3) r where+ type EmbeddedPduList (a1, a2, a3) = '[a1, a2, a3]+ data Pdu (a1, a2, a3) r where ToPdu1 :: Pdu a1 r -> Pdu (a1, a2, a3) r ToPdu2 :: Pdu a2 r -> Pdu (a1, a2, a3) r ToPdu3 :: Pdu a3 r -> Pdu (a1, a2, a3) r +instance (ToLogMsg (Pdu a1 r), ToLogMsg (Pdu a2 r), ToLogMsg (Pdu a3 r)) => ToLogMsg (Pdu (a1, a2, a3) r) where+ toLogMsg (ToPdu1 a1) = toLogMsg a1+ toLogMsg (ToPdu2 a2) = toLogMsg a2+ toLogMsg (ToPdu3 a3) = toLogMsg a3+ instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4) => HasPdu (a1, a2, a3, a4) where- type instance EmbeddedPduList (a1, a2, a3, a4) = '[a1, a2, a3, a4]- data instance Pdu (a1, a2, a3, a4) r where+ type EmbeddedPduList (a1, a2, a3, a4) = '[a1, a2, a3, a4]+ data Pdu (a1, a2, a3, a4) r where ToPdu1Of4 :: Pdu a1 r -> Pdu (a1, a2, a3, a4) r ToPdu2Of4 :: Pdu a2 r -> Pdu (a1, a2, a3, a4) r ToPdu3Of4 :: Pdu a3 r -> Pdu (a1, a2, a3, a4) r ToPdu4Of4 :: Pdu a4 r -> Pdu (a1, a2, a3, a4) r +instance (ToLogMsg (Pdu a1 r), ToLogMsg (Pdu a2 r), ToLogMsg (Pdu a3 r), ToLogMsg (Pdu a4 r)) => ToLogMsg (Pdu (a1, a2, a3, a4) r) where+ toLogMsg (ToPdu1Of4 a1) = toLogMsg a1+ toLogMsg (ToPdu2Of4 a2) = toLogMsg a2+ toLogMsg (ToPdu3Of4 a3) = toLogMsg a3+ toLogMsg (ToPdu4Of4 a4) = toLogMsg a4+ instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4, HasPdu a5) => HasPdu (a1, a2, a3, a4, a5) where- type instance EmbeddedPduList (a1, a2, a3, a4, a5) = '[a1, a2, a3, a4, a5]- data instance Pdu (a1, a2, a3, a4, a5) r where+ type EmbeddedPduList (a1, a2, a3, a4, a5) = '[a1, a2, a3, a4, a5]+ data Pdu (a1, a2, a3, a4, a5) r where ToPdu1Of5 :: Pdu a1 r -> Pdu (a1, a2, a3, a4, a5) r ToPdu2Of5 :: Pdu a2 r -> Pdu (a1, a2, a3, a4, a5) r ToPdu3Of5 :: Pdu a3 r -> Pdu (a1, a2, a3, a4, a5) r ToPdu4Of5 :: Pdu a4 r -> Pdu (a1, a2, a3, a4, a5) r ToPdu5Of5 :: Pdu a5 r -> Pdu (a1, a2, a3, a4, a5) r +instance (ToLogMsg (Pdu a1 r), ToLogMsg (Pdu a2 r), ToLogMsg (Pdu a3 r), ToLogMsg (Pdu a4 r), ToLogMsg (Pdu a5 r)) => ToLogMsg (Pdu (a1, a2, a3, a4, a5) r) where+ toLogMsg (ToPdu1Of5 a1) = toLogMsg a1+ toLogMsg (ToPdu2Of5 a2) = toLogMsg a2+ toLogMsg (ToPdu3Of5 a3) = toLogMsg a3+ toLogMsg (ToPdu4Of5 a4) = toLogMsg a4+ toLogMsg (ToPdu5Of5 a5) = toLogMsg a5+ -- | Tag a 'ProcessId' with an 'Pdu' type index to mark it a 'Endpoint' process -- handling that API proxyAsEndpoint :: proxy protocol -> ProcessId -> Endpoint protocol@@ -260,63 +286,67 @@ -- | Tag a 'ProcessId' with an 'Pdu' type index to mark it a 'Endpoint' process -- handling that API-asEndpoint :: forall protocol . ProcessId -> Endpoint protocol+asEndpoint :: forall protocol. ProcessId -> Endpoint protocol asEndpoint = Endpoint ----- | A class for 'Pdu' instances that embed other 'Pdu'.+-- | A class for 'Pdu' instances that embeds other 'Pdu' instances. ----- This is a part of 'Embeds' provide instances for your--- 'Pdu's but in client code use the 'Embeds' constraint.+-- Example: --+-- > data Parent deriving Typeable+-- > data Child deriving Typeable+-- >+-- > instance HasPduPrism Parent Child where+-- > embedPdu = Delegate+-- > fromPdu (Delegate x) = Just x+-- > fromPdu _ = Nothing+-- >+-- > instance HasPdu Parent where+-- > data instance Pdu Parent s where+-- > Foo :: Pdu Parent Asynchronous+-- > Delegate :: Pdu Child r -> Pdu Parent r+-- >+-- > instance HasPdu Child where+-- > data instance Pdu Child s where+-- > Xyz :: Pdy Child Asynchronous+-- >+-- -- Instances of this class serve as proof to 'Embeds' that -- a conversion into another 'Pdu' actually exists. ----- A 'Prism' for the embedded 'Pdu' is the center of this class+-- A 'Prism' for the embedded 'Pdu' is the center of this class. -- -- Laws: @embeddedPdu = prism' embedPdu fromPdu@ -- -- @since 0.29.0 class- (Typeable protocol, Typeable embeddedProtocol)- => HasPduPrism protocol embeddedProtocol where-+ (Typeable protocol, Typeable embeddedProtocol) =>+ HasPduPrism protocol embeddedProtocol+ where -- | A 'Prism' for the embedded 'Pdu's.- embeddedPdu- :: forall (result :: Synchronicity)- . Prism' (Pdu protocol result) (Pdu embeddedProtocol result)+ embeddedPdu ::+ forall (result :: Synchronicity).+ Prism'+ (Pdu protocol result)+ (Pdu embeddedProtocol result) embeddedPdu = prism' embedPdu fromPdu -- | Embed the 'Pdu' value of an embedded protocol into the corresponding -- 'Pdu' value.- embedPdu- :: forall (result :: Synchronicity)- . Pdu embeddedProtocol result -> Pdu protocol result+ embedPdu ::+ forall (result :: Synchronicity).+ Pdu embeddedProtocol result ->+ Pdu protocol result embedPdu = review embeddedPdu+ -- | Examine a 'Pdu' value from the outer protocol, and return it, if it embeds a 'Pdu' of -- embedded protocol, otherwise return 'Nothing'/- fromPdu- :: forall (result :: Synchronicity)- . Pdu protocol result -> Maybe (Pdu embeddedProtocol result)+ fromPdu ::+ forall (result :: Synchronicity).+ Pdu protocol result ->+ Maybe (Pdu embeddedProtocol result) fromPdu = preview embeddedPdu --- | Convert an 'Endpoint' to an endpoint for an embedded protocol.------ See 'Embeds', 'fromEmbeddedEndpoint'.------ @since 0.25.1-toEmbeddedEndpoint :: forall inner outer . Embeds outer inner => Endpoint outer -> Endpoint inner-toEmbeddedEndpoint (Endpoint e) = Endpoint e---- | Convert an 'Endpoint' to an endpoint for a server, that embeds the protocol.------ See 'Embeds', 'toEmbeddedEndpoint'.------ @since 0.25.1-fromEmbeddedEndpoint :: forall outer inner . HasPduPrism outer inner => Endpoint inner -> Endpoint outer-fromEmbeddedEndpoint (Endpoint e) = Endpoint e- instance (Typeable a) => HasPduPrism a a where embeddedPdu = prism' id Just embedPdu = id@@ -356,7 +386,6 @@ showsPrec d (ToPduLeft x) = showsPrec d x showsPrec d (ToPduRight y) = showsPrec d y - instance (NFData (Pdu a1 r), NFData (Pdu a2 r), NFData (Pdu a3 r)) => NFData (Pdu (a1, a2, a3) r) where rnf (ToPdu1 x) = rnf x rnf (ToPdu2 y) = rnf y@@ -399,7 +428,7 @@ fromPdu (ToPdu4Of4 l) = Just l fromPdu _ = Nothing -instance (Typeable r, NFData (Pdu a1 r), NFData (Pdu a2 r), NFData (Pdu a3 r), NFData (Pdu a4 r), NFData (Pdu a5 r)) => NFData (Pdu (a1, a2, a3, a4, a5) r) where+instance (NFData (Pdu a1 r), NFData (Pdu a2 r), NFData (Pdu a3 r), NFData (Pdu a4 r), NFData (Pdu a5 r)) => NFData (Pdu (a1, a2, a3, a4, a5) r) where rnf (ToPdu1Of5 x) = rnf x rnf (ToPdu2Of5 y) = rnf y rnf (ToPdu3Of5 z) = rnf z@@ -439,3 +468,4 @@ fromPdu _ = Nothing makeLenses ''Endpoint+
src/Control/Eff/Concurrent/Protocol/Broker.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-}+ -- | A process broker spawns and monitors child processes. -- -- The child processes are mapped to symbolic identifier values: Child-IDs.@@ -48,53 +50,55 @@ -- -- @since 0.23.0 module Control.Eff.Concurrent.Protocol.Broker- ( startLink- , statefulChild- , stopBroker- , isBrokerAlive- , monitorBroker- , getDiagnosticInfo- , spawnChild- , spawnOrLookup- , lookupChild- , callById- , castById- , stopChild- , ChildNotFound(..)- , Broker()- , Pdu(StartC, StopC, LookupC, GetDiagnosticInfo)- , ChildId- , Stateful.StartArgument(MkBrokerConfig)- , brokerConfigChildStopTimeout- , SpawnErr(AlreadyStarted)- , ChildEvent(OnChildSpawned, OnChildDown, OnBrokerShuttingDown)- ) where+ ( startLink,+ statefulChild,+ stopBroker,+ isBrokerAlive,+ monitorBroker,+ getDiagnosticInfo,+ spawnChild,+ spawnOrLookup,+ lookupChild,+ callById,+ castById,+ stopChild,+ ChildNotFound (..),+ Broker (),+ Pdu (StartC, StopC, LookupC, GetDiagnosticInfo),+ ChildId,+ Stateful.StartArgument (MkBrokerConfig),+ brokerConfigChildStopTimeout,+ SpawnErr (AlreadyStarted),+ ChildEvent (OnChildSpawned, OnChildDown, OnBrokerShuttingDown),+ )+where -import Control.DeepSeq (NFData(rnf))+import Control.Applicative ((<|>))+import Control.DeepSeq (NFData (rnf)) import Control.Eff as Eff+import Control.Eff.Concurrent.Process+import Control.Eff.Concurrent.Process.Timer import Control.Eff.Concurrent.Protocol+import Control.Eff.Concurrent.Protocol.Broker.InternalState import Control.Eff.Concurrent.Protocol.Client-import Control.Eff.Concurrent.Protocol.Wrapper-import Control.Eff.Concurrent.Protocol.Observer import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful+import Control.Eff.Concurrent.Protocol.Observer import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful-import Control.Eff.Concurrent.Protocol.Broker.InternalState-import Control.Eff.Concurrent.Process-import Control.Eff.Concurrent.Process.Timer+import Control.Eff.Concurrent.Protocol.Wrapper import Control.Eff.Extend (raise) import Control.Eff.Log import Control.Eff.State.Strict as Eff-import Control.Lens hiding ((.=), use)+import Control.Lens hiding (use, (.=)) import Data.Default import Data.Dynamic import Data.Foldable import Data.Kind import qualified Data.Map as Map-import Data.Text (Text, pack)-import Data.Type.Pretty+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as T import GHC.Generics (Generic) import GHC.Stack-import Control.Applicative ((<|>)) -- * Broker Server API @@ -105,15 +109,13 @@ -- To spawn new child processes use 'spawnChild'. -- -- @since 0.23.0-startLink- :: forall p e- . ( HasCallStack- , IoLogging (Processes e)- , TangibleBroker p- , Stateful.Server (Broker p) (Processes e)- )- => Stateful.StartArgument (Broker p)- -> Eff (Processes e) (Endpoint (Broker p))+startLink ::+ forall p e.+ ( IoLogging (Processes e),+ Stateful.Server (Broker p) (Processes e)+ ) =>+ Stateful.StartArgument (Broker p) ->+ Eff (Processes e) (Endpoint (Broker p)) startLink = Stateful.startLink -- | A smart constructor for 'MkBrokerConfig' that makes it easy to start a 'Stateful.Server' instance.@@ -121,16 +123,7 @@ -- The user needs to instantiate @'ChildId' p@. -- -- @since 0.30.0-statefulChild- :: forall p e- . ( HasCallStack- , IoLogging e- , TangibleBroker (Stateful.Stateful p)- , Stateful.Server (Broker (Stateful.Stateful p)) e- )- => Timeout- -> (ChildId p -> Stateful.StartArgument p)- -> Stateful.StartArgument (Broker (Stateful.Stateful p))+statefulChild :: forall p. Timeout -> (ChildId p -> Stateful.StartArgument p) -> Stateful.StartArgument (Broker (Stateful.Stateful p)) statefulChild t f = MkBrokerConfig t (Stateful.Init . f) -- | Stop the broker and shutdown all processes.@@ -138,65 +131,52 @@ -- Block until the broker has finished. -- -- @since 0.23.0-stopBroker- :: ( HasCallStack- , HasProcesses e q- , Member Logs e- , Lifted IO e- , TangibleBroker p- )- => Endpoint (Broker p)- -> Eff e ()+stopBroker ::+ ( HasCallStack,+ HasProcesses e q,+ Member Logs e,+ TangibleBroker p+ ) =>+ Endpoint (Broker p) ->+ Eff e () stopBroker ep = do- logInfo ("stopping broker: " <> pack (show ep))+ logInfo (LABEL "stopping broker" ep) mr <- monitor (_fromEndpoint ep) sendInterrupt (_fromEndpoint ep) NormalExitRequested r <- receiveSelectedMessage (selectProcessDown mr)- logInfo ("broker stopped: " <> pack (show ep) <> " " <> pack (show r))+ logInfo (LABEL "broker stopped" ep) r -- | Check if a broker process is still alive. -- -- @since 0.23.0-isBrokerAlive- :: forall p q0 e .- ( HasCallStack- , Member Logs e- , Typeable p- , HasProcesses e q0- )- => Endpoint (Broker p)- -> Eff e Bool+isBrokerAlive ::+ forall p q0 e. HasProcesses e q0 => Endpoint (Broker p) -> Eff e Bool isBrokerAlive x = isProcessAlive (_fromEndpoint x) -- | Monitor a broker process. -- -- @since 0.23.0-monitorBroker- :: forall p q0 e .- ( HasCallStack- , Member Logs e- , HasProcesses e q0- , TangibleBroker p- )- => Endpoint (Broker p)- -> Eff e MonitorReference+monitorBroker ::+ forall p q0 e.+ HasProcesses e q0 =>+ Endpoint (Broker p) ->+ Eff e MonitorReference monitorBroker x = monitor (_fromEndpoint x) -- | Start and monitor a new child process using the 'SpawnFun' passed -- to 'startLink'. -- -- @since 0.23.0-spawnChild- :: forall p q0 e .- ( HasCallStack- , Member Logs e- , HasProcesses e q0- , TangibleBroker p- , Typeable (Effectful.ServerPdu p)- )- => Endpoint (Broker p)- -> ChildId p- -> Eff e (Either (SpawnErr p) (Endpoint (Effectful.ServerPdu p)))+spawnChild ::+ forall p q0 e.+ ( HasProcesses e q0,+ TangibleBroker p,+ ToTypeLogMsg (Broker p),+ Typeable (Effectful.ServerPdu p)+ ) =>+ Endpoint (Broker 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@@ -206,20 +186,20 @@ -- ignoring the 'AlreadyStarted' error. -- -- @since 0.29.2-spawnOrLookup- :: forall p q0 e .- ( HasCallStack- , Member Logs e- , HasProcesses e q0- , TangibleBroker p- , Typeable (Effectful.ServerPdu p)- )- => Endpoint (Broker p)- -> ChildId p- -> Eff e (Endpoint (Effectful.ServerPdu p))+spawnOrLookup ::+ forall p q0 e.+ ( HasProcesses e q0,+ TangibleBroker p,+ ToTypeLogMsg (Broker p),+ Typeable (Effectful.ServerPdu p)+ ) =>+ Endpoint (Broker p) ->+ ChildId p ->+ Eff e (Endpoint (Effectful.ServerPdu p)) spawnOrLookup supEp cId =- do res <- spawnChild supEp cId- pure $+ do+ res <- spawnChild supEp cId+ pure $ case res of Left (AlreadyStarted _ ep) -> ep Right ep -> ep@@ -229,16 +209,15 @@ -- -- @since 0.23.0 lookupChild ::- forall p e q0 .- ( HasCallStack- , Member Logs e- , HasProcesses e q0- , TangibleBroker p- , Typeable (Effectful.ServerPdu p)- )- => Endpoint (Broker p)- -> ChildId p- -> Eff e (Maybe (Endpoint (Effectful.ServerPdu p)))+ forall p e q0.+ ( HasProcesses e q0,+ TangibleBroker p,+ ToTypeLogMsg (Broker p),+ Typeable (Effectful.ServerPdu p)+ ) =>+ Endpoint (Broker 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.@@ -248,47 +227,44 @@ -- -- @since 0.23.0 stopChild ::- forall p e q0 .- ( HasCallStack- , Member Logs e- , HasProcesses e q0- , TangibleBroker p- )- => Endpoint (Broker p)- -> ChildId p- -> Eff e Bool+ forall p e q0.+ ( HasProcesses e q0,+ ToTypeLogMsg (Broker p),+ TangibleBroker p+ ) =>+ Endpoint (Broker p) ->+ ChildId p ->+ Eff e Bool stopChild ep cId = call ep (StopC @p cId (TimeoutMicros 4000000)) callById ::- forall destination protocol result e q0 .- ( HasCallStack- , Member Logs e- , HasProcesses e q0- , Lifted IO e- , Lifted IO q0- , TangibleBroker protocol- , TangiblePdu destination ( 'Synchronous result)- , TangiblePdu protocol ( 'Synchronous result)- , Embeds (Effectful.ServerPdu destination) protocol- , Ord (ChildId destination)- , Tangible (ChildId destination)- , Typeable (Effectful.ServerPdu destination)- , Tangible result- , NFData (Pdu protocol ( 'Synchronous result))- , NFData (Pdu (Effectful.ServerPdu destination) ( 'Synchronous result))- , Show (Pdu (Effectful.ServerPdu destination) ( 'Synchronous result))- )- => Endpoint (Broker destination)- -> ChildId destination- -> Pdu protocol ( 'Synchronous result)- -> Timeout- -> Eff e result+ forall destination protocol result e q0.+ ( Member Logs e,+ Member Logs q0,+ HasProcesses e q0,+ TangiblePdu destination ('Synchronous result),+ TangiblePdu protocol ('Synchronous result),+ Embeds (Effectful.ServerPdu destination) protocol,+ Ord (ChildId destination),+ Tangible (ChildId destination),+ ToLogMsg (ChildId destination),+ Tangible result,+ NFData (Pdu (Effectful.ServerPdu destination) ('Synchronous result)),+ ToLogMsg (Pdu (Effectful.ServerPdu destination) ('Synchronous result)),+ ToTypeLogMsg (Broker destination),+ ToTypeLogMsg (Effectful.ServerPdu destination)+ ) =>+ Endpoint (Broker destination) ->+ ChildId destination ->+ Pdu protocol ('Synchronous result) ->+ Timeout ->+ Eff e result callById broker cId pdu tMax = lookupChild broker cId- >>=- maybe- (do logError ("callById failed for: " <> pack (show pdu))- interrupt (InterruptedBy (ChildNotFound cId broker))+ >>= maybe+ ( do+ logError (LABEL "callById failed for" pdu)+ interrupt (InterruptedBy (toMessage (ChildNotFound cId broker))) ) (\cEp -> callWithTimeout cEp pdu tMax) @@ -296,44 +272,32 @@ ChildNotFound :: ChildId child -> Endpoint (Broker child) -> ChildNotFound child deriving (Typeable) -instance (Show (ChildId child), Typeable child) => Show (ChildNotFound child) where- showsPrec d (ChildNotFound cId broker)- = showParen (d >= 10) ( showString "child not found: "- . showsPrec 10 cId- . showString " at: "- . showsPrec 10 broker- )+instance (ToLogMsg (ChildId child), ToTypeLogMsg child) => ToLogMsg (ChildNotFound child) where+ toLogMsg (ChildNotFound cId brokerEp) =+ spaced (LABEL "child" cId) (LABEL "not found in" brokerEp) instance NFData (ChildId c) => NFData (ChildNotFound c) where rnf (ChildNotFound cId broker) = rnf cId `seq` rnf broker `seq` () castById ::- forall destination protocol e q0 .- ( HasCallStack- , Member Logs e- , HasProcesses e q0- , TangibleBroker protocol- , TangiblePdu destination 'Asynchronous- , TangiblePdu protocol 'Asynchronous- )- => Endpoint (Broker destination)- -> ChildId destination- -> Pdu protocol 'Asynchronous- -> Eff e ()+ forall destination protocol e.+ HasCallStack =>+ Endpoint (Broker destination) ->+ ChildId destination ->+ Pdu protocol 'Asynchronous ->+ Eff e () castById = error "TODO" - -- | Return a 'Text' describing the current state of the broker. -- -- @since 0.23.0-getDiagnosticInfo- :: forall p e q0 .- ( HasCallStack- , HasProcesses e q0- , TangibleBroker p- )- => Endpoint (Broker p)- -> Eff e Text+getDiagnosticInfo ::+ forall p e q0.+ ( HasProcesses e q0,+ TangibleBroker p+ ) =>+ Endpoint (Broker p) ->+ Eff e Text getDiagnosticInfo s = call s (GetDiagnosticInfo @p) -- ** Types@@ -346,29 +310,31 @@ -- The broker maps an identifier value of type @'ChildId' p@ to an @'Endpoint' p@. -- -- @since 0.24.0-data Broker (p :: Type) deriving Typeable+data Broker (p :: Type) deriving (Typeable) +instance ToTypeLogMsg p => ToTypeLogMsg (Broker p) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @p) <> "_broker"+ instance Typeable p => HasPdu (Broker p) where- type instance EmbeddedPduList (Broker p) = '[ObserverRegistry (ChildEvent p)]- -- | The 'Pdu' instance contains methods to start, stop and lookup a child- -- process, as well as a diagnostic callback.- --- -- @since 0.23.0- data instance Pdu (Broker p) r where- StartC :: ChildId p -> Pdu (Broker p) ('Synchronous (Either (SpawnErr p) (Endpoint (Effectful.ServerPdu p))))- StopC :: ChildId p -> Timeout -> Pdu (Broker p) ('Synchronous Bool)- LookupC :: ChildId p -> Pdu (Broker p) ('Synchronous (Maybe (Endpoint (Effectful.ServerPdu p))))- GetDiagnosticInfo :: Pdu (Broker p) ('Synchronous Text)- ChildEventObserverRegistry :: Pdu (ObserverRegistry (ChildEvent p)) r -> Pdu (Broker p) r- deriving Typeable+ type EmbeddedPduList (Broker p) = '[ObserverRegistry (ChildEvent p)] -instance (Typeable p, Show (ChildId p)) => Show (Pdu (Broker p) r) where- showsPrec d (StartC c) = showParen (d >= 10) (showString "StartC " . showsPrec 10 c)- showsPrec d (StopC c t) = showParen (d >= 10) (showString "StopC " . showsPrec 10 c . showChar ' ' . showsPrec 10 t)- showsPrec d (LookupC c) = showParen (d >= 10) (showString "LookupC " . showsPrec 10 c)- showsPrec _ GetDiagnosticInfo = showString "GetDiagnosticInfo"- showsPrec d (ChildEventObserverRegistry c) = showParen (d >= 10) (showString "ChildEventObserverRegistry " . showsPrec 10 c)+ data Pdu (Broker p) r where+ StartC :: ChildId p -> Pdu (Broker p) ('Synchronous (Either (SpawnErr p) (Endpoint (Effectful.ServerPdu p))))+ StopC :: ChildId p -> Timeout -> Pdu (Broker p) ('Synchronous Bool)+ LookupC :: ChildId p -> Pdu (Broker p) ('Synchronous (Maybe (Endpoint (Effectful.ServerPdu p))))+ GetDiagnosticInfo :: Pdu (Broker p) ('Synchronous Text)+ ChildEventObserverRegistry :: Pdu (ObserverRegistry (ChildEvent p)) r -> Pdu (Broker p) r+ deriving (Typeable) +instance (ToTypeLogMsg (Broker p), ToLogMsg (ChildId p), ToTypeLogMsg p) => ToLogMsg (Pdu (Broker p) r) where+ toLogMsg = \case+ StartC cId -> toTypeLogMsg (Proxy @(Broker p)) <> packLogMsg " start-child: " <> toLogMsg cId+ StopC cId t -> toTypeLogMsg (Proxy @(Broker p)) <> packLogMsg " stop-child: " <> toLogMsg cId <> packLogMsg " timeout: " <> toLogMsg t+ LookupC cId -> toTypeLogMsg (Proxy @(Broker p)) <> packLogMsg " lookup-child: " <> toLogMsg cId+ GetDiagnosticInfo -> toTypeLogMsg (Proxy @(Broker p)) <> packLogMsg " get diagnostic info"+ ChildEventObserverRegistry evt ->+ toTypeLogMsg (Proxy @(Broker p)) <> packLogMsg " child event observer registry message: " <> toLogMsg evt+ instance (NFData (ChildId p)) => NFData (Pdu (Broker p) r) where rnf (StartC ci) = rnf ci rnf (StopC ci t) = rnf ci `seq` rnf t@@ -377,11 +343,9 @@ rnf (ChildEventObserverRegistry x) = rnf x instance Typeable p => HasPduPrism (Broker p) (ObserverRegistry (ChildEvent p)) where- embedPdu = ChildEventObserverRegistry- fromPdu (ChildEventObserverRegistry x) = Just x- fromPdu _ = Nothing--type instance ToPretty (Broker p) = "broker" <:> ToPretty p+ embedPdu = ChildEventObserverRegistry+ fromPdu (ChildEventObserverRegistry x) = Just x+ fromPdu _ = Nothing -- | The event type to indicate that a child was started or stopped. --@@ -398,23 +362,27 @@ -- @since 0.30.0 data ChildEvent p where OnChildSpawned :: Endpoint (Broker p) -> ChildId p -> Endpoint (Effectful.ServerPdu p) -> ChildEvent p- OnChildDown :: Endpoint (Broker p) -> ChildId p -> Endpoint (Effectful.ServerPdu p) -> Interrupt 'NoRecovery -> ChildEvent p- OnBrokerShuttingDown :: Endpoint (Broker p) -> ChildEvent p -- ^ The broker is shutting down and will soon begin stopping/killing its children+ OnChildDown :: Endpoint (Broker p) -> ChildId p -> Endpoint (Effectful.ServerPdu p) -> ShutdownReason -> ChildEvent p+ OnBrokerShuttingDown ::+ Endpoint (Broker p) ->+ -- | The broker is shutting down and will soon begin stopping/killing its children+ ChildEvent p deriving (Typeable, Generic) +instance ToTypeLogMsg p => ToTypeLogMsg (ChildEvent p) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @p) <> packLogMsg "_broker_event"+ instance (NFData (ChildId p)) => NFData (ChildEvent p) -instance (Typeable p, Typeable (Effectful.ServerPdu p), Show (ChildId p)) => Show (ChildEvent p) where- showsPrec d x =+instance (ToTypeLogMsg p, ToTypeLogMsg (Effectful.ServerPdu p), ToLogMsg (ChildId p)) => ToLogMsg (ChildEvent p) where+ toLogMsg x = case x of- OnChildSpawned s i e ->- showParen (d >= 10)- (shows s . showString ": child-spawned: " . shows i . showChar ' ' . shows e)- OnChildDown s i e r ->- showParen (d >= 10)- (shows s . showString ": child-down: " . shows i . showChar ' ' . shows e . showChar ' ' . showsPrec 10 r)- OnBrokerShuttingDown s ->- shows s . showString ": shutting down"+ OnChildSpawned s i e ->+ toLogMsg s <> packLogMsg ": child-spawned: " <> toLogMsg i <> packLogMsg " " <> toLogMsg e+ OnChildDown s i e r ->+ toLogMsg s <> packLogMsg ": child-down: " <> toLogMsg i <> packLogMsg " " <> toLogMsg e <> packLogMsg " " <> toLogMsg r+ OnBrokerShuttingDown s ->+ toLogMsg s <> packLogMsg ": shutting down" -- | The type of value used to index running 'Server' processes managed by a 'Broker'. --@@ -429,60 +397,50 @@ -- -- @since 0.24.0 type TangibleBroker p =- ( Tangible (ChildId p)- , Ord (ChildId p)- , Typeable p+ ( Tangible (ChildId p),+ Ord (ChildId p),+ Typeable p,+ ToTypeLogMsg p,+ ToLogMsg (ChildId p) ) - instance- ( IoLogging q- , TangibleBroker p- , Tangible (ChildId p)- , Typeable (Effectful.ServerPdu p)- , Effectful.Server p (Processes q)- , HasProcesses (Effectful.ServerEffects p (Processes q)) q- ) => Stateful.Server (Broker p) (Processes q) where-- -- | Options that control the 'Broker p' process.- --- -- This contains:- --- -- * a 'SpawnFun'- -- * the 'Timeout' after requesting a normal child exit before brutally killing the child.- --- -- @since 0.24.0- data instance StartArgument (Broker p) = MkBrokerConfig- {- brokerConfigChildStopTimeout :: Timeout- , brokerConfigStartFun :: ChildId p -> Effectful.Init p+ ( IoLogging q,+ TangibleBroker p,+ Typeable (Effectful.ServerPdu p),+ Effectful.Server p (Processes q),+ ToTypeLogMsg (Effectful.ServerPdu p),+ ToTypeLogMsg (Broker p),+ HasProcesses (Effectful.ServerEffects p (Processes q)) q+ ) =>+ Stateful.Server (Broker p) (Processes q)+ where+ data StartArgument (Broker p) = MkBrokerConfig+ { brokerConfigChildStopTimeout :: Timeout,+ brokerConfigStartFun :: ChildId p -> Effectful.Init p } - data instance Model (Broker p) =- BrokerModel { _children :: Children (ChildId p) p- , _childEventObserver :: ObserverRegistry (ChildEvent p)- }- deriving Typeable+ data Model (Broker p) = BrokerModel+ { _children :: Children (ChildId p) p,+ _childEventObserver :: ObserverRegistry (ChildEvent p)+ }+ deriving (Typeable) setup _ _cfg = pure (BrokerModel def emptyObserverRegistry, ()) update _ _brokerConfig (Stateful.OnCast req) =- case req of+ case req of ChildEventObserverRegistry x -> Stateful.zoomModel @(Broker p) childEventObserverLens (observerRegistryHandlePdu x)- update me brokerConfig (Stateful.OnCall rt req) = case req of ChildEventObserverRegistry x ->- logEmergency ("unreachable: " <> pack (show x))-+ logEmergency (LABEL "unreachable" x) GetDiagnosticInfo -> zoomToChildren @p $ do- p <- (pack . show <$> getChildren @(ChildId p) @p)+ p <- (T.unlines . fmap (_fromLogMsg . \(cId, cMon) -> toLogMsg cId <> packLogMsg " => " <> toLogMsg cMon) . Map.assocs . view childrenById <$> getChildren @(ChildId p) @p) sendReply rt p- LookupC i -> zoomToChildren @p $ do- p <- fmap (view childEndpoint) <$> lookupChildById @(ChildId p) @p i+ p <- fmap childEndpoint <$> lookupChildById @(ChildId p) @p i sendReply rt p- StopC i t -> zoomToChildren @p $ do mExisting <- lookupAndRemoveChildById @(ChildId p) @p i case mExisting of@@ -492,8 +450,7 @@ sendReply rt True Stateful.zoomModel @(Broker p) childEventObserverLens- (observerRegistryNotify @(ChildEvent p) (OnChildDown me i (existingChild^.childEndpoint) reason))-+ (observerRegistryNotify @(ChildEvent p) (OnChildDown me i (childEndpoint existingChild) reason)) StartC i -> do mExisting <- zoomToChildren @p $ lookupChildById @(ChildId p) @p i case mExisting of@@ -501,60 +458,58 @@ childEp <- raise (raise (Effectful.startLink (brokerConfigStartFun brokerConfig i))) let childPid = _fromEndpoint childEp cMon <- monitor childPid- zoomToChildren @p $ putChild i (MkChild @p childEp cMon)+ zoomToChildren @p $ putChild i (MkChild @p cMon) sendReply rt (Right childEp) Stateful.zoomModel @(Broker p) childEventObserverLens (observerRegistryNotify @(ChildEvent p) (OnChildSpawned me i childEp)) Just existingChild ->- sendReply rt (Left (AlreadyStarted i (existingChild ^. childEndpoint)))-+ sendReply rt (Left (AlreadyStarted i (childEndpoint existingChild))) update me _brokerConfig (Stateful.OnDown pd) = do- wasObserver <- Stateful.zoomModel @(Broker p)+ wasObserver <-+ Stateful.zoomModel @(Broker p) childEventObserverLens (observerRegistryRemoveProcess @(ChildEvent p) (downProcess pd))- if wasObserver- then logInfo ("observer process died: " <> pack (show pd))- else do+ if wasObserver+ then logInfo (LABEL "observer process died" pd)+ else do oldEntry <- zoomToChildren @p $ lookupAndRemoveChildByMonitor @(ChildId p) @p (downReference pd) case oldEntry of- Nothing -> logWarning ("unexpected: " <> pack (show pd))+ Nothing -> logWarning (LABEL "unexpected" pd) Just (i, c) -> do- logInfo ( pack (show pd)- <> " for child "- <> pack (show i)- <> " => "- <> pack (show (c^.childEndpoint))- )+ logInfo (spaced pd (LABEL "child-id" i) (LABEL "child" (childEndpoint c)) :: LogMsg) Stateful.zoomModel @(Broker p)- childEventObserverLens- (observerRegistryNotify @(ChildEvent p) (OnChildDown me i (c^.childEndpoint) (downReason pd)))+ childEventObserverLens+ (observerRegistryNotify @(ChildEvent p) (OnChildDown me i (childEndpoint c) (downReason pd))) update me brokerConfig (Stateful.OnInterrupt e) = case e of NormalExitRequested -> do- logDebug ("broker stopping: " <> pack (show e))+ logDebug (LABEL "broker stopping" e) Stateful.zoomModel @(Broker p)- childEventObserverLens- (observerRegistryNotify @(ChildEvent p) (OnBrokerShuttingDown me))+ childEventObserverLens+ (observerRegistryNotify @(ChildEvent p) (OnBrokerShuttingDown me)) stopAllChildren @p me (brokerConfigChildStopTimeout brokerConfig) exitNormally LinkedProcessCrashed linked ->- logNotice (pack (show linked))+ logNotice linked _ -> do- logWarning ("broker interrupted: " <> pack (show e))+ logWarning (LABEL "broker interrupted" e) Stateful.zoomModel @(Broker p)- childEventObserverLens- (observerRegistryNotify @(ChildEvent p) (OnBrokerShuttingDown me))+ childEventObserverLens+ (observerRegistryNotify @(ChildEvent p) (OnBrokerShuttingDown me)) stopAllChildren @p me (brokerConfigChildStopTimeout brokerConfig) exitBecause (interruptToExit e)-- update _ _brokerConfig o = logWarning ("unexpected: " <> pack (show o))+ update _ _brokerConfig o = logWarning (LABEL "unexpected" o) +instance ToTypeLogMsg p => ToLogMsg (Stateful.StartArgument (Broker p)) where+ toLogMsg (MkBrokerConfig x _initFun) =+ toTypeLogMsg (Proxy @p) <> packLogMsg " broker configuration: child start timeout: " <> toLogMsg x -zoomToChildren :: forall p c e- . Member (Stateful.ModelState (Broker p)) e- => Eff (State (Children (ChildId p) p) ': e) c- -> Eff e c+zoomToChildren ::+ forall p c e.+ Member (Stateful.ModelState (Broker p)) e =>+ Eff (State (Children (ChildId p) p) ': e) c ->+ Eff e c zoomToChildren = Stateful.zoomModel @(Broker p) childrenLens childrenLens :: Lens' (Stateful.Model (Broker p)) (Children (ChildId p) p)@@ -570,76 +525,84 @@ deriving (Typeable, Generic) deriving instance Eq (ChildId p) => Eq (SpawnErr p)+ deriving instance Ord (ChildId p) => Ord (SpawnErr p)-deriving instance (Typeable (Effectful.ServerPdu p), Show (ChildId p)) => Show (SpawnErr p) instance NFData (ChildId p) => NFData (SpawnErr p) +instance (ToTypeLogMsg (Effectful.ServerPdu p), ToLogMsg (ChildId p)) => ToLogMsg (SpawnErr p) where+ toLogMsg (AlreadyStarted cId cEp) =+ packLogMsg "child: " <> toLogMsg cId <> packLogMsg " already started as: " <> toLogMsg cEp+ -- Internal Functions -stopOrKillChild- :: forall p e q0 .- ( HasCallStack- , HasProcesses e q0- , Lifted IO e- , Lifted IO q0- , Member Logs e- , Member (Stateful.ModelState (Broker p)) e- , TangibleBroker p- , Typeable (Effectful.ServerPdu p)- )- => ChildId p- -> Child p- -> Timeout- -> Eff e (Interrupt 'NoRecovery)+stopOrKillChild ::+ forall p e q0.+ ( HasCallStack,+ HasProcesses e q0,+ Member Logs e,+ Member Logs q0,+ TangibleBroker p,+ ToTypeLogMsg (Effectful.ServerPdu p)+ ) =>+ ChildId p ->+ Child p ->+ Timeout ->+ Eff e ShutdownReason stopOrKillChild cId c stopTimeout =- do- broker <- asEndpoint @(Broker p) <$> self- t <- startTimerWithTitle- (MkProcessTitle ("child-exit-timer-" <> pack (show broker) <> "-" <> pack (show cId)))- stopTimeout- 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")- let reason = interruptToExit (TimeoutInterrupt- ("child did not shut down in time and was terminated by the "- ++ show broker))- sendShutdown (_fromEndpoint (c^.childEndpoint)) reason- return reason- Right downMsg -> do- logInfo ("child "<> pack (show cId) <>" => " <> pack(show (c^.childEndpoint)) <>" terminated: " <> pack (show (downReason downMsg)))- return (downReason downMsg)+ do+ broker <- asEndpoint @(Broker p) <$> self+ t <-+ startTimerWithTitle+ (MkProcessTitle (toLogMsg broker <> packLogMsg "_child-exit-timer_" <> toLogMsg cId))+ stopTimeout+ sendInterrupt (_fromEndpoint (childEndpoint c)) NormalExitRequested+ r1 <-+ receiveSelectedMessage+ ( Right <$> selectProcessDown (c ^. childMonitoring)+ <|> Left <$> selectTimerElapsed t+ )+ demonitor (c ^. childMonitoring)+ unlinkProcess (_fromEndpoint (childEndpoint c))+ case r1 of+ Left timerElapsed -> do+ logWarning timerElapsed (spaced (LABEL "child" cId) (MSG "=>") (childEndpoint c) (MSG "did not shutdown in time") :: LogMsg)+ let reason =+ interruptToExit+ ( TimeoutInterrupt+ (toLogMsg (LABEL "child did not shut down in time and was terminated by the" broker))+ )+ sendShutdown (_fromEndpoint (childEndpoint c)) reason+ return reason+ Right downMsg -> do+ logInfo (spaced (LABEL "child" cId) (MSG "=>") (childEndpoint c) (LABEL "terminated" (downReason downMsg)) :: LogMsg)+ return (downReason downMsg) -stopAllChildren- :: forall p e q0 .- ( HasCallStack- , HasProcesses e q0- , Lifted IO e- , Lifted IO q0- , Member Logs e- , Member (Stateful.ModelState (Broker p)) e- , TangibleBroker p- , Typeable (Effectful.ServerPdu p)- )- => Endpoint (Broker p) -> Timeout -> Eff e ()+stopAllChildren ::+ forall p e q0.+ ( HasCallStack,+ HasProcesses e q0,+ Member Logs e,+ Member Logs q0,+ Member (Stateful.ModelState (Broker p)) e,+ TangibleBroker p,+ ToTypeLogMsg (Effectful.ServerPdu p)+ ) =>+ Endpoint (Broker p) ->+ Timeout ->+ Eff e () stopAllChildren me stopTimeout = zoomToChildren @p (removeAllChildren @(ChildId p) @p)- >>= pure . Map.assocs- >>= traverse_ killAndNotify+ >>= pure . Map.assocs+ >>= traverse_ killAndNotify where killAndNotify (cId, c) = do reason <- provideInterrupts (stopOrKillChild cId c stopTimeout) >>= either crash return Stateful.zoomModel @(Broker p)- childEventObserverLens- (observerRegistryNotify @(ChildEvent p) (OnChildDown me cId (c^.childEndpoint) reason))-+ childEventObserverLens+ (observerRegistryNotify @(ChildEvent p) (OnChildDown me cId (childEndpoint c) reason)) where crash e = do- logError (pack (show e) <> " while stopping child: " <> pack (show cId) <> " " <> pack (show c))+ logError e (LABEL "while stopping child" cId) c return (interruptToExit e)
src/Control/Eff/Concurrent/Protocol/Broker/InternalState.hs view
@@ -1,49 +1,58 @@ module Control.Eff.Concurrent.Protocol.Broker.InternalState- ( Child(MkChild)- , childMonitoring- , childEndpoint- , putChild- , Children()- , removeAllChildren- , getChildren- , lookupChildById- , lookupAndRemoveChildById- , lookupAndRemoveChildByMonitor- )- where+ ( Child (MkChild),+ childMonitoring,+ childEndpoint,+ putChild,+ Children (),+ childrenById,+ removeAllChildren,+ getChildren,+ lookupChildById,+ lookupAndRemoveChildById,+ lookupAndRemoveChildByMonitor,+ )+where import Control.DeepSeq import Control.Eff as Eff import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Protocol import Control.Eff.Concurrent.Protocol.EffectfulServer+import Control.Eff.Log.Message import Control.Eff.State.Strict as Eff-import Control.Lens hiding ((.=), use)+import Control.Lens hiding (use, (.=)) import Data.Default import Data.Dynamic import Data.Map (Map)+import Data.Proxy import GHC.Generics (Generic) --data Child p = MkChild- { _childEndpoint :: Endpoint (ServerPdu p)- , _childMonitoring :: MonitorReference+newtype Child p = MkChild+ { _childMonitoring :: MonitorReference }- deriving (Generic, Typeable, Eq, Ord)+ deriving (Generic, Typeable, Eq, Ord, NFData) -instance NFData (Child o)+instance ToTypeLogMsg d => ToTypeLogMsg (Child d) where+ toTypeLogMsg _ = packLogMsg "child_" <> toTypeLogMsg (Proxy @d) -instance Typeable (ServerPdu p) => Show (Child p) where- showsPrec d c = showParen (d>=10)- (showString "process broker entry: " . shows (_childEndpoint c) . showChar ' ' . shows (_childMonitoring c) )+instance ToTypeLogMsg d => ToLogMsg (Child d) where+ toLogMsg c = toTypeLogMsg (Proxy @(Child d)) <> packLogMsg "_" <> toLogMsg (_childMonitoring c) +-- | Extract the 'Endpoint' of a 'ServerPdu' of the 'Child' watched by the+-- 'Broker'.+--+-- @since 1.0.0+childEndpoint :: Child p -> Endpoint (ServerPdu p)+childEndpoint = Endpoint . _monitoredProcess . _childMonitoring+ makeLenses ''Child -- | Internal state. data Children i p = MkChildren- { _childrenById :: Map i (Child p)- , _childrenByMonitor :: Map MonitorReference (i, Child p)- } deriving (Show, Generic, Typeable)+ { _childrenById :: Map i (Child p),+ _childrenByMonitor :: Map MonitorReference (i, Child p)+ }+ deriving (Generic, Typeable) instance Default (Children i p) where def = MkChildren def def@@ -53,63 +62,70 @@ makeLenses ''Children -- | State accessor-getChildren- :: (Ord i, Member (State (Children i o)) e)- => Eff e (Children i o)+getChildren ::+ (Member (State (Children i o)) e) =>+ Eff e (Children i o) getChildren = Eff.get -putChild- :: (Ord i, Member (State (Children i o)) e)- => i- -> Child o- -> Eff e ()-putChild cId c = modify ( (childrenById . at cId .~ Just c)- . (childrenByMonitor . at (_childMonitoring c) .~ Just (cId, c))- )+putChild ::+ (Ord i, Member (State (Children i o)) e) =>+ i ->+ Child o ->+ Eff e ()+putChild cId c =+ modify+ ( (childrenById . at cId .~ Just c)+ . (childrenByMonitor . at (_childMonitoring c) .~ Just (cId, c))+ ) -lookupChildById- :: (Ord i, Member (State (Children i o)) e)- => i- -> Eff e (Maybe (Child o))+lookupChildById ::+ (Ord i, Member (State (Children i o)) e) =>+ i ->+ Eff e (Maybe (Child o)) lookupChildById i = view (childrenById . at i) <$> get -lookupChildByMonitor- :: (Ord i, Member (State (Children i o)) e)- => MonitorReference- -> Eff e (Maybe (i, Child o))+lookupChildByMonitor ::+ (Member (State (Children i o)) e) =>+ MonitorReference ->+ Eff e (Maybe (i, Child o)) lookupChildByMonitor m = view (childrenByMonitor . at m) <$> get -lookupAndRemoveChildById- :: forall i o e. (Ord i, Member (State (Children i o)) e)- => i- -> Eff e (Maybe (Child o))+lookupAndRemoveChildById ::+ forall i o e.+ (Ord i, Member (State (Children i o)) e) =>+ i ->+ Eff e (Maybe (Child o)) lookupAndRemoveChildById i = traverse go =<< lookupChildById i where go c = pure c <* removeChild i c -removeChild- :: forall i o e. (Ord i, Member (State (Children i o)) e)- => i- -> Child o- -> Eff e ()+removeChild ::+ forall i o e.+ (Ord i, Member (State (Children i o)) e) =>+ i ->+ Child o ->+ Eff e () removeChild i c = do- modify @(Children i o) ( (childrenById . at i .~ Nothing)- . (childrenByMonitor . at (_childMonitoring c) .~ Nothing)- )+ modify @(Children i o)+ ( (childrenById . at i .~ Nothing)+ . (childrenByMonitor . at (_childMonitoring c) .~ Nothing)+ ) -lookupAndRemoveChildByMonitor- :: forall i o e. (Ord i, Member (State (Children i o)) e)- => MonitorReference- -> Eff e (Maybe (i, Child o))+lookupAndRemoveChildByMonitor ::+ forall i o e.+ (Ord i, Member (State (Children i o)) e) =>+ MonitorReference ->+ Eff e (Maybe (i, Child o)) lookupAndRemoveChildByMonitor r = do traverse go =<< lookupChildByMonitor r where go (i, c) = pure (i, c) <* removeChild i c -removeAllChildren- :: forall i o e. (Ord i, Member (State (Children i o)) e)- => Eff e (Map i (Child o))+removeAllChildren ::+ forall i o e.+ (Ord i, Member (State (Children i o)) e) =>+ Eff e (Map i (Child o)) removeAllChildren = do cm <- view childrenById <$> getChildren @i modify @(Children i o) (childrenById .~ mempty)
src/Control/Eff/Concurrent/Protocol/CallbackServer.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-}+ -- | Build a "Control.Eff.Concurrent.EffectfulServer" from callbacks. -- -- This module contains in instance of 'E.Server' that delegates to@@ -6,123 +7,134 @@ -- -- @since 0.27.0 module Control.Eff.Concurrent.Protocol.CallbackServer- ( start- , startLink- , Server- , ServerId(..)- , Event(..)- , TangibleCallbacks- , Callbacks- , callbacks- , onEvent- , CallbacksEff- , callbacksEff- , onEventEff+ ( start,+ startLink,+ Server,+ ServerId (..),+ Event (..),+ TangibleCallbacks,+ Callbacks,+ callbacks,+ onEvent,+ CallbacksEff,+ callbacksEff,+ onEventEff, )- where+where import Control.DeepSeq import Control.Eff-import Control.Eff.Concurrent.Misc import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Protocol+import Control.Eff.Concurrent.Protocol.EffectfulServer (Event (..)) import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as E-import Control.Eff.Concurrent.Protocol.EffectfulServer (Event(..)) import Control.Eff.Extend () import Control.Eff.Log+import Data.Coerce import Data.Kind+import Data.Proxy import Data.String-import Data.Typeable import qualified Data.Text as T-import GHC.Stack (HasCallStack)+import Data.Typeable -- | Execute the server loop, that dispatches incoming events -- to either a set of 'Callbacks' or 'CallbacksEff'. -- -- @since 0.29.1-start- :: forall (tag :: Type) eLoop q e.- ( HasCallStack- , TangibleCallbacks tag eLoop q- , E.Server (Server tag eLoop q) (Processes q)- , FilteredLogging (Processes q)- , HasProcesses e q- )- => CallbacksEff tag eLoop q- -> Eff e (Endpoint tag)+start ::+ forall (tag :: Type) eLoop q e.+ ( TangibleCallbacks tag eLoop q,+ E.Server (Server tag eLoop q) (Processes q),+ FilteredLogging (Processes q),+ HasProcesses e q+ ) =>+ CallbacksEff tag eLoop q ->+ Eff e (Endpoint tag) start = E.start -- | Execute the server loop, that dispatches incoming events -- to either a set of 'Callbacks' or 'CallbacksEff'. -- -- @since 0.29.1-startLink- :: forall (tag :: Type) eLoop q e.- ( HasCallStack- , TangibleCallbacks tag eLoop q- , E.Server (Server tag eLoop q) (Processes q)- , FilteredLogging (Processes q)- , HasProcesses e q- )- => CallbacksEff tag eLoop q- -> Eff e (Endpoint tag)+startLink ::+ forall (tag :: Type) eLoop q e.+ ( TangibleCallbacks tag eLoop q,+ E.Server (Server tag eLoop q) (Processes q),+ FilteredLogging (Processes q),+ HasProcesses e q+ ) =>+ CallbacksEff tag eLoop q ->+ Eff e (Endpoint tag) startLink = E.startLink -- | Phantom type to indicate a callback based 'E.Server' instance. -- -- @since 0.27.0-data Server tag eLoop e deriving Typeable+data Server tag eLoop e deriving (Typeable) +instance ToTypeLogMsg tag => ToTypeLogMsg (Server tag eLoop e) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @tag)+ -- | The constraints for a /tangible/ 'Server' instance. -- -- @since 0.27.0 type TangibleCallbacks tag eLoop e =- ( HasProcesses eLoop e- , Typeable e- , Typeable eLoop- , Typeable tag- )+ ( HasProcesses eLoop e,+ ToTypeLogMsg tag,+ Typeable e,+ Typeable eLoop,+ Typeable tag+ ) -- | The name/id of a 'Server' for logging purposes. -- -- @since 0.24.0-newtype ServerId (tag :: Type) =- MkServerId { _fromServerId :: T.Text }+newtype ServerId (tag :: Type) = MkServerId {_fromServerId :: T.Text} deriving (Typeable, NFData, Ord, Eq, IsString) -instance (Typeable tag) => Show (ServerId tag) where+instance ToTypeLogMsg tag => ToTypeLogMsg (ServerId tag) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @tag) <> packLogMsg "_server_id"++instance ToLogMsg (ServerId tag) where+ toLogMsg x = coerce x++instance (ToTypeLogMsg tag) => Show (ServerId tag) where showsPrec d px@(MkServerId x) = showParen (d >= 10)- (showString (T.unpack x)- . showString " :: "- . showSTypeRep (typeOf px)+ ( showString (T.unpack x)+ . showString "_"+ . shows (toTypeLogMsg px) ) -instance (TangibleCallbacks tag eLoop e) => E.Server (Server (tag :: Type) eLoop e) (Processes e) where+instance (ToLogMsg (E.Init (Server tag eLoop e)), TangibleCallbacks tag eLoop e) => E.Server (Server (tag :: Type) eLoop e) (Processes e) where type ServerPdu (Server tag eLoop e) = tag type ServerEffects (Server tag eLoop e) (Processes e) = eLoop- data instance Init (Server tag eLoop e) =- MkServer- { genServerId :: ServerId tag- , genServerRunEffects :: forall x . (Endpoint tag -> Eff eLoop x -> Eff (Processes e) x)- , genServerOnEvent :: Endpoint tag -> Event tag -> Eff eLoop ()- } deriving Typeable+ data Init (Server tag eLoop e) = MkServer+ { genServerId :: ServerId tag,+ genServerRunEffects :: forall x. (Endpoint tag -> Eff eLoop x -> Eff (Processes e) x),+ genServerOnEvent :: Endpoint tag -> Event tag -> Eff eLoop ()+ }+ deriving (Typeable) runEffects myEp svr = genServerRunEffects svr myEp onEvent myEp svr = genServerOnEvent svr myEp +instance forall (tag :: Type) (e1 :: [Type -> Type]) (e2 :: [Type -> Type]). ToLogMsg (E.Init (Server tag e1 e2)) where+ toLogMsg x = toLogMsg (genServerId x)+ instance (TangibleCallbacks tag eLoop e) => NFData (E.Init (Server (tag :: Type) eLoop e)) where rnf (MkServer x y z) = rnf x `seq` y `seq` z `seq` () -instance (TangibleCallbacks tag eLoop e) => Show (E.Init (Server (tag :: Type) eLoop e)) where+instance forall tag eLoop e. (TangibleCallbacks tag eLoop e) => Show (E.Init (Server (tag :: Type) eLoop e)) where showsPrec d svr =- showParen (d>=10)+ showParen+ (d >= 10) ( showsPrec 11 (genServerId svr)- . showChar ' ' . showSTypeRep (typeRep (Proxy @tag))- . showString " callback-server"+ . showChar ' '+ . shows (toTypeLogMsg (Proxy @tag))+ . showString " callback-server" ) - -- ** Smart Constructors for 'Callbacks' -- | A convenience type alias for callbacks that do not@@ -131,35 +143,24 @@ -- @since 0.29.1 type Callbacks tag e = CallbacksEff tag (Processes e) e - -- | A smart constructor for 'Callbacks'. -- -- @since 0.29.1-callbacks- :: forall tag q.- ( HasCallStack- , TangibleCallbacks tag (Processes q) q- , E.Server (Server tag (Processes q) q) (Processes q)- , FilteredLogging q- )- => (Endpoint tag -> Event tag -> Eff (Processes q) ())- -> ServerId tag- -> Callbacks tag q+callbacks ::+ forall tag q.+ (Endpoint tag -> Event tag -> Eff (Processes q) ()) ->+ ServerId tag ->+ Callbacks tag q callbacks evtCb i = callbacksEff (const id) evtCb i -- | A simple smart constructor for 'Callbacks'. -- -- @since 0.29.1-onEvent- :: forall tag q .- ( HasCallStack- , TangibleCallbacks tag (Processes q) q- , E.Server (Server tag (Processes q) q) (Processes q)- , FilteredLogging q- )- => (Event tag -> Eff (Processes q) ())- -> ServerId (tag :: Type)- -> Callbacks tag q+onEvent ::+ forall tag q.+ (Event tag -> Eff (Processes q) ()) ->+ ServerId (tag :: Type) ->+ Callbacks tag q onEvent = onEventEff id -- ** Smart Constructors for 'CallbacksEff'@@ -174,32 +175,20 @@ -- | A smart constructor for 'CallbacksEff'. -- -- @since 0.29.1-callbacksEff- :: forall tag eLoop q.- ( HasCallStack- , TangibleCallbacks tag eLoop q- , E.Server (Server tag eLoop q) (Processes q)- , FilteredLogging q- )- => (forall x . Endpoint tag -> Eff eLoop x -> Eff (Processes q) x)- -> (Endpoint tag -> Event tag -> Eff eLoop ())- -> ServerId tag- -> CallbacksEff tag eLoop q+callbacksEff ::+ forall tag eLoop q.+ (forall x. Endpoint tag -> Eff eLoop x -> Eff (Processes q) x) ->+ (Endpoint tag -> Event tag -> Eff eLoop ()) ->+ ServerId tag ->+ CallbacksEff tag eLoop q callbacksEff a b c = MkServer c a b -- | A simple smart constructor for 'CallbacksEff'. -- -- @since 0.29.1-onEventEff- ::- ( HasCallStack- , TangibleCallbacks tag eLoop q- , E.Server (Server tag eLoop q) (Processes q)- , FilteredLogging q- )- => (forall a. Eff eLoop a -> Eff (Processes q) a)- -> (Event tag -> Eff eLoop ())- -> ServerId (tag :: Type)- -> CallbacksEff tag eLoop q+onEventEff ::+ (forall a. Eff eLoop a -> Eff (Processes q) a) ->+ (Event tag -> Eff eLoop ()) ->+ ServerId (tag :: Type) ->+ CallbacksEff tag eLoop q onEventEff h f i = callbacksEff (const h) (const f) i-
src/Control/Eff/Concurrent/Protocol/Client.hs view
@@ -3,32 +3,38 @@ -- This modules is required to write clients that send'Pdu's. module Control.Eff.Concurrent.Protocol.Client ( -- * Calling APIs directly- cast- , call- , callWithTimeout- -- * Server Process Registration- , castSingleton- , castEndpointReader- , callSingleton- , callEndpointReader- , HasEndpointReader- , EndpointReader- , askEndpoint- , runEndpointReader+ cast,+ call,+ callWithTimeout,++ -- * Server Process Registration+ castSingleton,+ castEndpointReader,+ callSingleton,+ callEndpointReader,+ HasEndpointReader,+ EndpointReader,+ askEndpoint,+ runEndpointReader, ) where -import Control.Eff-import Control.Eff.Reader.Strict-import Control.Eff.Concurrent.Protocol-import Control.Eff.Concurrent.Protocol.Wrapper-import Control.Eff.Concurrent.Process-import Control.Eff.Concurrent.Process.Timer-import Control.Eff.Log-import Data.Typeable ( Typeable )-import Data.Text (pack)-import GHC.Stack+import Control.Eff+import Control.Eff.Concurrent.Process+import Control.Eff.Concurrent.Process.Timer+import Control.Eff.Concurrent.Protocol+import Control.Eff.Concurrent.Protocol.Wrapper+import Control.Eff.Log+import Control.Eff.Reader.Strict+import Data.Typeable (Typeable)+import GHC.Stack +-- instance ToProtocolName protocol => ToProtocolName (Endpoint protocol) where+-- toProtocolName = toProtocolName @protocol <> "_ep"+--+-- instance ToProtocolName protocol => ToTypeLogMsg (Endpoint protocol) where+-- toTypeLogMsg _ = packLogMsg (toProtocolName @(Endpoint protocol))+-- -- | Send a request 'Pdu' that has no reply and return immediately. --@@ -37,18 +43,15 @@ -- message was delivered, use 'call' instead. -- -- The message will be reduced to normal form ('rnf') in the caller process.-cast- :: forall destination protocol r q- . ( HasCallStack- , HasProcesses r q- , HasPdu destination- , HasPdu protocol- , Tangible (Pdu destination 'Asynchronous)- , Embeds destination protocol- )- => Endpoint destination- -> Pdu protocol 'Asynchronous- -> Eff r ()+cast ::+ forall destination protocol r q.+ ( HasProcesses r q,+ TangiblePdu destination 'Asynchronous,+ Embeds destination protocol+ ) =>+ Endpoint destination ->+ Pdu protocol 'Asynchronous ->+ Eff r () cast (Endpoint pid) castMsg = sendMessage pid (Cast (embedPdu @destination castMsg)) -- | Send a request 'Pdu' and wait for the server to return a result value.@@ -57,18 +60,16 @@ -- 'Synchronous'. -- -- __Always prefer 'callWithTimeout' over 'call'__-call- :: forall result destination protocol r q- . ( HasProcesses r q- , TangiblePdu destination ( 'Synchronous result)- , TangiblePdu protocol ( 'Synchronous result)- , Tangible result- , Embeds destination protocol- , HasCallStack- )- => Endpoint destination- -> Pdu protocol ( 'Synchronous result)- -> Eff r result+call ::+ forall result destination protocol r q.+ ( HasProcesses r q,+ TangiblePdu destination ('Synchronous result),+ Tangible result,+ Embeds destination protocol+ ) =>+ Endpoint destination ->+ Pdu protocol ('Synchronous result) ->+ Eff r result call (Endpoint pidInternal) req = do callRef <- makeReference fromPid <- self@@ -77,13 +78,13 @@ sendMessage pidInternal requestMessage let selectResult :: MessageSelector result selectResult =- let extractResult- :: Reply destination result -> Maybe result+ let extractResult ::+ Reply destination result -> Maybe result extractResult (Reply origin' result) = if origin == origin' then Just result else Nothing- in selectMessageWith extractResult+ in selectMessageWith extractResult resultOrError <- receiveWithMonitor pidInternal selectResult- either (interrupt . becauseProcessIsDown) return resultOrError+ either (interrupt . becauseOtherProcessNotRunning) return resultOrError -- | Send an request 'Pdu' and wait for the server to return a result value. --@@ -98,20 +99,20 @@ -- __Always prefer this function over 'call'__ -- -- @since 0.22.0-callWithTimeout- :: forall result destination protocol r q- . ( HasProcesses r q- , TangiblePdu destination ( 'Synchronous result)- , TangiblePdu protocol ( 'Synchronous result)- , Tangible result- , Member Logs r- , HasCallStack- , Embeds destination protocol- )- => Endpoint destination- -> Pdu protocol ( 'Synchronous result)- -> Timeout- -> Eff r result+callWithTimeout ::+ forall result destination protocol r q.+ ( HasProcesses r q,+ TangiblePdu destination ('Synchronous result),+ Tangible result,+ Member Logs q,+ Member Logs r,+ HasCallStack,+ Embeds destination protocol+ ) =>+ Endpoint destination ->+ Pdu protocol ('Synchronous result) ->+ Timeout ->+ Eff r result callWithTimeout serverP@(Endpoint pidInternal) req timeOut = do fromPid <- self callRef <- makeReference@@ -119,26 +120,33 @@ origin = RequestOrigin @destination @result fromPid callRef sendMessage pidInternal requestMessage let selectResult =- let extractResult- :: Reply destination result -> Maybe result+ let extractResult ::+ Reply destination result -> Maybe result extractResult (Reply origin' result) = if origin == origin' then Just result else Nothing- in selectMessageWith extractResult- let timerTitle = MkProcessTitle ( "call-timer-" <> pack (show serverP)- <> "-" <> pack (show origin)- <> "-" <> pack (show timeOut))- resultOrError <- receiveSelectedWithMonitorAfterWithTitle pidInternal selectResult timeOut timerTitle+ in selectMessageWith extractResult+ let timerTitle = MkProcessTitle (packLogMsg "call-timeout")+ initialLog =+ packLogMsg "call-timeout from: "+ <> toLogMsg fromPid+ <> packLogMsg " to: "+ <> toLogMsg serverP+ resultOrError <- receiveSelectedWithMonitorAfterWithTitle pidInternal selectResult timeOut timerTitle initialLog let onTimeout timerRef = do- let msg = "call timed out after "- ++ show timeOut ++ " to server: "- ++ show serverP ++ " from "- ++ show fromPid ++ " "- ++ show timerRef- logWarning' msg+ let msg =+ packLogMsg "call-timeout "+ <> toLogMsg timerRef+ <> packLogMsg " for call from "+ <> toLogMsg fromPid+ <> packLogMsg " to "+ <> toLogMsg serverP+ <> packLogMsg " timed out after "+ <> toLogMsg timeOut+ logWarning msg interrupt (TimeoutInterrupt msg) onProcDown p = do- logWarning' ("call to dead server: "++ show serverP ++ " from " ++ show fromPid)- interrupt (becauseProcessIsDown p)+ logWarning (LABEL "call to dead server" serverP) (LABEL "from" fromPid)+ interrupt (becauseOtherProcessNotRunning p) either (either onProcDown onTimeout) return resultOrError -- | Instead of passing around a 'Endpoint' value and passing to functions like@@ -147,8 +155,8 @@ -- convenience to express that an effect has 'Process' and a reader for a -- 'Endpoint'. type HasEndpointReader o r =- ( Typeable o- , Member (EndpointReader o) r+ ( Typeable o,+ Member (EndpointReader o) r ) -- | The reader effect for 'ProcessId's for 'Pdu's, see 'runEndpointReader'@@ -156,8 +164,7 @@ -- | Run a reader effect that contains __the one__ server handling a specific -- 'Pdu' instance.-runEndpointReader- :: HasCallStack => Endpoint o -> Eff (EndpointReader o ': r) a -> Eff r a+runEndpointReader :: Endpoint o -> Eff (EndpointReader o ': r) a -> Eff r a runEndpointReader = runReader -- | Get the 'Endpoint' registered with 'runEndpointReader'.@@ -168,17 +175,16 @@ -- 'runEndpointReader'. -- -- When working with an embedded 'Pdu' use 'callSingleton'.-callEndpointReader- :: forall reply o r q .- ( HasEndpointReader o r- , HasCallStack- , Tangible reply- , TangiblePdu o ( 'Synchronous reply)- , HasProcesses r q- , Embeds o o- )- => Pdu o ( 'Synchronous reply)- -> Eff r reply+callEndpointReader ::+ forall reply o r q.+ ( HasEndpointReader o r,+ Tangible reply,+ TangiblePdu o ('Synchronous reply),+ HasProcesses r q,+ Embeds o o+ ) =>+ Pdu o ('Synchronous reply) ->+ Eff r reply callEndpointReader method = do serverPid <- askEndpoint @o call @reply @o @o serverPid method@@ -187,17 +193,15 @@ -- 'runEndpointReader'. -- -- When working with an embedded 'Pdu' use 'castSingleton'.-castEndpointReader- :: forall o r q .- ( HasEndpointReader o r- , HasProcesses r q- , Tangible (Pdu o 'Asynchronous)- , HasCallStack- , HasPdu o- , Embeds o o- )- => Pdu o 'Asynchronous- -> Eff r ()+castEndpointReader ::+ forall o r q.+ ( HasEndpointReader o r,+ HasProcesses r q,+ TangiblePdu o 'Asynchronous,+ Embeds o o+ ) =>+ Pdu o 'Asynchronous ->+ Eff r () castEndpointReader method = do serverPid <- askEndpoint @o cast @o @o serverPid method@@ -209,19 +213,18 @@ -- When not working with an embedded 'Pdu' use 'callEndpointReader'. -- -- @since 0.25.1-callSingleton- :: forall outer inner reply q e- . ( HasCallStack- , Member (EndpointReader outer) e- , Embeds outer inner- , Embeds outer outer- , HasProcesses e q- , TangiblePdu outer ('Synchronous reply)- , TangiblePdu inner ('Synchronous reply)- , Tangible reply- )- => Pdu inner ('Synchronous reply)- -> Eff e reply+callSingleton ::+ forall outer inner reply q e.+ ( HasCallStack,+ Member (EndpointReader outer) e,+ Embeds outer inner,+ Embeds outer outer,+ HasProcesses e q,+ TangiblePdu outer ('Synchronous reply),+ Tangible reply+ ) =>+ Pdu inner ('Synchronous reply) ->+ Eff e reply callSingleton = withFrozenCallStack $ \p -> callEndpointReader (embedPdu @outer @inner p) -- | Like 'castEndpointReader', but uses 'embedPdu' to embed the value.@@ -231,17 +234,15 @@ -- When not working with an embedded 'Pdu' use 'castEndpointReader'. -- -- @since 0.25.1-castSingleton- :: forall outer inner q e- . ( HasCallStack- , Member (EndpointReader outer) e- , Tangible (Pdu outer 'Asynchronous)- , HasProcesses e q- , HasPdu outer- , HasPdu inner- , Embeds outer inner- , Embeds outer outer- )- => Pdu inner 'Asynchronous- -> Eff e ()+castSingleton ::+ forall outer inner q e.+ ( HasCallStack,+ Member (EndpointReader outer) e,+ HasProcesses e q,+ TangiblePdu outer 'Asynchronous,+ Embeds outer inner,+ Embeds outer outer+ ) =>+ Pdu inner 'Asynchronous ->+ Eff e () castSingleton = withFrozenCallStack $ \p -> castEndpointReader (embedPdu @outer @inner p)
src/Control/Eff/Concurrent/Protocol/EffectfulServer.hs view
@@ -2,31 +2,26 @@ -- -- @since 0.24.0 module Control.Eff.Concurrent.Protocol.EffectfulServer- ( Server(..)- , Event(..)- , start- , startLink- , protocolServerLoop+ ( Server (..),+ Event (..),+ start,+ startLink,+ protocolServerLoop, )- where+where import Control.Applicative import Control.DeepSeq import Control.Eff-import Control.Eff.Concurrent.Misc-import Control.Eff.Extend () import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Process.Timer import Control.Eff.Concurrent.Protocol import Control.Eff.Concurrent.Protocol.Wrapper+import Control.Eff.Extend () import Control.Eff.Log import Control.Lens import Data.Kind-import Data.String import Data.Typeable-import Data.Type.Pretty-import qualified Data.Text as T-import GHC.Stack (HasCallStack) -- | A type class for effectful server loops. --@@ -40,8 +35,7 @@ -- instances exist, like 2-,3-,4-, or 5-tuple. -- -- @since 0.24.1-class Server (a :: Type) (e :: [Type -> Type])- where+class (ToLogMsg (Init a)) => Server (a :: Type) (e :: [Type -> Type]) where -- | The value that defines what is required to initiate a 'Server' -- loop. data Init a@@ -49,100 +43,109 @@ -- | The index type of the 'Event's that this server processes. -- This is the first parameter to the 'Request' and therefore of -- the 'Pdu' family.- type ServerPdu a :: Type+ type ServerPdu a :: Type -- TODO get rid of ...+ type ServerPdu a = a -- | Effects of the implementation -- -- @since 0.24.1 type ServerEffects a e :: [Type -> Type]+ type ServerEffects a e = e -- | Return the 'ProcessTitle'. -- -- Usually you should rely on the default implementation serverTitle :: Init a -> ProcessTitle-- default serverTitle :: Typeable a => Init a -> ProcessTitle- serverTitle _ = fromString $ showSTypeable @a ""+ default serverTitle :: ToTypeLogMsg a => Init a -> ProcessTitle+ serverTitle x = MkProcessTitle (toTypeLogMsg x) -- | Process the effects of the implementation runEffects :: Endpoint (ServerPdu a) -> Init a -> Eff (ServerEffects a e) x -> Eff e x- default runEffects :: ServerEffects a e ~ e => Endpoint (ServerPdu a) -> Init a -> Eff (ServerEffects a e) x -> Eff e x runEffects _ = const id -- | Update the 'Model' based on the 'Event'. onEvent :: Endpoint (ServerPdu a) -> Init a -> Event (ServerPdu a) -> Eff (ServerEffects a e) ()+ default onEvent :: (Member Logs (ServerEffects a e)) => Endpoint (ServerPdu a) -> Init a -> Event (ServerPdu a) -> Eff (ServerEffects a e) ()+ onEvent _ i e = logInfo (MkUnhandledEvent i e) - default onEvent :: (Show (Init a), Member Logs (ServerEffects a e)) => Endpoint (ServerPdu a) -> Init a -> Event (ServerPdu a) -> Eff (ServerEffects a e) ()- onEvent _ i e = logInfo ("unhandled: " <> T.pack (show i) <> " " <> T.pack (show e))+data UnhandledEvent a where+ MkUnhandledEvent ::+ ( ToLogMsg (Init a),+ ToLogMsg (Event (ServerPdu a))+ ) =>+ Init a ->+ Event (ServerPdu a) ->+ UnhandledEvent a +instance ToLogMsg (UnhandledEvent a) where+ toLogMsg (MkUnhandledEvent i e) = packLogMsg "unhandled event: " <> toLogMsg e <> packLogMsg " init: " <> toLogMsg i -- | Execute the server loop. -- -- @since 0.24.0-start- :: forall a r q- . ( Server a (Processes q)- , Typeable a- , Typeable (ServerPdu a)- , FilteredLogging (Processes q)- , HasProcesses (ServerEffects a (Processes q)) q- , HasProcesses r q- , HasCallStack)- => Init a- -> Eff r (Endpoint (ServerPdu a))+start ::+ forall a r q.+ ( Server a (Processes q),+ Typeable (ServerPdu a),+ FilteredLogging (Processes q),+ HasProcesses (ServerEffects a (Processes q)) q,+ HasProcesses r q+ ) =>+ Init a ->+ Eff r (Endpoint (ServerPdu a)) start a = asEndpoint <$> spawn (serverTitle @_ @(Processes q) a) (protocolServerLoop a) -- | Execute the server loop. -- -- @since 0.24.0-startLink- :: forall a r q- . ( Typeable a- , Typeable (ServerPdu a)- , Server a (Processes q)- , FilteredLogging (Processes q)- , HasProcesses (ServerEffects a (Processes q)) q- , HasProcesses r q- , HasCallStack)- => Init a- -> Eff r (Endpoint (ServerPdu a))+startLink ::+ forall a r q.+ ( Typeable (ServerPdu a),+ Server a (Processes q),+ FilteredLogging (Processes q),+ HasProcesses (ServerEffects a (Processes q)) q,+ HasProcesses r q+ ) =>+ Init a ->+ Eff r (Endpoint (ServerPdu a)) startLink a = asEndpoint <$> spawnLink (serverTitle @_ @(Processes q) a) (protocolServerLoop a) -- | Execute the server loop. -- -- @since 0.24.0-protocolServerLoop- :: forall q a- . ( Server a (Processes q)- , FilteredLogging (Processes q)- , HasProcesses (ServerEffects a (Processes q)) q- , Typeable a- , Typeable (ServerPdu a)- )- => Init a -> Eff (Processes q) ()+protocolServerLoop ::+ forall q a.+ ( Server a (Processes q),+ FilteredLogging (Processes q),+ HasProcesses (ServerEffects a (Processes q)) q,+ Typeable (ServerPdu a)+ ) =>+ Init a ->+ Eff (Processes q) () protocolServerLoop a = do myEp <- asEndpoint @(ServerPdu a) <$> self- logDebug ("starting")- runEffects myEp a (receiveSelectedLoop sel (mainLoop myEp))+ logDebug ("starting" :: String)+ runEffects myEp a (receiveSelectedLoop sel (mainLoop myEp)) return () where sel :: MessageSelector (Event (ServerPdu a))- sel = onRequest <$> selectMessage @(Request (ServerPdu a))- <|> OnDown <$> selectMessage @ProcessDown- <|> OnTimeOut <$> selectMessage @TimerElapsed- <|> OnMessage <$> selectAnyMessage+ sel =+ onRequest <$> selectMessage @(Request (ServerPdu a))+ <|> OnDown <$> selectMessage @ProcessDown+ <|> OnTimeOut <$> selectMessage @TimerElapsed+ <|> OnMessage <$> selectAnyMessage where onRequest :: Request (ServerPdu a) -> Event (ServerPdu a)- onRequest (Call o m) = OnCall (replyTarget (MkSerializer toStrictDynamic) o) m+ onRequest (Call o m) = OnCall (replyTarget (MkSerializer toMessage) o) m onRequest (Cast m) = OnCast m handleInt myEp i = onEvent @_ @(Processes q) myEp a (OnInterrupt i) *> pure Nothing- mainLoop :: (Typeable a)- => Endpoint (ServerPdu a)- -> Either (Interrupt 'Recoverable) (Event (ServerPdu a))- -> Eff (ServerEffects a (Processes q)) (Maybe ())+ mainLoop ::+ Endpoint (ServerPdu a) ->+ Either InterruptReason (Event (ServerPdu a)) ->+ Eff (ServerEffects a (Processes q)) (Maybe ()) mainLoop myEp (Left i) = handleInt myEp i mainLoop myEp (Right i) = onEvent @_ @(Processes q) myEp a i *> pure Nothing @@ -155,40 +158,44 @@ -- use 'toEmbeddedReplyTarget' to convert a 'ReplyTarget' safely to the embedded protocol. -- -- @since 0.24.1- OnCall- :: forall a r. (Tangible r, TangiblePdu a ('Synchronous r))- => ReplyTarget a r- -> Pdu a ('Synchronous r)- -> Event a- OnCast- :: forall a. TangiblePdu a 'Asynchronous- => Pdu a 'Asynchronous- -> Event a- OnInterrupt :: Interrupt 'Recoverable -> Event a+ OnCall ::+ forall a r.+ ( Tangible r,+ TangiblePdu a ('Synchronous r),+ ToLogMsg (Pdu a ('Synchronous r))+ ) =>+ ReplyTarget a r ->+ Pdu a ('Synchronous r) ->+ Event a+ OnCast ::+ forall a.+ ( TangiblePdu a 'Asynchronous,+ ToLogMsg (Pdu a 'Asynchronous)+ ) =>+ Pdu a 'Asynchronous ->+ Event a+ OnInterrupt :: InterruptReason -> Event a OnDown :: ProcessDown -> Event a OnTimeOut :: TimerElapsed -> Event a- OnMessage :: StrictDynamic -> Event a- deriving Typeable--instance Show (Event a) where- showsPrec d e =- showParen (d>=10) $- showString "event: "- . case e of- OnCall o p -> shows (Call (view replyTargetOrigin o) p)- OnCast p -> shows (Cast p)- OnInterrupt r -> shows r- OnDown r -> shows r- OnTimeOut r -> shows r- OnMessage r -> shows r+ OnMessage :: Message -> Event a+ deriving (Typeable) -instance NFData a => NFData (Event a) where- rnf = \case- OnCall o p -> rnf o `seq` rnf p- OnCast p -> rnf p- OnInterrupt r -> rnf r- OnDown r -> rnf r- OnTimeOut r -> rnf r- OnMessage r -> r `seq` ()+instance ToLogMsg (Event a) where+ toLogMsg x =+ packLogMsg "event: "+ <> case x of+ OnCall o p -> toLogMsg (Call (view replyTargetOrigin o) p)+ OnCast p -> toLogMsg (Cast p)+ OnInterrupt r -> toLogMsg r+ OnDown r -> toLogMsg r+ OnTimeOut r -> toLogMsg r+ OnMessage r -> packLogMsg "message: " <> packLogMsg (show r) -type instance ToPretty (Event a) = ToPretty a <+> PutStr "event"+instance NFData (Event a) where+ rnf = \case+ OnCall o p -> rnf o `seq` rnf p+ OnCast p -> rnf p+ OnInterrupt r -> rnf r+ OnDown r -> rnf r+ OnTimeOut r -> rnf r+ OnMessage r -> r `seq` ()
src/Control/Eff/Concurrent/Protocol/Observer.hs view
@@ -10,44 +10,42 @@ -- -- @since 0.16.0 module Control.Eff.Concurrent.Protocol.Observer- ( Observer(..)- , ObservationSink()- , IsObservable- , CanObserve- , Pdu(RegisterObserver, ForgetObserver, Observed)- , registerObserver- , forgetObserver- , forgetObserverUnsafe- , ObserverRegistry(..)- , ObserverRegistryState- , observerRegistryNotify- , evalObserverRegistryState- , emptyObserverRegistry- , observerRegistryHandlePdu- , observerRegistryRemoveProcess+ ( Observer (..),+ ObservationSink (),+ IsObservable,+ CanObserve,+ Pdu (RegisterObserver, ForgetObserver, Observed),+ registerObserver,+ forgetObserver,+ forgetObserverUnsafe,+ ObserverRegistry (..),+ ObserverRegistryState,+ observerRegistryNotify,+ evalObserverRegistryState,+ emptyObserverRegistry,+ observerRegistryHandlePdu,+ observerRegistryRemoveProcess, ) where -import Control.DeepSeq ( NFData(rnf) )-import Control.Eff-import Control.Eff.Concurrent.Misc-import Control.Eff.Concurrent.Process-import Control.Eff.Concurrent.Protocol-import Control.Eff.Concurrent.Protocol.Client-import Control.Eff.Concurrent.Protocol.Wrapper (Request(Cast))-import Control.Eff.State.Strict-import Control.Eff.Log-import Control.Lens-import Control.Monad-import Data.Dynamic-import Data.Kind-import Data.Semigroup-import Data.Map ( Map )-import qualified Data.Map as Map-import Data.Text ( pack )-import Data.Type.Pretty-import GHC.Generics-import GHC.Stack+import Control.DeepSeq (NFData (rnf))+import Control.Eff+import Control.Eff.Concurrent.Process+import Control.Eff.Concurrent.Protocol+import Control.Eff.Concurrent.Protocol.Client+import Control.Eff.Concurrent.Protocol.Wrapper (Request (Cast))+import Control.Eff.Log+import Control.Eff.State.Strict+import Control.Lens+import Control.Monad+import Data.Dynamic+import Data.Kind+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Proxy+import Data.Semigroup+import GHC.Generics+import GHC.Stack -- * Observers @@ -66,42 +64,40 @@ -- while the 'ProcessId' serves as key for internal maps. -- -- @since 0.28.0-newtype Observer event =- MkObserver (Arg ProcessId (ObservationSink event))+newtype Observer event+ = MkObserver (Arg ProcessId (ObservationSink event)) deriving (Eq, Ord, Typeable) -instance NFData (Observer event) where- rnf (MkObserver (Arg x y)) = rnf x `seq` rnf y+instance ToTypeLogMsg event => ToLogMsg (Observer event) where+ toLogMsg (MkObserver (Arg t _)) = toTypeLogMsg (Proxy @(Observer event)) <> toLogMsg t -instance Typeable event => Show (Observer event) where- showsPrec d (MkObserver (Arg x (MkObservationSink _ m))) =- showParen (d>=10) (showString "observer: " . showSTypeable @event . showString " ". showsPrec 10 x . showChar ' ' . showsPrec 10 m )+instance ToTypeLogMsg event => ToTypeLogMsg (Observer event) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @event) <> packLogMsg "_observer" -type instance ToPretty (Observer event) =- PrettyParens ("observing" <:> ToPretty event)+instance NFData (Observer event) where+ rnf (MkObserver (Arg x y)) = rnf x `seq` rnf y instance (Tangible event) => HasPdu (Observer event) where data Pdu (Observer event) r where Observed :: event -> Pdu (Observer event) 'Asynchronous- deriving Typeable+ deriving (Typeable) instance NFData event => NFData (Pdu (Observer event) r) where rnf (Observed event) = rnf event -instance Show event => Show (Pdu (Observer event) r) where- showsPrec d (Observed event) =- showParen (d >= 10) (showString "observered: " . showsPrec 10 event)+instance ToLogMsg event => ToLogMsg (Pdu (Observer event) r) where+ toLogMsg (Observed event) =+ packLogMsg "observed: " <> toLogMsg event -- | The Information necessary to wrap an 'Observed' event to a process specific -- message, e.g. the embedded 'Observer' 'Pdu' instance, and the 'MonitorReference' of -- the destination process. -- -- @since 0.28.0-data ObservationSink event =- MkObservationSink- { _observerSerializer :: Serializer (Pdu (Observer event) 'Asynchronous)- , _observerMonitorReference :: MonitorReference- }+data ObservationSink event = MkObservationSink+ { _observerSerializer :: Serializer (Pdu (Observer event) 'Asynchronous),+ _observerMonitorReference :: MonitorReference+ } deriving (Generic, Typeable) instance NFData (ObservationSink event) where@@ -111,18 +107,20 @@ -- -- @since 0.28.0 type IsObservable eventSource event =- ( Tangible event- , Embeds eventSource (ObserverRegistry event)- , HasPdu eventSource+ ( Tangible event,+ Embeds eventSource (ObserverRegistry event),+ HasPdu eventSource,+ ToTypeLogMsg event,+ ToLogMsg event ) -- | Convenience type alias. -- -- @since 0.28.0 type CanObserve eventSink event =- ( Tangible event- , Embeds eventSink (Observer event)- , HasPdu eventSink+ ( Tangible event,+ Embeds eventSink (Observer event),+ HasPdu eventSink ) -- | And an 'Observer' to the set of recipients for all observations reported by 'observerRegistryNotify'.@@ -131,60 +129,54 @@ -- combine several filter functions. -- -- @since 0.16.0-registerObserver- :: forall event eventSink eventSource r q .- ( HasCallStack- , HasProcesses r q- , IsObservable eventSource event- , Tangible (Pdu eventSource 'Asynchronous)- , Tangible (Pdu eventSink 'Asynchronous)- , CanObserve eventSink event- )- => Endpoint eventSource- -> Endpoint eventSink- -> Eff r ()+registerObserver ::+ forall event eventSink eventSource r q.+ ( HasProcesses r q,+ TangiblePdu eventSource 'Asynchronous,+ IsObservable eventSource event,+ TangiblePdu eventSink 'Asynchronous,+ CanObserve eventSink event+ ) =>+ Endpoint eventSource ->+ Endpoint eventSink ->+ Eff r () registerObserver eventSource eventSink =- cast eventSource (RegisterObserver serializer (eventSink ^. fromEndpoint))- where- serializer =- MkSerializer- ( toStrictDynamic- . Cast- . embedPdu @eventSink @(Observer event) @( 'Asynchronous )- )-+ cast eventSource (RegisterObserver serializer (eventSink ^. fromEndpoint))+ where+ serializer =+ MkSerializer+ ( toMessage+ . Cast+ . embedPdu @eventSink @(Observer event) @('Asynchronous)+ ) -- | Send the 'ForgetObserver' message -- -- @since 0.16.0-forgetObserver- :: forall event eventSink eventSource r q .- ( HasProcesses r q- , HasCallStack- , Tangible (Pdu eventSource 'Asynchronous)- , Tangible (Pdu eventSink 'Asynchronous)- , IsObservable eventSource event- , CanObserve eventSink event- )- => Endpoint eventSource- -> Endpoint eventSink- -> Eff r ()+forgetObserver ::+ forall event eventSink eventSource r q.+ ( HasProcesses r q,+ TangiblePdu eventSource 'Asynchronous,+ IsObservable eventSource event+ ) =>+ Endpoint eventSource ->+ Endpoint eventSink ->+ Eff r () forgetObserver eventSource eventSink = forgetObserverUnsafe @event @eventSource eventSource (eventSink ^. fromEndpoint) -- | Send the 'ForgetObserver' message, use a raw 'ProcessId' as parameter. -- -- @since 0.28.0-forgetObserverUnsafe- :: forall event eventSource r q .- ( HasProcesses r q- , HasCallStack- , Tangible (Pdu eventSource 'Asynchronous)- , IsObservable eventSource event- )- => Endpoint eventSource- -> ProcessId- -> Eff r ()+forgetObserverUnsafe ::+ forall event eventSource r q.+ ( HasProcesses r q,+ TangiblePdu eventSource 'Asynchronous,+ IsObservable eventSource event+ ) =>+ Endpoint eventSource ->+ ProcessId ->+ Eff r () forgetObserverUnsafe eventSource eventSink = cast eventSource (ForgetObserver @event eventSink) @@ -197,19 +189,14 @@ -- -- @since 0.28.0 data ObserverRegistry (event :: Type) = MkObserverRegistry- { _observerRegistry :: Map ProcessId (ObservationSink event) }- deriving Typeable+ {_observerRegistry :: Map ProcessId (ObservationSink event)}+ deriving (Typeable) -type instance ToPretty (ObserverRegistry event) =- PrettyParens ("observer registry" <:> ToPretty event)+instance ToTypeLogMsg event => ToTypeLogMsg (ObserverRegistry event) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @event) <> packLogMsg "_observer_registry_event" instance (Tangible event) => HasPdu (ObserverRegistry event) where-- -- | Protocol for managing observers. This can be added to any server for any number of different observation types.- -- The functions 'evalObserverRegistryState' and 'observerRegistryHandlePdu' are used to include observer handling;- --- -- @since 0.16.0- data instance Pdu (ObserverRegistry event) r where+ data Pdu (ObserverRegistry event) r where -- | This message denotes that the given 'Observer' should receive observations until 'ForgetObserver' is -- received. --@@ -218,20 +205,20 @@ -- | This message denotes that the given 'Observer' should not receive observations anymore. -- -- @since 0.16.1- ForgetObserver :: ProcessId -> Pdu (ObserverRegistry event) 'Asynchronous--- -- | This message denotes that a monitored process died--- ----- -- @since 0.28.0--- ObserverMightBeDown :: MonitorReference -> Pdu (ObserverRegistry event) ( 'Synchronous Bool)- deriving Typeable+ ForgetObserver :: ProcessId -> Pdu (ObserverRegistry event) 'Asynchronous+ -- -- | This message denotes that a monitored process died+ -- --+ -- -- @since 0.28.0+ -- ObserverMightBeDown :: MonitorReference -> Pdu (ObserverRegistry event) ( 'Synchronous Bool)+ deriving (Typeable) instance NFData (Pdu (ObserverRegistry event) r) where rnf (RegisterObserver ser pid) = rnf ser `seq` rnf pid rnf (ForgetObserver pid) = rnf pid -instance Typeable event => Show (Pdu (ObserverRegistry event) r) where- showsPrec d (RegisterObserver ser pid) = showParen (d >= 10) (showString "register observer: " . shows ser . showChar ' ' . shows pid)- showsPrec d (ForgetObserver p) = showParen (d >= 10) (showString "forget observer: " . shows p)+instance ToTypeLogMsg event => ToLogMsg (Pdu (ObserverRegistry event) r) where+ toLogMsg (RegisterObserver _ser pid) = packLogMsg "register " <> toTypeLogMsg (Proxy @event) <> packLogMsg " observer " <> toLogMsg pid+ toLogMsg (ForgetObserver pid) = packLogMsg "forget " <> toTypeLogMsg (Proxy @event) <> packLogMsg " observer " <> toLogMsg pid -- ** Protocol for integrating 'ObserverRegistry' into processes. @@ -239,46 +226,48 @@ -- messages. It also adds the 'ObserverRegistryState' constraint to the effect list. -- -- @since 0.28.0-observerRegistryHandlePdu- :: forall event q r- . ( HasCallStack- , Typeable event- , HasProcesses r q- , Member (ObserverRegistryState event) r- , Member Logs r- )- => Pdu (ObserverRegistry event) 'Asynchronous -> Eff r ()+observerRegistryHandlePdu ::+ forall event q r.+ ( HasCallStack,+ ToTypeLogMsg event,+ HasProcesses r q,+ Member (ObserverRegistryState event) r,+ Member Logs r+ ) =>+ Pdu (ObserverRegistry event) 'Asynchronous ->+ Eff r () observerRegistryHandlePdu = \case- RegisterObserver ser pid -> do- monRef <- monitor pid- let sink = MkObservationSink ser monRef- observer = MkObserver (Arg pid sink)- modify @(ObserverRegistry event) (over observerRegistry (Map.insert pid sink))- os <- get @(ObserverRegistry event)- logDebug ( "registered "- <> pack (show observer)- <> " current number of observers: " -- TODO put this info into the process details- <> pack (show (Map.size (view observerRegistry os))))-- ForgetObserver ob -> do- wasRemoved <- observerRegistryRemoveProcess @event ob- unless wasRemoved $- logDebug (pack (show ("unknown observer " ++ show ob)))-+ RegisterObserver ser pid -> do+ monRef <- monitor pid+ let sink = MkObservationSink ser monRef+ observer = MkObserver (Arg pid sink)+ modify @(ObserverRegistry event) (over observerRegistry (Map.insert pid sink))+ os <- get @(ObserverRegistry event)+ logDebug+ (LABEL "registered" observer)+ ( LABEL+ "current number of observers" -- TODO put this info into the process details+ (Map.size (view observerRegistry os))+ )+ ForgetObserver ob -> do+ wasRemoved <- observerRegistryRemoveProcess @event ob+ unless wasRemoved $+ logDebug (LABEL "unknown observer " ob) -- | Remove the entry in the 'ObserverRegistry' for the 'ProcessId' -- and return 'True' if there was an entry, 'False' otherwise. -- -- @since 0.28.0-observerRegistryRemoveProcess- :: forall event q r- . ( HasCallStack- , Typeable event- , HasProcesses r q- , Member (ObserverRegistryState event) r- , Member Logs r- )- => ProcessId -> Eff r Bool+observerRegistryRemoveProcess ::+ forall event q r.+ ( HasCallStack,+ ToTypeLogMsg event,+ HasProcesses r q,+ Member (ObserverRegistryState event) r,+ Member Logs r+ ) =>+ ProcessId ->+ Eff r Bool observerRegistryRemoveProcess ob = do mSink <- view (observerRegistry . at ob) <$> get @(ObserverRegistry event) modify @(ObserverRegistry event) (observerRegistry . at ob .~ Nothing)@@ -287,21 +276,20 @@ (pure False) (foundIt os) mSink- where- foundIt os sink@(MkObservationSink _ monRef) = do- demonitor monRef- logDebug ( "removed: "- <> (pack $ show $ MkObserver $ Arg ob sink)- <> " current number of observers: "- <> pack (show (Map.size (view observerRegistry os))))- pure True+ where+ foundIt os sink@(MkObservationSink _ monRef) = do+ demonitor monRef+ logDebug+ (LABEL "removed" (MkObserver $ Arg ob sink))+ (LABEL "current number of observers" (Map.size (view observerRegistry os)))+ pure True -- | Keep track of registered 'Observer's. -- -- Handle the 'ObserverRegistryState' effect, i.e. run 'evalState' on an 'emptyObserverRegistry'. -- -- @since 0.28.0-evalObserverRegistryState :: HasCallStack => Eff (ObserverRegistryState event ': r) a -> Eff r a+evalObserverRegistryState :: Eff (ObserverRegistryState event ': r) a -> Eff r a evalObserverRegistryState = evalState emptyObserverRegistry -- | The empty 'ObserverRegistryState'@@ -321,18 +309,16 @@ -- The process needs to 'evalObserverRegistryState' and to 'observerRegistryHandlePdu'. -- -- @since 0.28.0-observerRegistryNotify- :: forall event r q- . ( HasProcesses r q- , Member (ObserverRegistryState event) r- , Tangible event- , HasCallStack- )- => event- -> Eff r ()+observerRegistryNotify ::+ forall event r q.+ ( HasProcesses r q,+ Member (ObserverRegistryState event) r+ ) =>+ event ->+ Eff r () observerRegistryNotify observation = do os <- view observerRegistry <$> get mapM_ notifySomeObserver (Map.assocs os)- where- notifySomeObserver (destination, (MkObservationSink serializer _)) =- sendAnyMessage destination (runSerializer serializer (Observed observation))+ where+ notifySomeObserver (destination, (MkObservationSink serializer _)) =+ sendAnyMessage destination (runSerializer serializer (Observed observation))
src/Control/Eff/Concurrent/Protocol/Observer/Queue.hs view
@@ -1,33 +1,32 @@ {-# LANGUAGE UndecidableInstances #-}+ -- | A small process to capture and _share_ observation's by enqueueing them into an STM 'TBQueue'. module Control.Eff.Concurrent.Protocol.Observer.Queue- ( ObservationQueue(..)- , Reader- , observe- , await- , tryRead- , flush+ ( ObservationQueue (..),+ Reader,+ observe,+ await,+ tryRead,+ flush, ) where -import Control.Concurrent.STM-import Control.Eff-import Control.Eff.Concurrent.Misc-import Control.Eff.Concurrent.Protocol-import Control.Eff.Concurrent.Protocol.Observer-import Control.Eff.Concurrent.Protocol.StatefulServer-import Control.Eff.Concurrent.Process-import Control.Eff.ExceptionExtra ( )-import Control.Eff.Log-import qualified Control.Eff.Reader.Strict as Eff-import Control.Exception.Safe as Safe-import Control.Lens-import Control.Monad.IO.Class-import Control.Monad ( unless, when )-import qualified Data.Text as T-import Data.Typeable-import GHC.Stack+import Control.Concurrent.STM+import Control.Eff+import Control.Eff.Concurrent.Process+import Control.Eff.Concurrent.Protocol+import Control.Eff.Concurrent.Protocol.Observer+import Control.Eff.Concurrent.Protocol.StatefulServer+import Control.Eff.ExceptionExtra ()+import Control.Eff.Log+import qualified Control.Eff.Reader.Strict as Eff+import Control.Exception.Safe as Safe+import Control.Lens+import Control.Monad (unless, when)+import Control.Monad.IO.Class import Data.Default (Default)+import Data.Proxy+import GHC.Stack -- | Contains a 'TBQueue' capturing observations. -- See 'observe'.@@ -36,24 +35,24 @@ -- | A 'Reader' for an 'ObservationQueue'. type Reader a = Eff.Reader (ObservationQueue a) -logPrefix :: forall event proxy . (HasCallStack, Typeable event) => proxy event -> T.Text-logPrefix _px = "observation queue: " <> T.pack (showSTypeable @event "")+instance ToTypeLogMsg event => ToTypeLogMsg (ObservationQueue event) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @event) <> packLogMsg "_observations" +instance ToTypeLogMsg event => ToLogMsg (ObservationQueue event) where+ toLogMsg _ = toTypeLogMsg (Proxy @(ObservationQueue event))+ -- | Read queued observations captured and enqueued in the shared 'ObservationQueue' by 'observe'. -- -- This blocks until something was captured or an interrupt or exceptions was thrown. For a non-blocking -- variant use 'tryRead' or 'flush'. -- -- @since 0.28.0-await- :: forall event r- . ( Member (Reader event) r- , HasCallStack- , MonadIO (Eff r)- , Typeable event- , Member Logs r- )- => Eff r event+await ::+ forall event r.+ ( Member (Reader event) r,+ MonadIO (Eff r)+ ) =>+ Eff r event await = do ObservationQueue q <- Eff.ask @(ObservationQueue event) liftIO (atomically (readTBQueue q))@@ -64,15 +63,12 @@ -- Use 'await' to block until an observation is observerRegistryNotify. -- -- @since 0.28.0-tryRead- :: forall event r- . ( Member (Reader event) r- , HasCallStack- , MonadIO (Eff r)- , Typeable event- , Member Logs r- )- => Eff r (Maybe event)+tryRead ::+ forall event r.+ ( Member (Reader event) r,+ MonadIO (Eff r)+ ) =>+ Eff r (Maybe event) tryRead = do ObservationQueue q <- Eff.ask @(ObservationQueue event) liftIO (atomically (tryReadTBQueue q))@@ -84,15 +80,12 @@ -- For a blocking variant use 'await'. -- -- @since 0.28.0-flush- :: forall event r- . ( Member (Reader event) r- , HasCallStack- , MonadIO (Eff r)- , Typeable event- , Member Logs r- )- => Eff r [event]+flush ::+ forall event r.+ ( Member (Reader event) r,+ MonadIO (Eff r)+ ) =>+ Eff r [event] flush = do ObservationQueue q <- Eff.ask @(ObservationQueue event) liftIO (atomically (flushTBQueue q))@@ -124,50 +117,58 @@ -- @ -- -- @since 0.28.0-observe- :: forall event eventSource e q len b- . ( HasCallStack- , HasProcesses e q- , FilteredLogging e- , FilteredLogging q- , FilteredLogging (Processes q)- , Lifted IO e- , Lifted IO q- , IsObservable eventSource event- , Integral len- , Server (ObservationQueue event) (Processes q)- , Tangible (Pdu eventSource 'Asynchronous)- )- => len- -> Endpoint eventSource- -> Eff (Reader event ': e) b- -> Eff e b+observe ::+ forall event eventSource e q len b.+ ( HasCallStack,+ HasProcesses e q,+ FilteredLogging e,+ FilteredLogging q,+ FilteredLogging (Processes q),+ Lifted IO e,+ Lifted IO q,+ IsObservable eventSource event,+ Integral len,+ TangiblePdu eventSource 'Asynchronous+ ) =>+ len ->+ Endpoint eventSource ->+ Eff (Reader event ': e) b ->+ Eff e b observe queueLimit eventSource e = withObservationQueue queueLimit (withWriter @event eventSource e) --withObservationQueue- :: forall event b e len- . ( HasCallStack- , Typeable event- , Show event- , Member Logs e- , Lifted IO e- , Integral len- , Member Interrupts e- )- => len- -> Eff (Reader event ': e) b- -> Eff e b+withObservationQueue ::+ forall event b e len.+ ( HasCallStack,+ ToLogMsg event,+ ToTypeLogMsg event,+ Member Logs e,+ Lifted IO e,+ Integral len,+ Member Interrupts e+ ) =>+ len ->+ Eff (Reader event ': e) b ->+ Eff e b withObservationQueue queueLimit e = do- q <- lift (newTBQueueIO (fromIntegral queueLimit))- res <- handleInterrupts (return . Left)- (Right <$> Eff.runReader (ObservationQueue q) e)+ q <- lift (newTBQueueIO (fromIntegral queueLimit))+ let oq = ObservationQueue q+ res <-+ handleInterrupts+ (return . Left)+ (Right <$> Eff.runReader oq e) rest <- lift (atomically (flushTBQueue q)) unless (null rest)- (logNotice (logPrefix (Proxy @event) <> " unread observations: " <> T.pack (show rest)))- either (\em -> logError (T.pack (show em)) >> lift (throwIO em)) return res+ (mapM_ (logDebug oq . LABEL "unread observation") rest)+ either+ ( \em ->+ do+ logError em+ lift (throwIO (MkUnhandledProcessInterrupt em))+ )+ return+ res -- | Spawn a process that can be used as an 'Observer' that enqueues the observations into an -- 'ObservationQueue'. See 'withObservationQueue' for an example.@@ -177,18 +178,14 @@ -- returned by 'await'. -- -- @since 0.28.0-spawnWriter- :: forall event r q- . ( Member Logs q- , Lifted IO q- , FilteredLogging (Processes q)- , HasProcesses r q- , Typeable event- , HasCallStack- , Server (ObservationQueue event) (Processes q)- )- => ObservationQueue event- -> Eff r (Endpoint (Observer event))+spawnWriter ::+ forall event r q.+ ( FilteredLogging (Processes q),+ HasProcesses r q,+ Server (ObservationQueue event) (Processes q)+ ) =>+ ObservationQueue event ->+ Eff r (Endpoint (Observer event)) spawnWriter q = startLink @_ @r @q (MkObservationQueue q) @@ -200,37 +197,42 @@ -- returned by 'await'. -- -- @since 0.28.0-withWriter- :: forall event eventSource e q b- . ( HasCallStack- , HasProcesses e q- , Lifted IO q- , FilteredLogging (Processes q)- , Member Logs q- , IsObservable eventSource event- , Member (Reader event) e- , Tangible (Pdu eventSource 'Asynchronous)- )- => Endpoint eventSource- -> Eff e b- -> Eff e b+withWriter ::+ forall event eventSource e q b.+ ( HasProcesses e q,+ Lifted IO q,+ FilteredLogging (Processes q),+ Member Logs q,+ IsObservable eventSource event,+ Member (Reader event) e,+ TangiblePdu eventSource 'Asynchronous+ ) =>+ Endpoint eventSource ->+ Eff e b ->+ Eff e b withWriter eventSource e = do q <- Eff.ask @(ObservationQueue event) w <- spawnWriter @event q registerObserver @event eventSource w res <- e forgetObserver @event eventSource w- sendShutdown (w^.fromEndpoint) ExitNormally+ sendShutdown (w ^. fromEndpoint) ExitNormally pure res --instance (Typeable event, Lifted IO q, Member Logs q) => Server (ObservationQueue event) (Processes q) where- type instance Protocol (ObservationQueue event) = Observer event+instance+ ( Typeable event,+ Lifted IO q,+ Member Logs q,+ ToTypeLogMsg event+ ) =>+ Server (ObservationQueue event) (Processes q)+ where+ type Protocol (ObservationQueue event) = Observer event - data instance StartArgument (ObservationQueue event) =- MkObservationQueue (ObservationQueue event)+ data StartArgument (ObservationQueue event)+ = MkObservationQueue (ObservationQueue event) - newtype instance Model (ObservationQueue event) = MkObservationQueueModel () deriving Default+ newtype Model (ObservationQueue event) = MkObservationQueueModel () deriving (Default) update _ (MkObservationQueue (ObservationQueue q)) = \case@@ -240,6 +242,9 @@ unless isFull (writeTBQueue q event) pure isFull when isFull $- logWarning "queue full"+ logWarning (MSG "queue full") otherMsg ->- logError ("unexpected: " <> T.pack (show otherMsg))+ logError (LABEL "unexpected" otherMsg)++instance ToTypeLogMsg event => ToLogMsg (StartArgument (ObservationQueue event)) where+ toLogMsg (MkObservationQueue q) = toLogMsg q
src/Control/Eff/Concurrent/Protocol/StatefulServer.hs view
@@ -2,38 +2,38 @@ -- -- @since 0.24.0 module Control.Eff.Concurrent.Protocol.StatefulServer- ( Server(..)- , Stateful- , Effectful.Init(..)- , startLink- , start- , ModelState- , modifyModel- , getAndModifyModel- , modifyAndGetModel- , getModel- , putModel- , getAndPutModel- , useModel- , preuseModel- , zoomModel- , logModel- , SettingsReader- , askSettings- , viewSettings- , mapEffects- , coerceEffects- -- * Re-exports- , Effectful.Event(..)+ ( Server (..),+ Stateful,+ Effectful.Init (..),+ startLink,+ start,+ ModelState,+ modifyModel,+ getAndModifyModel,+ modifyAndGetModel,+ getModel,+ putModel,+ getAndPutModel,+ useModel,+ preuseModel,+ zoomModel,+ logModel,+ SettingsReader,+ askSettings,+ viewSettings,+ mapEffects,+ coerceEffects,++ -- * Re-exports+ Effectful.Event (..), )- where+where import Control.Eff-import Control.Eff.Concurrent.Misc import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Protocol import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful-import Control.Eff.Extend ()+import Control.Eff.Extend (raise) import Control.Eff.Log import Control.Eff.Reader.Strict import Control.Eff.State.Strict@@ -41,12 +41,10 @@ import Data.Coerce import Data.Default import Data.Kind-import Data.String (fromString)-import Data.Text (Text, pack)-import Data.Typeable-import GHC.Stack (HasCallStack)-import Control.Eff.Extend (raise) import Data.Monoid (First)+import Data.Proxy+import Data.Typeable+ -- | A type class for server loops. -- -- This class serves as interface for other mechanisms, for example /process supervision/@@ -64,23 +62,27 @@ -- 'State' and 'Reader' effect. -- -- @since 0.24.0-class (Typeable (Protocol a)) => Server (a :: Type) q where+class (ToLogMsg (StartArgument a), Typeable (Protocol a), ToTypeLogMsg (Protocol a)) => Server (a :: Type) q where -- | The value that defines what is required to initiate a 'Server' -- loop. data StartArgument a+ -- | The index type of the 'Event's that this server processes. -- This is the first parameter to the 'Request' and therefore of -- the 'Pdu' family. type Protocol a :: Type+ type Protocol a = a+ -- | Type of the /model/ data, given to every invocation of 'update' -- via the 'ModelState' effect. -- The /model/ of a server loop is changed through incoming 'Event's. -- It is initially calculated by 'setup'.- data family Model a :: Type+ data Model a :: Type -- | Type of read-only state. type Settings a :: Type+ type Settings a = () -- | Return a new 'ProcessTitle' for the stateful process,@@ -88,29 +90,27 @@ -- -- @since 0.30.0 title :: StartArgument a -> ProcessTitle-- default title :: Typeable a => StartArgument a -> ProcessTitle- title _ = fromString $ showSTypeable @a ""+ default title :: ToTypeLogMsg a => StartArgument a -> ProcessTitle+ title _ = coerce (toTypeLogMsg (Proxy @a)) -- | Return an initial 'Model' and 'Settings' setup ::- Endpoint (Protocol a)- -> StartArgument a- -> Eff q (Model a, Settings a)-+ Endpoint (Protocol a) ->+ StartArgument a ->+ Eff q (Model a, Settings a) default setup ::- (Default (Model a), Default (Settings a))- => Endpoint (Protocol a)- -> StartArgument a- -> Eff q (Model a, Settings a)+ (Default (Model a), Default (Settings a)) =>+ Endpoint (Protocol a) ->+ StartArgument a ->+ Eff q (Model a, Settings a) setup _ _ = pure (def, def) -- | Update the 'Model' based on the 'Event'. update ::- Endpoint (Protocol a)- -> StartArgument a- -> Effectful.Event (Protocol a)- -> Eff (ModelState a ': SettingsReader a ': q) ()+ Endpoint (Protocol a) ->+ StartArgument a ->+ Effectful.Event (Protocol a) ->+ Eff (ModelState a ': SettingsReader a ': q) () -- | This type is used to build stateful 'EffectfulServer' instances. --@@ -118,9 +118,12 @@ -- with 'State' and 'Reader' effects. -- -- @since 0.24.0-data Stateful a deriving Typeable+data Stateful a deriving (Typeable) -instance Server a q => Effectful.Server (Stateful a) q where+instance ToTypeLogMsg a => ToTypeLogMsg (Stateful a) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @a)++instance (ToLogMsg (StartArgument a), Server a q) => Effectful.Server (Stateful a) q where data Init (Stateful a) = Init (StartArgument a) type ServerPdu (Stateful a) = Protocol a type ServerEffects (Stateful a) q = ModelState a ': SettingsReader a ': q@@ -133,34 +136,35 @@ serverTitle (Init startArg) = title @_ @q startArg +instance (ToLogMsg (StartArgument a)) => ToLogMsg (Effectful.Init (Stateful a)) where+ toLogMsg (Init sa) = toLogMsg sa+ -- | Execute the server loop. -- -- @since 0.24.0-startLink- :: forall a r q- . ( HasCallStack- , Typeable a- , FilteredLogging (Processes q)- , Effectful.Server (Stateful a) (Processes q)- , Server a (Processes q)- , HasProcesses r q- )- => StartArgument a -> Eff r (Endpoint (Protocol a))+startLink ::+ forall a r q.+ ( FilteredLogging (Processes q),+ Effectful.Server (Stateful a) (Processes q),+ Server a (Processes q),+ HasProcesses r q+ ) =>+ StartArgument a ->+ Eff r (Endpoint (Protocol a)) startLink = Effectful.startLink . Init -- | Execute the server loop. Please use 'startLink' if you can. -- -- @since 0.24.0-start- :: forall a r q- . ( HasCallStack- , Typeable a- , Effectful.Server (Stateful a) (Processes q)- , Server a (Processes q)- , FilteredLogging (Processes q)- , HasProcesses r q- )- => StartArgument a -> Eff r (Endpoint (Protocol a))+start ::+ forall a r q.+ ( Effectful.Server (Stateful a) (Processes q),+ Server a (Processes q),+ FilteredLogging (Processes q),+ HasProcesses r q+ ) =>+ StartArgument a ->+ Eff r (Endpoint (Protocol a)) start = Effectful.start . Init -- | The 'Eff'ect type of mutable 'Model' in a 'Server' instance.@@ -171,49 +175,49 @@ -- | Modify the 'Model' of a 'Server'. -- -- @since 0.24.0-modifyModel :: forall a e . Member (ModelState a) e => (Model a -> Model a) -> Eff e ()+modifyModel :: forall a e. Member (ModelState a) e => (Model a -> Model a) -> Eff e () modifyModel f = getModel @a >>= putModel @a . f -- | Modify the 'Model' of a 'Server' and return the old value. -- -- @since 0.24.0-getAndModifyModel :: forall a e . Member (ModelState a) e => (Model a -> Model a) -> Eff e (Model a)+getAndModifyModel :: forall a e. Member (ModelState a) e => (Model a -> Model a) -> Eff e (Model a) getAndModifyModel f = getModel @a <* modify f -- | Modify the 'Model' of a 'Server' and return the new value. -- -- @since 0.24.0-modifyAndGetModel :: forall a e . Member (ModelState a) e => (Model a -> Model a) -> Eff e (Model a)+modifyAndGetModel :: forall a e. Member (ModelState a) e => (Model a -> Model a) -> Eff e (Model a) modifyAndGetModel f = modifyModel @a f *> getModel @a -- | Return the 'Model' of a 'Server'. -- -- @since 0.24.0-getModel :: forall a e . Member (ModelState a) e => Eff e (Model a)+getModel :: forall a e. Member (ModelState a) e => Eff e (Model a) getModel = get -- | Return a element selected by a 'Lens' of the 'Model' of a 'Server'. -- -- @since 0.24.0-useModel :: forall a b e . Member (ModelState a) e => Getting b (Model a) b -> Eff e b+useModel :: forall a b e. Member (ModelState a) e => Getting b (Model a) b -> Eff e b useModel l = view l <$> getModel @a -- | Return a element selected by a 'Lens' of the 'Model' of a 'Server'. -- -- @since 0.30.0-preuseModel :: forall a b e . Member (ModelState a) e => Getting (First b) (Model a) b -> Eff e (Maybe b)+preuseModel :: forall a b e. Member (ModelState a) e => Getting (First b) (Model a) b -> Eff e (Maybe b) preuseModel l = preview l <$> getModel @a -- | Overwrite the 'Model' of a 'Server'. -- -- @since 0.24.0-putModel :: forall a e . Member (ModelState a) e => Model a -> Eff e ()+putModel :: forall a e. Member (ModelState a) e => Model a -> Eff e () putModel = put -- | Overwrite the 'Model' of a 'Server', return the old value. -- -- @since 0.24.0-getAndPutModel :: forall a e . Member (ModelState a) e => Model a -> Eff e (Model a)+getAndPutModel :: forall a e. Member (ModelState a) e => Model a -> Eff e (Model a) getAndPutModel m = getModel @a <* putModel @a m -- | Run an action that modifies portions of the 'Model' of a 'Server' defined by the given 'Lens'.@@ -229,14 +233,16 @@ -- | Log the 'Model' of a 'Server' using 'logDebug'. -- -- @since 0.30.0-logModel- :: forall m e q. ( Show (Model m)- , Member Logs e- , HasProcesses e q- , Member (ModelState m) e)- => Text -> Eff e ()+logModel ::+ forall m e.+ ( ToLogMsg (Model m),+ Member Logs e,+ Member (ModelState m) e+ ) =>+ LogMsg ->+ Eff e () logModel x =- getModel @m >>= logDebug . (x <>) . pack . show+ getModel @m >>= logDebug x -- | The 'Eff'ect type of readonly 'Settings' in a 'Server' instance. --@@ -246,65 +252,74 @@ -- | Return the read-only 'Settings' of a 'Server' -- -- @since 0.24.0-askSettings :: forall a e . Member (SettingsReader a) e => Eff e (Settings a)+askSettings :: forall a e. Member (SettingsReader a) e => Eff e (Settings a) askSettings = ask -- | Return the read-only 'Settings' of a 'Server' as viewed through a 'Lens' -- -- @since 0.24.0-viewSettings :: forall a b e . Member (SettingsReader a) e => Getting b (Settings a) b -> Eff e b+viewSettings :: forall a b e. Member (SettingsReader a) e => Getting b (Settings a) b -> Eff e b viewSettings l = view l <$> askSettings @a -- | Map 'ModelState' and 'SettingsReader' effects. -- Use this to embed 'update' from another 'Server' instance. -- -- @since 0.30.0-mapEffects- :: forall inner outer a e.- (Settings outer -> Settings inner) -- ^ A function to get the /inner/ settings out of the /outer/ settings- -> Lens' (Model outer) (Model inner) -- ^ A 'Lens' to get and set the /inner/ model inside the /outer/ model- -> Eff (ModelState inner : SettingsReader inner : e) a- -> Eff (ModelState outer : SettingsReader outer : e) a+mapEffects ::+ forall inner outer a e.+ -- | A function to get the /inner/ settings out of the /outer/ settings+ (Settings outer -> Settings inner) ->+ -- | A 'Lens' to get and set the /inner/ model inside the /outer/ model+ Lens' (Model outer) (Model inner) ->+ Eff (ModelState inner : SettingsReader inner : e) a ->+ Eff (ModelState outer : SettingsReader outer : e) a mapEffects innerSettings innerStateLens innerEff =- do st0 <- getModel @outer- s0 <- askSettings @outer- (res, st1) <-+ do+ st0 <- getModel @outer+ s0 <- askSettings @outer+ (res, st1) <- raise- (raise- (runReader- @(Settings inner)- (innerSettings s0)- (runState- @(Model inner)- (st0 ^. innerStateLens)- innerEff)))- modifyModel @outer (innerStateLens .~ st1)- return res-+ ( raise+ ( runReader+ @(Settings inner)+ (innerSettings s0)+ ( runState+ @(Model inner)+ (st0 ^. innerStateLens)+ innerEff+ )+ )+ )+ modifyModel @outer (innerStateLens .~ st1)+ return res -- | Coerce 'Coercible' 'ModelState' and 'SettingsReader' effects. -- Use this to embed 'update' from a /similar/ 'Server' instance. -- -- @since 0.30.0-coerceEffects- :: forall inner outer a e.- ( Coercible (Model inner) (Model outer)- , Coercible (Model outer) (Model inner)- , Coercible (Settings outer) (Settings inner)- )- => Eff (ModelState inner : SettingsReader inner : e) a- -> Eff (ModelState outer : SettingsReader outer : e) a+coerceEffects ::+ forall inner outer a e.+ ( Coercible (Model inner) (Model outer),+ Coercible (Model outer) (Model inner),+ Coercible (Settings outer) (Settings inner)+ ) =>+ Eff (ModelState inner : SettingsReader inner : e) a ->+ Eff (ModelState outer : SettingsReader outer : e) a coerceEffects innerEff =- do st0 <- getModel @outer- s0 <- askSettings @outer- (res, st1) <-+ do+ st0 <- getModel @outer+ s0 <- askSettings @outer+ (res, st1) <- raise- (raise- (runReader- @(Settings inner)- (coerce s0)- (runState- (coerce @(Model outer) st0)- innerEff)))- putModel @outer (coerce st1)- return res+ ( raise+ ( runReader+ @(Settings inner)+ (coerce s0)+ ( runState+ (coerce @(Model outer) st0)+ innerEff+ )+ )+ )+ putModel @outer (coerce st1)+ return res
src/Control/Eff/Concurrent/Protocol/Watchdog.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-}+ -- | Monitor a process and act when it is unresponsive. -- -- Behaviour of the watchdog:@@ -18,84 +19,90 @@ -- -- @since 0.30.0 module Control.Eff.Concurrent.Protocol.Watchdog- ( startLink- , Watchdog- , attachTemporary- , attachPermanent- , getCrashReports- , CrashRate(..)- , crashCount- , crashTimeSpan- , crashesPerSeconds- , CrashCount- , CrashTimeSpan- , ChildWatch(..)- , parent- , crashes- , ExonerationTimer(..)- , CrashReport(..)- , crashTime- , crashReason- , exonerationTimerReference- ) where+ ( startLink,+ Watchdog,+ attachTemporary,+ attachPermanent,+ getCrashReports,+ CrashRate (..),+ crashCount,+ crashTimeSpan,+ crashesPerSeconds,+ CrashCount,+ CrashTimeSpan,+ ChildWatch (..),+ parent,+ crashes,+ ExonerationTimer (..),+ CrashReport (..),+ crashTime,+ crashReason,+ exonerationTimerReference,+ )+where import Control.DeepSeq-import Control.Eff (Eff, Member, lift, Lifted)-import Control.Eff.Concurrent.Misc+import Control.Eff (Eff, Lifted, Member, lift) import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Process.Timer import Control.Eff.Concurrent.Protocol+import Control.Eff.Concurrent.Protocol.Broker (Broker)+import qualified Control.Eff.Concurrent.Protocol.Broker as Broker import Control.Eff.Concurrent.Protocol.Client-import Control.Eff.Concurrent.Protocol.Wrapper-import qualified Control.Eff.Concurrent.Protocol.Observer as Observer+import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful import Control.Eff.Concurrent.Protocol.Observer (Observer)-import qualified Control.Eff.Concurrent.Protocol.Broker as Broker-import Control.Eff.Concurrent.Protocol.Broker (Broker)+import qualified Control.Eff.Concurrent.Protocol.Observer as Observer import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful-import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful-import Control.Lens+import Control.Eff.Concurrent.Protocol.Wrapper import Control.Eff.Log-import Data.Set (Set)-import Data.Typeable-import qualified Data.Set as Set+import Control.Lens+import Control.Monad (when)+import Data.Default+import Data.Foldable (forM_, traverse_)+import Data.Kind (Type) import Data.Map (Map) import qualified Data.Map as Map+import Data.Maybe (isJust)+import Data.Proxy+import Data.Set (Set)+import qualified Data.Set as Set import Data.Time.Clock-import Data.Kind (Type)-import Data.Default-import Data.Text (pack)+import Data.Typeable import GHC.Stack (HasCallStack)-import Data.Maybe (isJust)-import Data.Foldable (traverse_, forM_)-import Control.Monad (when) - -- | The phantom for watchdog processes, that watch the given type of servers -- -- This type is used for the 'Effectful.Server' and 'HasPdu' instances. -- -- @since 0.30.0-data Watchdog (child :: Type) deriving Typeable+data Watchdog (child :: Type) deriving (Typeable) +instance ToTypeLogMsg child => ToTypeLogMsg (Watchdog child) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @child) <> packLogMsg "_watchdog"+ -- | Start and link a new watchdog process. -- -- The watchdog process will register itself to the 'Broker.ChildEvent's and -- restart crashed children. -- -- @since 0.30.0-startLink- :: forall child e q- . ( HasCallStack- , Typeable child- , FilteredLogging (Processes q)- , Member Logs q- , HasProcesses e q- , Tangible (Broker.ChildId child)- , Ord (Broker.ChildId child)- , HasPdu (Effectful.ServerPdu child)- , Lifted IO q- )- => CrashRate -> Eff e (Endpoint (Watchdog child))+startLink ::+ forall child e q.+ ( Typeable child,+ FilteredLogging (Processes q),+ Member Logs q,+ HasProcesses e q,+ ToTypeLogMsg child,+ Tangible (Broker.ChildId child),+ Ord (Broker.ChildId child),+ ToLogMsg (Broker.ChildId child),+ HasPdu (Effectful.ServerPdu child),+ ToTypeLogMsg (Effectful.ServerPdu child),+ ToTypeLogMsg (Broker child),+ Lifted IO q+ ) =>+ CrashRate ->+ Eff e (Endpoint (Watchdog child)) startLink = Stateful.startLink @(Watchdog child) . StartWatchDog -- | Restart children of the given broker.@@ -103,17 +110,21 @@ -- When the broker exits, ignore the children of that broker. -- -- @since 0.30.0-attachTemporary- :: forall child q e- . ( HasCallStack- , FilteredLogging e- , Typeable child- , HasPdu (Effectful.ServerPdu child)- , Tangible (Broker.ChildId child)- , Ord (Broker.ChildId child)- , HasProcesses e q- )- => Endpoint (Watchdog child) -> Endpoint (Broker child) -> Eff e ()+attachTemporary ::+ forall child q e.+ ( HasCallStack,+ FilteredLogging e,+ Member Logs q,+ Typeable child,+ Tangible (Broker.ChildId child),+ ToTypeLogMsg child,+ ToTypeLogMsg (Effectful.ServerPdu child),+ ToLogMsg (Broker.ChildId child),+ HasProcesses e q+ ) =>+ Endpoint (Watchdog child) ->+ Endpoint (Broker child) ->+ Eff e () attachTemporary wd broker = callWithTimeout wd (Attach broker False) (TimeoutMicros 1_000_000) @@ -122,17 +133,21 @@ -- When the broker exits, the watchdog process will exit, too. -- -- @since 0.30.0-attachPermanent- :: forall child q e- . ( HasCallStack- , FilteredLogging e- , Typeable child- , HasPdu (Effectful.ServerPdu child)- , Tangible (Broker.ChildId child)- , Ord (Broker.ChildId child)- , HasProcesses e q- )- => Endpoint (Watchdog child) -> Endpoint (Broker child) -> Eff e ()+attachPermanent ::+ forall child q e.+ ( HasCallStack,+ FilteredLogging e,+ Member Logs q,+ Typeable child,+ Tangible (Broker.ChildId child),+ ToTypeLogMsg child,+ ToTypeLogMsg (Effectful.ServerPdu child),+ ToLogMsg (Broker.ChildId child),+ HasProcesses e q+ ) =>+ Endpoint (Watchdog child) ->+ Endpoint (Broker child) ->+ Eff e () attachPermanent wd broker = callWithTimeout wd (Attach broker True) (TimeoutMicros 1_000_000) @@ -141,29 +156,29 @@ -- Useful for diagnostics -- -- @since 0.30.0-getCrashReports- :: forall child q e- . ( HasCallStack- , FilteredLogging e- , Typeable child- , HasPdu (Effectful.ServerPdu child)- , Tangible (Broker.ChildId child)- , Ord (Broker.ChildId child)- , HasProcesses e q- , Lifted IO q- , Lifted IO e- , Member Logs e- )- => Endpoint (Watchdog child) -> Eff e (Map (Broker.ChildId child) (ChildWatch child))+getCrashReports ::+ forall child q e.+ ( HasCallStack,+ FilteredLogging e,+ Typeable child,+ ToTypeLogMsg child,+ ToTypeLogMsg (Effectful.ServerPdu child),+ ToLogMsg (Broker.ChildId child),+ Tangible (Broker.ChildId child),+ HasProcesses e q,+ Member Logs q+ ) =>+ Endpoint (Watchdog child) ->+ Eff e (Map (Broker.ChildId child) (ChildWatch child)) getCrashReports wd = callWithTimeout wd GetCrashReports (TimeoutMicros 5_000_000) instance Typeable child => HasPdu (Watchdog child) where- type instance EmbeddedPduList (Watchdog child) = '[Observer (Broker.ChildEvent child)]+ type EmbeddedPduList (Watchdog child) = '[Observer (Broker.ChildEvent child)] data Pdu (Watchdog child) r where Attach :: Endpoint (Broker child) -> Bool -> Pdu (Watchdog child) ('Synchronous ()) GetCrashReports :: Pdu (Watchdog child) ('Synchronous (Map (Broker.ChildId child) (ChildWatch child))) OnChildEvent :: Broker.ChildEvent child -> Pdu (Watchdog child) 'Asynchronous- deriving Typeable+ deriving (Typeable) instance Typeable child => HasPduPrism (Watchdog child) (Observer (Broker.ChildEvent child)) where embedPdu (Observer.Observed e) = OnChildEvent e@@ -175,26 +190,40 @@ rnf GetCrashReports = () rnf (OnChildEvent o) = rnf o +instance (ToTypeLogMsg child) => ToTypeLogMsg (Pdu (Watchdog child) r) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @(Watchdog child)) <> packLogMsg "_pdu"+ instance- ( Show (Broker.ChildId child)- , Typeable child- , Typeable (Effectful.ServerPdu child)- )- => Show (Pdu (Watchdog child) r) where- showsPrec d (Attach e False) = showParen (d>=10) (showString "attach-temporary: " . shows e)- showsPrec d (Attach e True) = showParen (d>=10) (showString "attach-permanent: " . shows e)- showsPrec _ GetCrashReports = showString "get-crash-reports"- showsPrec d (OnChildEvent o) = showParen (d>=10) (showString "on-child-event: " . showsPrec 10 o)+ ( ToLogMsg (Broker.ChildId child),+ ToTypeLogMsg child,+ ToTypeLogMsg (Effectful.ServerPdu child)+ ) =>+ ToLogMsg (Pdu (Watchdog child) r)+ where+ toLogMsg (Attach e isPermanentFlag) =+ toTypeLogMsg (Proxy @(Watchdog child))+ <> packLogMsg " attach-"+ <> packLogMsg (if isPermanentFlag then "permanent" else "temporary")+ <> packLogMsg ": "+ <> toLogMsg e+ toLogMsg GetCrashReports =+ toTypeLogMsg (Proxy @(Watchdog child))+ <> packLogMsg " get-crash-reports"+ toLogMsg (OnChildEvent o) =+ toTypeLogMsg (Proxy @(Watchdog child))+ <> packLogMsg " on-child-event: "+ <> toLogMsg o -- ------------------ Broker Watches -data BrokerWatch =- MkBrokerWatch { _brokerMonitor :: MonitorReference, _isPermanent :: Bool }+data BrokerWatch = MkBrokerWatch {_brokerMonitor :: MonitorReference, _isPermanent :: Bool} deriving (Typeable) -instance Show BrokerWatch where- showsPrec d (MkBrokerWatch mon False) = showParen (d>=10) (showString "temporary-broker: " . showsPrec 10 mon)- showsPrec d (MkBrokerWatch mon True) = showParen (d>=10) (showString "permanent-broker: " . showsPrec 10 mon)+instance ToLogMsg BrokerWatch where+ toLogMsg (MkBrokerWatch mon isPermanentFlag) =+ packLogMsg (if isPermanentFlag then "permanent" else "temporary")+ <> packLogMsg "-child: "+ <> toLogMsg mon brokerMonitor :: Lens' BrokerWatch MonitorReference brokerMonitor = lens _brokerMonitor (\(MkBrokerWatch _ x) m -> MkBrokerWatch m x)@@ -204,126 +233,124 @@ -- --- Server Definition -instance- ( Typeable child- , HasPdu (Effectful.ServerPdu child)- , Tangible (Broker.ChildId child)- , Ord (Broker.ChildId child)- , Eq (Broker.ChildId child)- , Lifted IO e- , Member Logs e- ) => Stateful.Server (Watchdog child) (Processes e) where+instance ToTypeLogMsg child => ToLogMsg (Stateful.StartArgument (Watchdog child)) where+ toLogMsg cfg =+ toTypeLogMsg (Proxy @(Watchdog child))+ <> packLogMsg " configuration: "+ <> toLogMsg (_crashRate cfg) - data instance StartArgument (Watchdog child) =- StartWatchDog { _crashRate :: CrashRate- }- deriving Typeable+instance+ ( Typeable child,+ ToTypeLogMsg child,+ HasPdu (Effectful.ServerPdu child),+ ToTypeLogMsg (Effectful.ServerPdu child),+ Tangible (Broker.ChildId child),+ Ord (Broker.ChildId child),+ Eq (Broker.ChildId child),+ ToLogMsg (Broker.ChildId child),+ Lifted IO e,+ Member Logs e,+ ToTypeLogMsg (Broker child)+ ) =>+ Stateful.Server (Watchdog child) (Processes e)+ where+ data StartArgument (Watchdog child) = StartWatchDog+ { _crashRate :: CrashRate+ }+ deriving (Typeable) - data instance Model (Watchdog child) =- WatchdogModel { _brokers :: Map (Endpoint (Broker child)) BrokerWatch- , _watched :: Map (Broker.ChildId child) (ChildWatch child)- }+ data Model (Watchdog child) = WatchdogModel+ { _brokers :: Map (Endpoint (Broker child)) BrokerWatch,+ _watched :: Map (Broker.ChildId child) (ChildWatch child)+ } update me startArg = \case- Effectful.OnCall rt (Attach broker permanent) -> do- logDebug ( "attaching "- <> if permanent then "permanently" else "temporarily"- <> " to: " <> pack (show broker)- )+ Effectful.OnCall rt evt@(Attach broker permanent) -> do+ logDebug evt oldMonitor <- Stateful.preuseModel @(Watchdog child) (brokers . at broker . _Just . brokerMonitor)- newMonitor <- maybe (monitor (broker^.fromEndpoint)) return oldMonitor+ newMonitor <- maybe (monitor (broker ^. fromEndpoint)) return oldMonitor case oldMonitor of Nothing -> do- logDebug ("start observing: " <> pack (show broker))+ logDebug (LABEL "start observing" broker) Observer.registerObserver @(Broker.ChildEvent child) broker me Just _ ->- logDebug ("already observing " <> pack (show broker))+ logDebug (LABEL "already observing" broker) let newBrokerWatch = MkBrokerWatch newMonitor permanent Stateful.modifyModel (brokers . at broker ?~ newBrokerWatch) Observer.registerObserver @(Broker.ChildEvent child) broker me sendReply rt ()- Effectful.OnCall rt GetCrashReports -> Stateful.useModel @(Watchdog child) watched >>= sendReply rt-- Effectful.OnCast (OnChildEvent e) ->+ Effectful.OnCast (OnChildEvent e) -> case e of down@(Broker.OnBrokerShuttingDown broker) -> do- logInfo ("received: " <> pack (show down))+ logInfo (LABEL "received" down) removeBroker me broker- spawned@(Broker.OnChildSpawned broker _ _) -> do- logInfo ("received: " <> pack (show spawned))+ logInfo (LABEL "received" spawned) currentModel <- Stateful.getModel @(Watchdog child)- when (not (Set.member broker (currentModel ^. brokers . to Map.keysSet)))- (logWarning ("received child event for unknown broker: " <> pack (show spawned)))-+ when+ (not (Set.member broker (currentModel ^. brokers . to Map.keysSet)))+ (logWarning (LABEL "received child event for unknown broker" spawned)) down@(Broker.OnChildDown broker cId _ ExitNormally) -> do- logInfo ("received: " <> pack (show down))+ logInfo (LABEL "received" down) currentModel <- Stateful.getModel @(Watchdog child) if not (Set.member broker (currentModel ^. brokers . to Map.keysSet))- then logWarning ("received child event for unknown broker: " <> pack (show down))- else removeAndCleanChild @child cId-+ then logWarning (LABEL "received child event for unknown broker" down)+ else removeAndCleanChild @child cId down@(Broker.OnChildDown broker cId _ reason) -> do- logInfo ("received: " <> pack (show down))+ logInfo (LABEL "received" down) currentModel <- Stateful.getModel @(Watchdog child) if not (Set.member broker (currentModel ^. brokers . to Map.keysSet))- then- logWarning ("received child event for unknown broker: " <> pack (show down))- else do- let recentCrashes = countRecentCrashes broker cId currentModel- rate = startArg ^. crashRate- maxCrashCount = rate ^. crashCount- if recentCrashes < maxCrashCount then do- logNotice ("restarting (" <> pack (show recentCrashes) <> "/" <> pack (show maxCrashCount) <> "): "- <> pack (show cId) <> " of " <> pack (show broker))- res <- Broker.spawnChild broker cId- logNotice ("restarted: " <> pack (show cId) <> " of "- <> pack (show broker) <> ": " <> pack (show res))- crash <- startExonerationTimer @child cId reason (rate ^. crashTimeSpan)- if isJust (currentModel ^? childWatchesById cId)+ then logWarning (LABEL "received child event for unknown broker" down)+ else do+ let recentCrashes = countRecentCrashes broker cId currentModel+ rate = startArg ^. crashRate+ maxCrashCount = rate ^. crashCount+ if recentCrashes < maxCrashCount then do- logDebug ("recording crash for child: " <> pack (show cId) <> " of " <> pack (show broker))- Stateful.modifyModel (watched @child . at cId . _Just . crashes %~ Set.insert crash)+ logNotice (LABEL "restarting" (concatMsgs (show recentCrashes) (MSG "/") (show maxCrashCount) (LABEL "child" cId) (LABEL "of" broker) :: LogMsg))+ res <- Broker.spawnChild broker cId+ logNotice (LABEL "restarted child" cId) (LABEL "result" res) (LABEL "of" broker)+ crash <- startExonerationTimer cId reason (rate ^. crashTimeSpan)+ if isJust (currentModel ^? childWatchesById cId)+ then do+ logDebug (MSG "recording crash") (LABEL "child" cId) (LABEL "of" broker)+ Stateful.modifyModel (watched @child . at cId . _Just . crashes %~ Set.insert crash)+ else do+ logDebug (MSG "recording crash for new child") (LABEL "child" cId) (LABEL "of" broker)+ Stateful.modifyModel (watched @child . at cId .~ Just (MkChildWatch broker (Set.singleton crash))) else do- logDebug ("recording crash for new child: " <> pack (show cId) <> " of " <> pack (show broker))- Stateful.modifyModel (watched @child . at cId .~ Just (MkChildWatch broker (Set.singleton crash)))- else do- logWarning ("restart rate exceeded: " <> pack (show rate)- <> ", for child: " <> pack (show cId)- <> " of " <> pack (show broker))- removeAndCleanChild @child cId- forM_ (currentModel ^? brokers . at broker . _Just) $ \bw ->- if bw ^. isPermanent then do- logError ("a child of a permanent broker crashed too often, interrupting: " <> pack (show broker))- let r = ExitUnhandledError "restart frequency exceeded"- demonitor (bw ^. brokerMonitor)- sendShutdown (broker ^. fromEndpoint) r- exitBecause r- -- TODO shutdown all other permanent brokers!- else- logError ("a child of a temporary broker crashed too often: " <> pack (show broker))-+ logWarning+ (LABEL "restart rate exceeded" rate)+ (LABEL "child" cId)+ (LABEL "of" broker)+ removeAndCleanChild @child cId+ forM_ (currentModel ^? brokers . at broker . _Just) $ \bw ->+ if bw ^. isPermanent+ then do+ logError (LABEL "a child of a permanent broker crashed too often, shutting down permanent broker" broker)+ let r = ExitUnhandledError (packLogMsg "restart frequency exceeded")+ demonitor (bw ^. brokerMonitor)+ sendShutdown (broker ^. fromEndpoint) r+ exitBecause r+ else -- TODO shutdown all other permanent brokers!+ logError (LABEL "a child crashed too often of the temporary broker" broker) Effectful.OnDown pd@(ProcessDown _mref _ pid) -> do- logDebug ("received " <> pack (show pd))+ logDebug (LABEL "on-down" pd) let broker = asEndpoint pid removeBroker @child me broker- Effectful.OnTimeOut t -> do- logError ("received: " <> pack (show t))-- Effectful.OnMessage (fromStrictDynamic -> Just (MkExonerationTimer cId ref :: ExonerationTimer (Broker.ChildId child))) -> do- logInfo ("exonerating: " <> pack (show cId))+ logError (LABEL "on-timeout" t)+ Effectful.OnMessage (fromMessage -> Just (MkExonerationTimer cId ref :: ExonerationTimer (Broker.ChildId child))) -> do+ logInfo (LABEL "on-exoneration-timeout" cId) Stateful.modifyModel- (watched @child . at cId . _Just . crashes %~ Set.filter (\c -> c^.exonerationTimerReference /= ref))-+ (watched @child . at cId . _Just . crashes %~ Set.filter (\c -> c ^. exonerationTimerReference /= ref)) Effectful.OnMessage t -> do- logError ("received: " <> pack (show t))-+ logError (LABEL "on-message" t) Effectful.OnInterrupt reason -> do- logError ("received: " <> pack (show reason))+ logError (LABEL "on-interrupt" reason) -- ------------------ Start Argument @@ -342,22 +369,22 @@ -- This governs how long the 'ExonerationTimer' runs before cleaning up a 'CrashReport' in a 'ChildWatch'. -- -- @since 0.30.0-data CrashRate =- CrashesPerSeconds { _crashCount :: CrashCount- , _crashTimeSpan :: CrashTimeSpan- }+data CrashRate = CrashesPerSeconds+ { _crashCount :: CrashCount,+ _crashTimeSpan :: CrashTimeSpan+ } deriving (Typeable, Eq, Ord) +instance ToLogMsg CrashRate where+ toLogMsg (CrashesPerSeconds count time) =+ toLogMsg count <> packLogMsg " crashes in " <> toLogMsg time <> packLogMsg " seconds"+ -- | The default is three crashes in 30 seconds. -- -- @since 0.30.0 instance Default CrashRate where def = 3 `crashesPerSeconds` 30 -instance Show CrashRate where- showsPrec d (CrashesPerSeconds count time) =- showParen (d>=7) (shows count . showString " crashes/" . shows time . showString " seconds")- instance NFData CrashRate where rnf (CrashesPerSeconds c t) = c `seq` t `seq` () @@ -384,7 +411,7 @@ -- -- @since 0.30.0 crashCount :: Lens' CrashRate CrashCount-crashCount = lens _crashCount (\(CrashesPerSeconds _ time) count -> CrashesPerSeconds count time )+crashCount = lens _crashCount (\(CrashesPerSeconds _ time) count -> CrashesPerSeconds count time) -- | A lens for '_crashTimeSpan'. --@@ -399,54 +426,65 @@ -- See 'attachPermanent' and 'attachTemporary'. -- -- @since 0.30.0-data CrashReport a =- MkCrashReport { _exonerationTimerReference :: TimerReference- -- ^ After a crash, an 'ExonerationTimer' according to the 'CrashRate' of the 'Watchdog'- -- is started, this is the reference- , _crashTime :: UTCTime- -- ^ Recorded time of the crash- , _crashReason :: Interrupt 'NoRecovery- -- ^ Recorded crash reason- }+data CrashReport = MkCrashReport+ { -- | After a crash, an 'ExonerationTimer' according to the 'CrashRate' of the 'Watchdog'+ -- is started, this is the reference+ _exonerationTimerReference :: TimerReference,+ -- | Recorded time of the crash+ _crashTime :: UTCTime,+ -- | Recorded crash reason+ _crashReason :: ShutdownReason+ } deriving (Eq, Ord, Typeable) -instance (Show a, Typeable a) => Show (CrashReport a) where- showsPrec d c =- showParen (d>=10)- ( showString "crash report: "- . showString " time: " . showsPrec 10 (c^.crashTime)- . showString " reason: " . showsPrec 10 (c^.crashReason)- . showString " " . showsPrec 10 (c^.exonerationTimerReference)- )+instance ToLogMsg CrashReport where+ toLogMsg c =+ packLogMsg "crash-report: "+ <> packLogMsg (show (c ^. crashTime))+ <> packLogMsg " "+ <> toLogMsg (c ^. crashReason)+ <> packLogMsg " "+ <> toLogMsg (c ^. exonerationTimerReference) -instance NFData (CrashReport a) where+instance NFData CrashReport where rnf (MkCrashReport !a !b !c) = rnf a `seq` rnf b `seq` rnf c `seq` () -- | Lens for '_crashTime' -- -- @since 0.30.0-crashTime :: Lens' (CrashReport a) UTCTime-crashTime = lens _crashTime (\c t -> c { _crashTime = t})+crashTime :: Lens' CrashReport UTCTime+crashTime = lens _crashTime (\c t -> c {_crashTime = t}) -- | Lens for '_crashReason' -- -- @since 0.30.0-crashReason :: Lens' (CrashReport a) (Interrupt 'NoRecovery)-crashReason = lens _crashReason (\c t -> c { _crashReason = t})+crashReason :: Lens' CrashReport ShutdownReason+crashReason = lens _crashReason (\c t -> c {_crashReason = t}) -- | Lens for '_exonerationTimerReference' -- -- @since 0.30.0-exonerationTimerReference :: Lens' (CrashReport a) TimerReference-exonerationTimerReference = lens _exonerationTimerReference (\c t -> c { _exonerationTimerReference = t})+exonerationTimerReference :: Lens' CrashReport TimerReference+exonerationTimerReference = lens _exonerationTimerReference (\c t -> c {_exonerationTimerReference = t}) -startExonerationTimer :: forall child a q e .- (HasProcesses e q, Lifted IO q, Lifted IO e, Show a, NFData a, Typeable a, Typeable child)- => a -> Interrupt 'NoRecovery -> CrashTimeSpan -> Eff e (CrashReport a)+startExonerationTimer ::+ forall a q e.+ ( HasProcesses e q,+ Member Logs q,+ Lifted IO e,+ NFData a,+ Typeable a,+ ToLogMsg a+ ) =>+ a ->+ ShutdownReason ->+ CrashTimeSpan ->+ Eff e CrashReport startExonerationTimer cId r t = do- let title = MkProcessTitle ("ExonerationTimer<" <> pack (showSTypeable @child ">") <> pack (show cId))+ let title = MkProcessTitle (packLogMsg "exoneration-timer")+ initialDebugLogMsg = toLogMsg cId <> packLogMsg " " <> toLogMsg r <> packLogMsg " " <> toLogMsg t me <- self- ref <- sendAfterWithTitle title me (TimeoutMicros (t * 1_000_000)) (MkExonerationTimer cId)+ ref <- sendAfterWithTitleAndLogMsg initialDebugLogMsg title me (TimeoutMicros (t * 1_000_000)) (MkExonerationTimer cId) now <- lift getCurrentTime return (MkCrashReport ref now r) @@ -456,18 +494,18 @@ -- that child. -- -- @since 0.30.0-data ExonerationTimer a = MkExonerationTimer !a !TimerReference+data ExonerationTimer a = MkExonerationTimer !a !TimerReference deriving (Eq, Ord, Typeable) instance NFData a => NFData (ExonerationTimer a) where rnf (MkExonerationTimer !x !r) = rnf r `seq` rnf x `seq` () -instance Show a => Show (ExonerationTimer a) where- showsPrec d (MkExonerationTimer x r) =- showParen (d >= 10)- ( showString "exonerate: " . showsPrec 10 x- . showString " after: " . showsPrec 10 r- )+instance ToLogMsg a => ToLogMsg (ExonerationTimer a) where+ toLogMsg (MkExonerationTimer x r) =+ packLogMsg "exonerate: "+ <> toLogMsg x+ <> packLogMsg " after: "+ <> toLogMsg r -- --------------------------- Child Watches @@ -476,28 +514,26 @@ -- See 'attachPermanent' and 'attachTemporary', 'ExonerationTimer', 'CrashRate'. -- -- @since 0.30.0-data ChildWatch child =- MkChildWatch- { _parent :: Endpoint (Broker child)- -- ^ The attached 'Broker' that started the child- , _crashes :: Set (CrashReport (Broker.ChildId child))- -- ^ The crashes of the child. If the number of crashes- -- surpasses the allowed number of crashes before the- -- 'ExonerationTimer's clean them, the child is finally crashed.- }- deriving Typeable+data ChildWatch child = MkChildWatch+ { -- | The attached 'Broker' that started the child+ _parent :: Endpoint (Broker child),+ -- | The crashes of the child. If the number of crashes+ -- surpasses the allowed number of crashes before the+ -- 'ExonerationTimer's clean them, the child is finally crashed.+ _crashes :: Set CrashReport+ }+ deriving (Typeable) instance NFData (ChildWatch child) where rnf (MkChildWatch p c) = rnf p `seq` rnf c `seq` () -instance (Typeable child, Typeable (Broker.ChildId child), Show (Broker.ChildId child)) => Show (ChildWatch child) where- showsPrec d (MkChildWatch p c) =- showParen (d>=10) ( showString "child-watch: parent: "- . showsPrec 10 p- . showString " crashes: "- . foldr (.) id (showsPrec 10 <$> Set.toList c)- )+instance ToTypeLogMsg child => ToLogMsg (ChildWatch child) where+ toLogMsg (MkChildWatch p c) =+ packLogMsg "parent: " <> toLogMsg p+ <> case Set.toList c of+ [] -> packLogMsg " recorded no crashes"+ (r : rs) -> packLogMsg " recorded crashes: " <> toLogMsg r <> foldr ((<>) . (packLogMsg " " <>) . toLogMsg) (packLogMsg "") rs -- | A lens for '_parent'. --@@ -508,7 +544,7 @@ -- | A lens for '_crashes' -- -- @since 0.30.0-crashes :: Lens' (ChildWatch child) (Set (CrashReport (Broker.ChildId child)))+crashes :: Lens' (ChildWatch child) (Set CrashReport) crashes = lens _crashes (\m x -> m {_crashes = x}) -- ------------------ Model@@ -516,20 +552,6 @@ instance Default (Stateful.Model (Watchdog child)) where def = WatchdogModel def Map.empty -instance ( Show (Broker.ChildId child)- , Typeable (Broker.ChildId child)- , Typeable child- )- => Show (Stateful.Model (Watchdog child))- where- showsPrec d (WatchdogModel bs cs) =- showParen (d>=10)- (showString "watchdog model broker watches: "- . showsPrec 10 bs- . showString " watchdog model child watches: "- . showsPrec 10 cs- )- -- -------------------------- Model -> Child Watches watched :: Lens' (Stateful.Model (Watchdog child)) (Map (Broker.ChildId child) (ChildWatch child))@@ -539,27 +561,27 @@ childWatches = watched . itraversed childWatchesById ::- Eq (Broker.ChildId child)- => Broker.ChildId child- -> Traversal' (Stateful.Model (Watchdog child)) (ChildWatch child)+ Eq (Broker.ChildId child) =>+ Broker.ChildId child ->+ Traversal' (Stateful.Model (Watchdog child)) (ChildWatch child) childWatchesById theCId = childWatches . ifiltered (\cId _ -> cId == theCId) childWatchesByParenAndId ::- Eq (Broker.ChildId child)- => Endpoint (Broker child)- -> Broker.ChildId child- -> Traversal' (Stateful.Model (Watchdog child)) (ChildWatch child)+ Eq (Broker.ChildId child) =>+ Endpoint (Broker child) ->+ Broker.ChildId child ->+ Traversal' (Stateful.Model (Watchdog child)) (ChildWatch child) childWatchesByParenAndId theParent theCId = childWatches . ifiltered (\cId cw -> cw ^. parent == theParent && cId == theCId) countRecentCrashes ::- Eq (Broker.ChildId child)- => Endpoint (Broker child)- -> Broker.ChildId child- -> Stateful.Model (Watchdog child)- -> CrashCount+ Eq (Broker.ChildId child) =>+ Endpoint (Broker child) ->+ Broker.ChildId child ->+ Stateful.Model (Watchdog child) ->+ CrashCount countRecentCrashes theParent theCId theModel =- length (theModel ^.. childWatchesByParenAndId theParent theCId . crashes . folded)+ length (theModel ^.. childWatchesByParenAndId theParent theCId . crashes . folded) -- --------------------------- Model -> Broker Watches @@ -570,47 +592,48 @@ removeAndCleanChild :: forall child q e.- ( HasProcesses e q- , Typeable child- , Typeable (Broker.ChildId child)- , Ord (Broker.ChildId child)- , Show (Broker.ChildId child)- , Member (Stateful.ModelState (Watchdog child)) e- , Member Logs e- )- => Broker.ChildId child- -> Eff e ()+ ( HasProcesses e q,+ Ord (Broker.ChildId child),+ ToLogMsg (Broker.ChildId child),+ Member (Stateful.ModelState (Watchdog child)) e,+ Member Logs e,+ ToTypeLogMsg child+ ) =>+ Broker.ChildId child ->+ Eff e () removeAndCleanChild cId = do- oldModel <- Stateful.modifyAndGetModel (watched @child . at cId .~ Nothing)- forMOf_ (childWatchesById cId) oldModel $ \w -> do- logDebug ("removing client entry: " <> pack (show cId))- forMOf_ (crashes . folded . exonerationTimerReference) w cancelTimer- logDebug (pack (show w))+ oldModel <- Stateful.modifyAndGetModel (watched @child . at cId .~ Nothing)+ forMOf_ (childWatchesById cId) oldModel $ \w -> do+ logDebug (LABEL "removing client entry" cId)+ forMOf_ (crashes . folded . exonerationTimerReference) w cancelTimer+ logDebug w removeBroker :: forall child q e.- ( HasProcesses e q- , Typeable child- , Tangible (Broker.ChildId child)- , Typeable (Effectful.ServerPdu child)- , Ord (Broker.ChildId child)- , Show (Broker.ChildId child)- , Member (Stateful.ModelState (Watchdog child)) e- , Member Logs e- )- => Endpoint (Watchdog child)- -> Endpoint (Broker child)- -> Eff e ()+ ( HasProcesses e q,+ Typeable child,+ Tangible (Broker.ChildId child),+ ToLogMsg (Broker.ChildId child),+ ToTypeLogMsg child,+ ToTypeLogMsg (Effectful.ServerPdu child),+ ToTypeLogMsg (Broker child),+ Member (Stateful.ModelState (Watchdog child)) e,+ Member Logs e+ ) =>+ Endpoint (Watchdog child) ->+ Endpoint (Broker child) ->+ Eff e () removeBroker me broker = do- oldModel <- Stateful.getAndModifyModel @(Watchdog child)- ( (brokers . at broker .~ Nothing)- . (watched %~ Map.filter (\cw -> cw^.parent /= broker))- )- forM_ (oldModel ^? brokers . at broker . _Just) $ \deadBroker -> do- logNotice ("dettaching: " <> pack (show deadBroker) <> " " <> pack (show broker))- let forgottenChildren = oldModel ^.. watched . itraversed . filtered (\cw -> cw^.parent == broker)- traverse_ (logNotice . ("forgetting: " <>) . pack . show) forgottenChildren- Observer.forgetObserver @(Broker.ChildEvent child) broker me- when (view isPermanent deadBroker) $ do- logError ("permanent broker exited: " <> pack (show broker))- exitBecause (ExitOtherProcessNotRunning (broker ^. fromEndpoint))+ oldModel <-+ Stateful.getAndModifyModel @(Watchdog child)+ ( (brokers . at broker .~ Nothing)+ . (watched %~ Map.filter (\cw -> cw ^. parent /= broker))+ )+ forM_ (oldModel ^? brokers . at broker . _Just) $ \deadBroker -> do+ logNotice (LABEL "dettaching" deadBroker) (LABEL "from" broker)+ let forgottenChildren = oldModel ^.. watched . itraversed . filtered (\cw -> cw ^. parent == broker)+ traverse_ (logNotice . LABEL "forgetting") forgottenChildren+ Observer.forgetObserver @(Broker.ChildEvent child) broker me+ when (view isPermanent deadBroker) $ do+ logError (LABEL "permanent broker exited" broker)+ exitBecause (ExitOtherProcessNotRunning (broker ^. fromEndpoint))
src/Control/Eff/Concurrent/Protocol/Wrapper.hs view
@@ -1,96 +1,113 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeApplications #-}+ -- | Proxies and containers for casts and calls. -- -- @since 0.15.0 module Control.Eff.Concurrent.Protocol.Wrapper- ( Request(..)- , sendReply- , ReplyTarget(..)- , replyTarget- , replyTargetOrigin- , replyTargetSerializer- , embeddedReplyTarget- , toEmbeddedReplyTarget- , RequestOrigin(..)- , embedRequestOrigin- , toEmbeddedOrigin- , Reply(..)- , embedReplySerializer- , makeRequestOrigin+ ( Request (..),+ sendReply,+ ReplyTarget (..),+ replyTarget,+ replyTargetOrigin,+ replyTargetSerializer,+ embeddedReplyTarget,+ toEmbeddedReplyTarget,+ RequestOrigin (..),+ embedRequestOrigin,+ toEmbeddedOrigin,+ Reply (..),+ embedReplySerializer,+ makeRequestOrigin, )- where+where import Control.DeepSeq import Control.Eff import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Protocol+import Control.Eff.Log.Message import Control.Lens+import Data.Coerce (coerce) import Data.Kind (Type)-import Data.Typeable (Typeable) import Data.Semigroup+import Data.Typeable (Typeable) import GHC.Generics -- | A wrapper sum type for calls and casts for the 'Pdu's of a protocol -- -- @since 0.15.0 data Request protocol where- Call- :: forall protocol reply.- ( Tangible reply- , TangiblePdu protocol ('Synchronous reply)- )- => RequestOrigin protocol reply- -> Pdu protocol ('Synchronous reply)- -> Request protocol- Cast- :: forall protocol. (TangiblePdu protocol 'Asynchronous, NFData (Pdu protocol 'Asynchronous))- => Pdu protocol 'Asynchronous- -> Request protocol+ Call ::+ forall protocol reply.+ ( Tangible reply,+ TangiblePdu protocol ('Synchronous reply),+ ToLogMsg (Pdu protocol ('Synchronous reply))+ ) =>+ RequestOrigin protocol reply ->+ Pdu protocol ('Synchronous reply) ->+ Request protocol+ Cast ::+ forall protocol.+ ( TangiblePdu protocol 'Asynchronous,+ NFData (Pdu protocol 'Asynchronous),+ ToLogMsg (Pdu protocol 'Asynchronous)+ ) =>+ Pdu protocol 'Asynchronous ->+ Request protocol deriving (Typeable) -instance Show (Request protocol) where- showsPrec d (Call o r) =- showParen (d >= 10) (showString "call-request: " . showsPrec 11 o . showString ": " . showsPrec 11 r)- showsPrec d (Cast r) =- showParen (d >= 10) (showString "cast-request: " . showsPrec 11 r)+instance ToTypeLogMsg protocol => ToLogMsg (Request protocol) where+ toLogMsg = \case+ Call orig pdu -> packLogMsg "call from: " <> toLogMsg orig <> packLogMsg " pdu: " <> toLogMsg pdu+ Cast pdu -> packLogMsg "cast pdu: " <> toLogMsg pdu instance NFData (Request protocol) where rnf (Call o req) = rnf o `seq` rnf req rnf (Cast req) = rnf req - -- | The wrapper around replies to 'Call's. -- -- @since 0.15.0 data Reply protocol reply where- Reply :: (Tangible reply) =>- { _replyTo :: RequestOrigin protocol reply- , _replyValue :: reply- } -> Reply protocol reply+ Reply ::+ (Tangible reply) =>+ { _replyTo :: RequestOrigin protocol reply,+ _replyValue :: reply+ } ->+ Reply+ protocol+ reply deriving (Typeable) instance NFData (Reply p r) where rnf (Reply i r) = rnf i `seq` rnf r -instance Show r => Show (Reply p r) where- showsPrec d (Reply o r) =- showParen (d >= 10) (showString "request-reply: " . showsPrec 11 o . showString ": " . showsPrec 11 r)+instance (ToLogMsg r, ToTypeLogMsg p) => ToLogMsg (Reply p r) where+ toLogMsg rp =+ packLogMsg "reply: "+ <> toLogMsg (_replyValue rp)+ <> packLogMsg " to: "+ <> toLogMsg (_replyTo rp) -- | Wraps the source 'ProcessId' and a unique identifier for a 'Call'. -- -- @since 0.15.0 data RequestOrigin (proto :: Type) reply = RequestOrigin- { _requestOriginPid :: !ProcessId- , _requestOriginCallRef :: !Int- } deriving (Typeable, Generic, Eq, Ord)+ { _requestOriginPid :: !ProcessId,+ _requestOriginCallRef :: !Int+ }+ deriving (Typeable, Generic, Eq, Ord) -instance Show (RequestOrigin p r) where- showsPrec d (RequestOrigin o r) =- showParen (d >= 10) (showString "origin: " . showsPrec 10 o . showChar ' ' . showsPrec 10 r)+instance ToTypeLogMsg p => ToLogMsg (RequestOrigin p r) where+ toLogMsg ro =+ toLogMsg (Endpoint @p (_requestOriginPid ro))+ <> packLogMsg ('?' : show (_requestOriginCallRef ro)) -- | Create a new, unique 'RequestOrigin' value for the current process. -- -- @since 0.24.0-makeRequestOrigin :: (Typeable r, NFData r, HasProcesses e q0) => Eff e (RequestOrigin p r)+makeRequestOrigin :: HasProcesses e q0 => Eff e (RequestOrigin p r) makeRequestOrigin = RequestOrigin <$> self <*> makeReference instance NFData (RequestOrigin p r)@@ -104,10 +121,10 @@ -- See also 'embedReplySerializer'. -- -- @since 0.24.3-toEmbeddedOrigin- :: forall outer inner reply . Embeds outer inner- => RequestOrigin outer reply- -> RequestOrigin inner reply+toEmbeddedOrigin ::+ forall outer inner reply.+ RequestOrigin outer reply ->+ RequestOrigin inner reply toEmbeddedOrigin (RequestOrigin !pid !ref) = RequestOrigin pid ref -- | Turn an /embedded/ 'RequestOrigin' to a 'RequestOrigin' for the /bigger/ request.@@ -117,7 +134,10 @@ -- This function is strict in all parameters. -- -- @since 0.24.2-embedRequestOrigin :: forall outer inner reply . Embeds outer inner => RequestOrigin inner reply -> RequestOrigin outer reply+embedRequestOrigin ::+ forall outer inner reply.+ RequestOrigin inner reply ->+ RequestOrigin outer reply embedRequestOrigin (RequestOrigin !pid !ref) = RequestOrigin pid ref -- | Turn a 'Serializer' for a 'Pdu' instance that contains embedded 'Pdu' values@@ -130,7 +150,10 @@ -- See also 'toEmbeddedOrigin'. -- -- @since 0.24.2-embedReplySerializer :: forall outer inner reply . Embeds outer inner => Serializer (Reply outer reply) -> Serializer (Reply inner reply)+embedReplySerializer ::+ forall outer inner reply.+ Serializer (Reply outer reply) ->+ Serializer (Reply inner reply) embedReplySerializer = contramap embedReply -- | Turn an /embedded/ 'Reply' to a 'Reply' for the /bigger/ request.@@ -138,9 +161,10 @@ -- This function is strict in all parameters. -- -- @since 0.24.2-embedReply :: forall outer inner reply . Embeds outer inner => Reply inner reply -> Reply outer reply-embedReply (Reply (RequestOrigin !pid !ref) !v) = Reply (RequestOrigin pid ref) v+embedReply :: forall outer inner reply. Reply inner reply -> Reply outer reply+embedReply = coerce +-- (Reply (RequestOrigin !pid !ref) !v) = Reply (RequestOrigin pid ref) v -- | Answer a 'Call' by sending the reply value to the client process. --@@ -148,14 +172,13 @@ -- stored in the 'ReplyTarget'. -- -- @since 0.25.1-sendReply- :: ( HasProcesses eff q- , Tangible reply- , Typeable protocol- )- => ReplyTarget protocol reply- -> reply- -> Eff eff ()+sendReply ::+ ( HasProcesses eff q,+ Tangible reply+ ) =>+ ReplyTarget protocol reply ->+ reply ->+ Eff eff () sendReply (MkReplyTarget (Arg o ser)) r = sendAnyMessage (_requestOriginPid o) $! runSerializer ser $! Reply o r @@ -168,12 +191,9 @@ -- the 'RequestOrigin' instances. -- -- @since 0.26.0-newtype ReplyTarget p r =- MkReplyTarget (Arg (RequestOrigin p r) (Serializer (Reply p r)))- deriving (Eq, Ord, Typeable)--instance Show (ReplyTarget p r) where- showsPrec d (MkReplyTarget (Arg o _s)) = showParen (d>=10) (showString "reply-target: " . shows o)+newtype ReplyTarget p r+ = MkReplyTarget (Arg (RequestOrigin p r) (Serializer (Reply p r)))+ deriving (Eq, Ord, Typeable) instance NFData (ReplyTarget p r) where rnf (MkReplyTarget (Arg x y)) = rnf x `seq` y `seq` ()@@ -184,7 +204,7 @@ -- -- @since 0.26.0 replyTarget :: Serializer (Reply p reply) -> RequestOrigin p reply -> ReplyTarget p reply-replyTarget ser orig = MkReplyTarget (Arg orig ser)+replyTarget ser orig = MkReplyTarget (Arg orig ser) -- | A simple 'Lens' for the 'RequestOrigin' of a 'ReplyTarget'. --@@ -205,7 +225,11 @@ -- This combines 'replyTarget' and 'toEmbeddedReplyTarget'. -- -- @since 0.26.0-embeddedReplyTarget :: Embeds outer inner => Serializer (Reply outer reply) -> RequestOrigin outer reply -> ReplyTarget inner reply+embeddedReplyTarget ::+ forall outer inner reply.+ Serializer (Reply outer reply) ->+ RequestOrigin outer reply ->+ ReplyTarget inner reply embeddedReplyTarget ser orig = toEmbeddedReplyTarget $ replyTarget ser orig -- | Convert a 'ReplyTarget' to be usable for /embedded/ replies.@@ -214,6 +238,9 @@ -- 'ReplyTarget' that can be passed to functions defined soley on an embedded protocol. -- -- @since 0.26.0-toEmbeddedReplyTarget :: Embeds outer inner => ReplyTarget outer reply -> ReplyTarget inner reply+toEmbeddedReplyTarget ::+ forall outer inner reply.+ ReplyTarget outer reply ->+ ReplyTarget inner reply toEmbeddedReplyTarget (MkReplyTarget (Arg orig ser)) = MkReplyTarget (Arg (toEmbeddedOrigin orig) (embedReplySerializer ser))
src/Control/Eff/Concurrent/Pure.hs view
@@ -15,34 +15,36 @@ -- @since 0.25.0 module Control.Eff.Concurrent.Pure ( -- * Generic functions and type for Processes and Messages- module Control.Eff.Concurrent+ module Control.Eff.Concurrent,+ -- * Scheduler- , schedule- , Effects- , SafeEffects- , BaseEffects- , HasBaseEffects- -- * External Libraries- ) where+ schedule,+ Effects,+ SafeEffects,+ BaseEffects,+ HasBaseEffects, -import Control.Eff-import Control.Eff.Concurrent hiding- ( schedule- , defaultMain- , defaultMainWithLogWriter- , Effects- , SafeEffects- , BaseEffects- , HasBaseEffects- )+ -- * External Libraries+ )+where +import Control.Eff+import Control.Eff.Concurrent hiding+ ( BaseEffects,+ Effects,+ HasBaseEffects,+ SafeEffects,+ defaultMain,+ defaultMainWithLogWriter,+ schedule,+ ) import Control.Eff.Concurrent.Process.SingleThreadedScheduler -- | Run the 'Effects' using a single threaded, coroutine based, pure scheduler -- from "Control.Eff.Concurrent.Process.SingleThreadedScheduler". -- -- @since 0.25.0-schedule :: Eff Effects a -> Either (Interrupt 'NoRecovery) a+schedule :: Eff Effects a -> Either ShutdownReason a schedule = schedulePure -- | The effect list for 'Process' effects in the single threaded pure scheduler.@@ -69,4 +71,3 @@ -- -- @since 0.25.0 type HasBaseEffects e = HasPureBaseEffects e-
src/Control/Eff/Concurrent/SingleThreaded.hs view
@@ -16,41 +16,41 @@ -- @since 0.25.0 module Control.Eff.Concurrent.SingleThreaded ( -- * Generic functions and type for Processes and Messages- module Control.Eff.Concurrent+ module Control.Eff.Concurrent,+ -- * Scheduler- , schedule- , defaultMain- , defaultMainWithLogWriter- , Effects- , SafeEffects- , BaseEffects- , HasBaseEffects- -- * External Libraries- ) where+ schedule,+ defaultMain,+ defaultMainWithLogWriter,+ Effects,+ SafeEffects,+ BaseEffects,+ HasBaseEffects, -import Control.Eff-import Control.Eff.Concurrent hiding- ( schedule- , defaultMain- , defaultMainWithLogWriter- , Effects- , SafeEffects- , BaseEffects- , HasBaseEffects- )+ -- * External Libraries+ )+where +import Control.Eff+import Control.Eff.Concurrent hiding+ ( BaseEffects,+ Effects,+ HasBaseEffects,+ SafeEffects,+ defaultMain,+ defaultMainWithLogWriter,+ schedule,+ ) import Control.Eff.Concurrent.Process.SingleThreadedScheduler-import GHC.Stack (HasCallStack) -- | Run the 'Effects' using a single threaded, coroutine based, scheduler -- from "Control.Eff.Concurrent.Process.SingleThreadedScheduler". -- -- @since 0.25.0-schedule- :: HasCallStack- => LogWriter- -> Eff Effects a- -> IO (Either (Interrupt 'NoRecovery) a)+schedule ::+ LogWriter ->+ Eff Effects a ->+ IO (Either ShutdownReason a) schedule = scheduleIOWithLogging -- | The effect list for 'Process' effects in the single threaded scheduler.@@ -81,4 +81,3 @@ -- -- @since 0.25.0 type HasBaseEffects e = HasBaseEffectsIo e-
src/Control/Eff/ExceptionExtra.hs view
@@ -1,34 +1,24 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-}+ -- | Add-ons to 'Control.Eff.Exception' and 'Control.Exception' module Control.Eff.ExceptionExtra- ( liftTry- , maybeThrow- , module Eff+ ( maybeThrow,+ module Eff, ) where -import qualified Control.Exception.Safe as Safe-import qualified Control.Monad.Catch as Catch-import Control.Eff-import Control.Eff.Extend-import Control.Eff.Exception as Eff-import GHC.Stack-import Control.Eff.Reader.Lazy as Lazy-import Control.Eff.Reader.Strict as Strict---- | Catch 'Safe.Exception' thrown by an effect.-liftTry- :: forall e r a- . (HasCallStack, Safe.Exception e, Lifted IO r)- => Eff r a- -> Eff r (Either e a)-liftTry m = (Right <$> m) `catchDynE` (return . Left)-+import Control.Eff+import Control.Eff.Exception as Eff+import Control.Eff.Extend+import Control.Eff.Reader.Lazy as Lazy+import Control.Eff.Reader.Strict as Strict+import qualified Control.Exception.Safe as Safe+import qualified Control.Monad.Catch as Catch -- | Very similar to 'Eff.liftEither' but for 'Maybe's. Unlike 'Eff.liftMaybe' this -- will throw the given value (instead of using 'Eff.Fail').@@ -55,39 +45,41 @@ mask maskedEffect = do readerValue <- Lazy.ask @x raise- (Catch.mask- (\nestedUnmask -> Lazy.runReader- readerValue- (maskedEffect- (\unmasked ->- raise (nestedUnmask (Lazy.runReader readerValue unmasked))- )+ ( Catch.mask+ ( \nestedUnmask ->+ Lazy.runReader+ readerValue+ ( maskedEffect+ ( \unmasked ->+ raise (nestedUnmask (Lazy.runReader readerValue unmasked))+ )+ ) )- ) ) uninterruptibleMask maskedEffect = do readerValue <- Lazy.ask @x raise- (Catch.uninterruptibleMask- (\nestedUnmask -> Lazy.runReader- readerValue- (maskedEffect- (\unmasked ->- raise (nestedUnmask (Lazy.runReader readerValue unmasked))- )+ ( Catch.uninterruptibleMask+ ( \nestedUnmask ->+ Lazy.runReader+ readerValue+ ( maskedEffect+ ( \unmasked ->+ raise (nestedUnmask (Lazy.runReader readerValue unmasked))+ )+ ) )- ) ) generalBracket acquire release use = do readerValue <- Lazy.ask @x- let- lower :: Eff (Lazy.Reader x ': e) a -> Eff e a- lower = Lazy.runReader readerValue+ let lower :: Eff (Lazy.Reader x ': e) a -> Eff e a+ lower = Lazy.runReader readerValue raise- (Catch.generalBracket- (lower acquire)- (((.).(.)) lower release)- (lower . use))+ ( Catch.generalBracket+ (lower acquire)+ (((.) . (.)) lower release)+ (lower . use)+ ) -- ** Strict Reader @@ -107,39 +99,41 @@ mask maskedEffect = do readerValue <- Strict.ask @x raise- (Catch.mask- (\nestedUnmask -> Strict.runReader- readerValue- (maskedEffect- (\unmasked ->- raise (nestedUnmask (Strict.runReader readerValue unmasked))- )+ ( Catch.mask+ ( \nestedUnmask ->+ Strict.runReader+ readerValue+ ( maskedEffect+ ( \unmasked ->+ raise (nestedUnmask (Strict.runReader readerValue unmasked))+ )+ ) )- ) ) uninterruptibleMask maskedEffect = do readerValue <- Strict.ask @x raise- (Catch.uninterruptibleMask- (\nestedUnmask -> Strict.runReader- readerValue- (maskedEffect- (\unmasked ->- raise (nestedUnmask (Strict.runReader readerValue unmasked))- )+ ( Catch.uninterruptibleMask+ ( \nestedUnmask ->+ Strict.runReader+ readerValue+ ( maskedEffect+ ( \unmasked ->+ raise (nestedUnmask (Strict.runReader readerValue unmasked))+ )+ ) )- ) ) generalBracket acquire release use = do readerValue <- Strict.ask @x- let- lower :: Eff (Strict.Reader x ': e) a -> Eff e a- lower = Strict.runReader readerValue+ let lower :: Eff (Strict.Reader x ': e) a -> Eff e a+ lower = Strict.runReader readerValue raise- (Catch.generalBracket- (lower acquire)- (((.).(.)) lower release)- (lower . use))+ ( Catch.generalBracket+ (lower acquire)+ (((.) . (.)) lower release)+ (lower . use)+ ) -- ** Lifted IO @@ -155,32 +149,34 @@ instance Catch.MonadMask m => Catch.MonadMask (Eff '[Lift m]) where mask maskedEffect = lift- (Catch.mask- (\nestedUnmask -> runLift- (maskedEffect- (\unmasked -> lift (nestedUnmask (runLift unmasked))- )+ ( Catch.mask+ ( \nestedUnmask ->+ runLift+ ( maskedEffect+ ( \unmasked -> lift (nestedUnmask (runLift unmasked))+ )+ ) )- ) ) uninterruptibleMask maskedEffect = lift- (Catch.uninterruptibleMask- (\nestedUnmask -> runLift- (maskedEffect- (\unmasked ->- lift (nestedUnmask (runLift unmasked))- )+ ( Catch.uninterruptibleMask+ ( \nestedUnmask ->+ runLift+ ( maskedEffect+ ( \unmasked ->+ lift (nestedUnmask (runLift unmasked))+ )+ ) )- ) ) generalBracket acquire release use = lift- (Catch.generalBracket- (runLift acquire)- (((.).(.)) runLift release)- (runLift . use))-+ ( Catch.generalBracket+ (runLift acquire)+ (((.) . (.)) runLift release)+ (runLift . use)+ ) instance Catch.MonadThrow (Eff e) => Catch.MonadThrow (Eff (Exc x ': e)) where throwM exception = raise (Catch.throwM exception)@@ -196,47 +192,54 @@ instance Catch.MonadMask (Eff e) => Catch.MonadMask (Eff (Exc x ': e)) where mask maskedEffect = do- errorOrResult <- raise- (Catch.mask- (\nestedUnmask -> runError- (maskedEffect- (\unmasked -> do- errorOrResult <- raise (nestedUnmask (runError unmasked))- liftEither errorOrResult+ errorOrResult <-+ raise+ ( Catch.mask+ ( \nestedUnmask ->+ runError+ ( maskedEffect+ ( \unmasked -> do+ errorOrResult <- raise (nestedUnmask (runError unmasked))+ liftEither errorOrResult+ )+ ) )- ) )- ) liftEither errorOrResult uninterruptibleMask maskedEffect = do- errorOrResult <- raise- (Catch.uninterruptibleMask- (\nestedUnmask -> runError- (maskedEffect- (\unmasked -> do- errorOrResult <- raise (nestedUnmask (runError unmasked))- liftEither errorOrResult+ errorOrResult <-+ raise+ ( Catch.uninterruptibleMask+ ( \nestedUnmask ->+ runError+ ( maskedEffect+ ( \unmasked -> do+ errorOrResult <- raise (nestedUnmask (runError unmasked))+ liftEither errorOrResult+ )+ ) )- ) )- ) liftEither errorOrResult generalBracket acquire release use = do- (useResultOrError, releaseResultOrError) <- raise- (Catch.generalBracket- (runError acquire)- (\resourceRight exitCase ->- case resourceRight of- Left e -> return (Left e) -- acquire failed- Right resource ->- case exitCase of- Catch.ExitCaseSuccess (Right b) -> runError (release resource (Catch.ExitCaseSuccess b))- Catch.ExitCaseException e -> runError (release resource (Catch.ExitCaseException e))- _ -> runError (release resource Catch.ExitCaseAbort)- )- (\case- Left e -> return (Left e)- Right resource -> runError (use resource)))+ (useResultOrError, releaseResultOrError) <-+ raise+ ( Catch.generalBracket+ (runError acquire)+ ( \resourceRight exitCase ->+ case resourceRight of+ Left e -> return (Left e) -- acquire failed+ Right resource ->+ case exitCase of+ Catch.ExitCaseSuccess (Right b) -> runError (release resource (Catch.ExitCaseSuccess b))+ Catch.ExitCaseException e -> runError (release resource (Catch.ExitCaseException e))+ _ -> runError (release resource Catch.ExitCaseAbort)+ )+ ( \case+ Left e -> return (Left e)+ Right resource -> runError (use resource)+ )+ ) c <- liftEither releaseResultOrError -- if both results are bad, fire the release error b <- liftEither useResultOrError return (b, c)
src/Control/Eff/Log.hs view
@@ -18,38 +18,38 @@ -- > $ do -- > logDebug "test 1.1" -- > logError "test 1.2"--- > censorLogs (prefixLogMessagesWith "NESTED: ")+-- > censorLogs (prefixLogEventsWith "NESTED: ") -- > $ do -- > addLogWriter debugTraceLogWriter--- > $ setLogPredicate (\m -> (view lmMessage m) /= "not logged")+-- > $ setLogPredicate (\m -> (view logEventMessage m) /= "not logged") -- > $ do -- > logInfo "not logged"--- > logMsg "test 2.1"+-- > sendLogEvent "test 2.1" -- > logWarning "test 2.2" -- > logCritical "test 1.3" -- -- == Log Message Data Type ----- A singular /logging event/ is contained in a __'LogMessage's__ value.+-- A singular /logging event/ is contained in a __'LogEvent's__ value. ----- The 'LogMessage' is modelled along RFC-5424.+-- The 'LogEvent' is modelled along RFC-5424. ----- There is the 'ToLogMessage' class for converting to 'LogMessage'.+-- There is the 'ToLogEntry' class for converting to 'LogEvent'. -- /Although the author is not clear on how to pursue the approach./ -- -- == Receiving and Filtering ----- 'LogMessage's are sent using 'logMsg' and friends, see "Control.Eff.Log#SendingLogs"+-- 'LogEvent's are sent using 'sendLogEvent' and friends, see "Control.Eff.Log#SendingLogs" -- -- === Log Message Predicates -- -- There is a single global 'LogPredicate' that can be used to suppress logs before -- they are passed to any 'LogWriter'. ----- This is done by the 'logMsg' function.+-- This is done by the 'sendLogEvent' function. ----- Also, 'LogMessage's are evaluated using 'Control.DeepSeq.deepseq', __after__ they pass the 'LogPredicate',--- also inside 'logMsg'.+-- Also, 'LogEvent's are evaluated using 'Control.DeepSeq.deepseq', __after__ they pass the 'LogPredicate',+-- also inside 'sendLogEvent'. -- -- See "Control.Eff.Log#LogPredicate" --@@ -60,91 +60,80 @@ -- -- === Log Message Rendering ----- Message are rendered by 'LogMessageRenderer's found in the "Control.Eff.Log.MessageRenderer".+-- Message are rendered by 'LogEventReader's found in the "Control.Eff.Log.MessageRenderer". -- -- === 'LogWriter's -- -- * FilteredLogging in a 'Control.Concurrent.Async.withAsync' spawned thread is done using 'withAsyncLogging'.- module Control.Eff.Log ( -- * FilteredLogging API+ -- ** Sending Log Messages #SendingLogs#- logMsg- , logWithSeverity- , logWithSeverity'- , logEmergency- , logEmergency'- , logAlert- , logAlert'- , logCritical- , logCritical'- , logError- , logError'- , logWarning- , logWarning'- , logNotice- , logNotice'- , logInfo- , logInfo'- , logDebug- , logDebug'- , logCallStack- , logMultiLine- , logMultiLine'+ LogEventSender (..),+ logEmergency,+ logAlert,+ logCritical,+ logError,+ logWarning,+ logNotice,+ logInfo,+ logDebug,+ logCallStack, -- ** Log Message Pre-Filtering #LogPredicate# -- $LogPredicate- , includeLogMessages- , excludeLogMessages- , setLogPredicate- , modifyLogPredicate- , askLogPredicate+ whitelistLogEvents,+ blacklistLogEvents,+ setLogPredicate,+ modifyLogPredicate,+ askLogPredicate, -- * Log Handling API -- ** Writing Logs- , setLogWriter- , addLogWriter- , modifyLogWriter+ setLogWriter,+ addLogWriter,+ modifyLogWriter, -- *** Log Message Modification- , censorLogs- , censorLogsIo+ censorLogs,+ censorLogsIo, -- ** 'Logs' Effect Handling- , Logs()- , FilteredLogging- , IoLogging- , LoggingAndIo- , withLogging- , withoutLogging+ Logs (),+ FilteredLogging,+ IoLogging,+ LoggingAndIo,+ withLogging,+ withoutLogging, -- ** Low-Level API for Custom Extensions+ -- *** Log Message Interception- , runLogs- , respondToLogMessage- , interceptLogMessages+ runLogs,+ respondToLogEvent,+ interceptLogMessages, -- * Module Re-Exports- -- | The module that contains the 'LogMessage' and 'LogPredicate' definitions.++ -- | The module that contains the 'LogEvent' and 'LogPredicate' definitions. -- -- The log message type corresponds roughly to RFC-5424, including structured data.- , module Control.Eff.Log.Message- -- | Rendering functions for 'LogMessage's+ module Control.Eff.Log.Message,+ -- | Rendering functions for 'LogEvent's -- -- The functions have been seperated from "Control.Eff.Log.Message"- , module Control.Eff.Log.MessageRenderer-+ module Control.Eff.Log.MessageRenderer, -- | This module defines the 'LogWriter' type, which is used to give -- callback functions for log messages an explicit type.- , module Control.Eff.Log.Writer+ module Control.Eff.Log.Writer, ) where -import Control.Eff.Log.Handler-import Control.Eff.Log.Message-import Control.Eff.Log.MessageRenderer-import Control.Eff.Log.Writer+import Control.Eff.Log.Handler+import Control.Eff.Log.Message+import Control.Eff.Log.MessageRenderer+import Control.Eff.Log.Writer -- $LogPredicate --@@ -152,8 +141,8 @@ -- -- * 'setLogPredicate'. -- * 'modifyLogPredicate'.--- * 'includeLogMessages'--- * 'excludeLogMessages'+-- * 'whitelistLogEvents'+-- * 'blacklistLogEvents' -- -- The current predicate is retrieved via 'askLogPredicate'. --
src/Control/Eff/Log/Examples.hs view
@@ -1,37 +1,41 @@--- | Examples for FilteredLogging.+{-# LANGUAGE NoOverloadedStrings #-}++-- -- | Examples for FilteredLogging. module Control.Eff.Log.Examples ( -- * Example Code for FilteredLogging- exampleLogging- , exampleWithLogging- , exampleWithSomeLogging- , exampleSetLogWriter- , exampleLogTrace- , exampleAsyncLogging- , exampleRFC5424Logging- , exampleRFC3164WithRFC5424TimestampsLogging- , exampleDevLogSyslogLogging- , exampleDevLogRFC5424Logging- , exampleUdpRFC5424Logging- , exampleUdpRFC3164Logging- -- * Example Client Code- , loggingExampleClient- , logPredicatesExampleClient+ exampleLogging,+ exampleWithLogging,+ exampleWithSomeLogging,+ exampleSetLogWriter,+ exampleLogTrace,+ exampleAsyncLogging,+ exampleRFC5424Logging,+ exampleRFC3164WithRFC5424TimestampsLogging,+ exampleDevLogSyslogLogging,+ exampleDevLogRFC5424Logging,+ exampleUdpRFC5424Logging,+ exampleUdpRFC3164Logging,++ -- * Example Client Code+ loggingExampleClient,+ logPredicatesExampleClient, ) where -import Control.Eff.Log-import Control.Eff.LogWriter.Async-import Control.Eff.LogWriter.Console-import Control.Eff.LogWriter.DebugTrace-import Control.Eff.LogWriter.Rich-import Control.Eff.LogWriter.UnixSocket-import Control.Eff.LogWriter.UDP-import Control.Eff-import Control.Lens ( view- , (%~)- , to- )-import GHC.Stack+import Control.Eff+import Control.Eff.Log+import Control.Eff.LogWriter.Async+import Control.Eff.LogWriter.Console+import Control.Eff.LogWriter.DebugTrace+import Control.Eff.LogWriter.Rich+import Control.Eff.LogWriter.UDP+import Control.Eff.LogWriter.UnixSocket+import Control.Lens+ ( to,+ view,+ (%~),+ )+import GHC.Stack -- * FilteredLogging examples @@ -41,8 +45,9 @@ -- * 'MkLogWriter' -- See 'loggingExampleClient' exampleLogging :: HasCallStack => IO ()-exampleLogging = runLift- $ withConsoleLogging "my-app" local7 allLogMessages loggingExampleClient+exampleLogging =+ runLift $+ withConsoleLogging "my-app" local7 allLogEvents loggingExampleClient -- | Example code for: --@@ -73,12 +78,12 @@ exampleSetLogWriter = do lw1 <- stdoutLogWriter renderConsoleMinimalisticWide lw2 <- consoleLogWriter- runLift- $ withLogging lw1- $ do logAlert "test with log writer 1"- setLogWriter lw2 (logAlert "test with log writer 2")- logAlert "test with log writer 1 again"-+ runLift $+ withLogging lw1 $+ do+ logAlert "test with log writer 1"+ setLogWriter lw2 (logAlert "test with log writer 2")+ logAlert "test with log writer 1 again" -- | Example code for: --@@ -89,85 +94,111 @@ exampleLogTrace :: IO () exampleLogTrace = do lw <- consoleLogWriter- runLift- $ withRichLogging lw "test-app" local7 allLogMessages- $ addLogWriter- (filteringLogWriter- severeMessages- (mappingLogWriter (lmMessage %~ ("TRACED " <>))- (debugTraceLogWriter renderRFC5424)- )+ runLift $+ withRichLogging lw "test-app" local7 allLogEvents $+ addLogWriter+ ( filteringLogWriter+ severeMessages+ ( mappingLogWriter+ (logEventMessage %~ (packLogMsg "TRACED " <>))+ (debugTraceLogWriter renderRFC5424)+ ) )- $ do- logEmergency "test emergencySeverity 1"- logCritical "test criticalSeverity 2"- logAlert "test alertSeverity 3"- logError "test errorSeverity 4"- logWarning "test warningSeverity 5"- logInfo "test informationalSeverity 6"- logDebug "test debugSeverity 7"+ $ do+ logEmergency $ MSG "emergencySeverity 1"+ logCritical $ MSG "criticalSeverity 2"+ logAlert $ MSG "alertSeverity 3"+ logError $ MSG "errorSeverity 4"+ logWarning $ MSG "warningSeverity 5"+ logInfo $ MSG "informationalSeverity 6"+ logDebug $ MSG "debugSeverity 7" where- severeMessages = view (lmSeverity . to (<= errorSeverity))+ severeMessages = view (logEventSeverity . to (<= errorSeverity)) +newtype TestLogMsg = TestMSG String +instance ToLogMsg TestLogMsg where+ toLogMsg (TestMSG x) = packLogMsg x+ -- | Example code for: -- -- * 'withAsyncLogging' exampleAsyncLogging :: IO () exampleAsyncLogging = do lw <- stdoutLogWriter renderConsoleMinimalisticWide- runLift $ withLogging lw $ withAsyncLogWriter (1000 :: Int) $ do- logInfo "test 1"- logInfo "test 2"- logInfo "test 3"-+ runLift $+ withLogging lw $+ withAsyncLogWriter (1000 :: Int) $ do+ logInfo $ MSG "test 1"+ logInfo $ TestMSG "test 2"+ logInfo $ MSG "test 3" -- | Example code for RFC5424 formatted logs. exampleRFC5424Logging :: IO Int exampleRFC5424Logging =- runLift- $ withoutLogging- $ setLogWriter+ runLift $+ withoutLogging $+ setLogWriter (richLogWriter "myapp" local2 (debugTraceLogWriter renderRFC5424))- logPredicatesExampleClient+ logPredicatesExampleClient -- | Example code for RFC3164 with RFC5424 time stamp formatted logs. exampleRFC3164WithRFC5424TimestampsLogging :: IO Int exampleRFC3164WithRFC5424TimestampsLogging =- runLift- $ withoutLogging- $ setLogWriter+ runLift $+ withoutLogging $+ setLogWriter (richLogWriter "myapp" local2 (debugTraceLogWriter renderRFC3164WithRFC5424Timestamps))- logPredicatesExampleClient+ logPredicatesExampleClient -- | Example code logging via a unix domain socket to @/dev/log@. exampleDevLogSyslogLogging :: IO Int exampleDevLogSyslogLogging =- runLift- $ withUnixSocketLogging renderLogMessageSyslog "/dev/log" "myapp" local2 allLogMessages+ runLift $+ withUnixSocketLogging+ renderLogEventSyslog+ "/dev/log"+ "myapp"+ local2+ allLogEvents logPredicatesExampleClient - -- | Example code logging via a unix domain socket to @/dev/log@. exampleDevLogRFC5424Logging :: IO Int exampleDevLogRFC5424Logging =- runLift- $ withUnixSocketLogging renderRFC5424 "/dev/log" "myapp" local2 allLogMessages+ runLift $+ withUnixSocketLogging+ renderRFC5424+ "/dev/log"+ "myapp"+ local2+ allLogEvents logPredicatesExampleClient - -- | Example code logging RFC5424 via UDP port 514 on localhost. exampleUdpRFC5424Logging :: IO Int exampleUdpRFC5424Logging =- runLift- $ withUDPLogging renderRFC5424 "localhost" "514" "myapp" local2 allLogMessages+ runLift $+ withUDPLogging+ renderRFC5424+ "localhost"+ "514"+ "myapp"+ local2+ allLogEvents logPredicatesExampleClient -- | Example code logging RFC5424 via UDP port 514 on localhost. exampleUdpRFC3164Logging :: IO Int exampleUdpRFC3164Logging =- runLift- $ withUDPLogging renderRFC3164 "localhost" "514" "myapp" local1 allLogMessages+ runLift $+ withUDPLogging+ renderRFC3164+ "localhost"+ "514"+ "myapp"+ local1+ allLogEvents logPredicatesExampleClient -- | Example logging client code@@ -175,63 +206,62 @@ -- * 'addLogWriter' -- * 'debugTraceLogWriter' -- * 'setLogPredicate'--- * 'prefixLogMessagesWith'+-- * 'prefixLogEventsWith' -- * 'renderRFC3164'--- * 'logMsg'+-- * 'sendLogEvent' -- * 'logDebug' -- * 'logError' -- * 'logInfo' -- * 'logWarning' -- * 'logCritical'--- * 'lmMessage'+-- * 'logEventMessage' loggingExampleClient :: (HasCallStack, IoLogging e) => Eff e () loggingExampleClient = do- logDebug "test 1.1"- logError "test 1.2"- censorLogs (prefixLogMessagesWith "NESTED: ") $ do- addLogWriter (debugTraceLogWriter renderRFC3164)- $ setLogPredicate (\m -> view lmMessage m /= "not logged")- $ do- logInfo "not logged"- logMsg "test 2.1"- logWarning "test 2.2"- logCritical "test 1.3"-+ logDebug (packLogMsg "test 1.1")+ logError (MSG "test 1.2")+ censorLogs (prefixLogEventsWith ("NESTED: " :: String)) $ do+ addLogWriter (debugTraceLogWriter renderRFC3164) $+ setLogPredicate (\m -> view logEventMessage m /= packLogMsg "not logged") $+ do+ logInfo (MSG "not logged")+ sendLogEvent (infoMessage (MSG "test 2.1"))+ logWarning (LABEL "test" True)+ logCritical (MSG "test 1.3") -- | Example logging client code using many 'LogPredicate's. -- -- * 'setLogPredicate' -- * 'modifyLogPredicate'--- * 'lmMessageStartsWith'--- * 'lmSeverityIs'--- * 'lmSeverityIsAtLeast'--- * 'includeLogMessages'--- * 'excludeLogMessages'+-- * 'logEventMessageStartsWith'+-- * 'logEventSeverityIs'+-- * 'logEventSeverityIsAtLeast'+-- * 'whitelistLogEvents'+-- * 'blacklistLogEvents' logPredicatesExampleClient :: (HasCallStack, IoLogging e) => Eff e Int logPredicatesExampleClient = do logInfo "test" setLogPredicate- (lmMessageStartsWith "OMG")- (do- logInfo "this message will not be logged"- logInfo "OMG logged"- modifyLogPredicate (\p lm -> p lm || lmSeverityIs errorSeverity lm) $ do- logDebug "OMG logged"- logInfo "Not logged"- logError "Logged"- logEmergency "Not Logged"- includeLogMessages (lmSeverityIsAtLeast warningSeverity) $ do+ (logEventMessageStartsWith "OMG")+ ( do+ logInfo "this message will not be logged"+ logInfo "OMG logged"+ modifyLogPredicate (\p lm -> p lm || logEventSeverityIs errorSeverity lm) $ do+ logDebug "OMG logged" logInfo "Not logged" logError "Logged"- logEmergency "Logged"- logWarning "Logged"- logDebug "OMG still Logged"- excludeLogMessages (lmMessageStartsWith "OMG") $ do- logDebug "OMG NOT Logged"- logError "OMG ALSO NOT Logged"- logEmergency "Still Logged"- logWarning "Still Logged"- logWarning "Logged"- logDebug "OMG still Logged"- return 42+ logEmergency "Not Logged"+ whitelistLogEvents (logEventSeverityIsAtLeast warningSeverity) $ do+ logInfo "Not logged"+ logError "Logged"+ logEmergency "Logged"+ logWarning "Logged"+ logDebug "OMG still Logged"+ blacklistLogEvents (logEventMessageStartsWith "OMG") $ do+ logDebug "OMG NOT Logged"+ logError "OMG ALSO NOT Logged"+ logEmergency "Still Logged"+ logWarning "Still Logged"+ logWarning "Logged"+ logDebug "OMG still Logged"+ return 42 )
src/Control/Eff/Log/Handler.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-}+ -- | A memory efficient, streaming, logging effect with support for -- efficiently not logging when no logs are required. --@@ -6,171 +7,313 @@ -- as well as asynchronous logging in another thread. module Control.Eff.Log.Handler ( -- * FilteredLogging API+ -- ** Sending Log Messages- logMsg- , logWithSeverity- , logWithSeverity'- , logEmergency- , logEmergency'- , logAlert- , logAlert'- , logCritical- , logCritical'- , logError- , logError'- , logWarning- , logWarning'- , logNotice- , logNotice'- , logInfo- , logInfo'- , logDebug- , logDebug'- , logCallStack- , logMultiLine- , logMultiLine'+ Logs (..),+ LogEventSender (..),+ logEmergency,+ logAlert,+ logCritical,+ logError,+ logWarning,+ logNotice,+ logInfo,+ logDebug,+ logCallStack,+ logMultiLine, - -- ** Log Message Pre-Filtering #LogPredicate#- , includeLogMessages- , excludeLogMessages- , setLogPredicate- , modifyLogPredicate- , askLogPredicate+ -- ** Log Message Pre-Filtering #LogPredicate#+ whitelistLogEvents,+ blacklistLogEvents,+ setLogPredicate,+ modifyLogPredicate,+ askLogPredicate, - -- * Log Handling API+ -- * Log Handling API - -- ** Writing Logs- , setLogWriter- , addLogWriter- , modifyLogWriter+ -- ** Writing Logs+ setLogWriter,+ addLogWriter,+ modifyLogWriter, - -- *** Log Message Modification- , censorLogs- , censorLogsIo+ -- *** Log Message Modification+ censorLogs,+ censorLogsIo, - -- ** 'Logs' Effect Handling- , Logs()- , FilteredLogging- , IoLogging- , LoggingAndIo- , withLogging- , withoutLogging+ -- ** 'Logs' Effect Handling+ FilteredLogging,+ IoLogging,+ LoggingAndIo,+ withLogging,+ withoutLogging, - -- ** Low-Level API for Custom Extensions- -- *** Log Message Interception- , runLogs- , runLogsWithoutLogging- , respondToLogMessage- , interceptLogMessages+ -- ** Low-Level API for Custom Extensions + -- *** Log Message Interception+ runLogs,+ runLogsWithoutLogging,+ respondToLogEvent,+ interceptLogMessages, ) where -import Control.DeepSeq-import Control.Eff as Eff-import Control.Eff.Extend-import Control.Eff.Log.Message-import Control.Eff.Log.Writer-import qualified Control.Exception.Safe as Safe-import Control.Lens-import Control.Monad ( when, (>=>) )-import Control.Monad.Base ( MonadBase() )-import qualified Control.Monad.Catch as Catch-import Control.Monad.Trans.Control ( MonadBaseControl- ( restoreM- , liftBaseWith- , StM- )- )-import Data.Default-import Data.Function ( fix )-import Data.Hashable-import Data.Text as T-import GHC.Stack ( HasCallStack- , callStack- , withFrozenCallStack- , prettyCallStack- )-import Data.Foldable ( traverse_ )-import Text.Printf ( printf )+import Control.DeepSeq+import Control.Eff as Eff+import Control.Eff.Extend+import Control.Eff.Log.Message+import Control.Eff.Log.Writer+import qualified Control.Exception.Safe as Safe+import Control.Lens+import Control.Monad (when, (>=>))+import Control.Monad.Base (MonadBase ())+import qualified Control.Monad.Catch as Catch+import Control.Monad.Trans.Control+ ( MonadBaseControl+ ( StM,+ liftBaseWith,+ restoreM+ ),+ )+import Data.Default+import Data.Foldable (traverse_)+import Data.Function (fix)+import Data.Hashable+import Data.Text as T+import GHC.Stack+ ( HasCallStack,+ callStack,+ prettyCallStack,+ withFrozenCallStack,+ )+import Text.Printf (printf) --- | This effect sends 'LogMessage's and is a reader for a 'LogPredicate'.+-- | Something that consumes a 'LogEvent'. ----- Logs are sent via 'logMsg';+-- This type class seems overly general, but it has to be,+-- in order to allow writing log statements with many items+-- that should be part of a log message simply like this:+--+-- >>> sendLogEvent (debugMessage "started: ") myPid (LABEL "last message" lastMsg) (LABEL "threshold" currentThresh)+--+-- Which of course is sugar-coated by functions like 'logInfo', 'logDebug', 'logError', ... to be:+--+-- >>> logDebug "started: " myPid " after receiving: " lastMsg " threshold is: " currentThresh+--+-- NOTE: The function instance will always separate the parameters with a 'SeparatorMsg'.+--+-- @since 1.0.0+class LogEventSender a where+ -- | Log a 'LogEvent'.+ --+ -- Dispatch 'LogEvent's that match the 'LogPredicate'.+ --+ -- The 'LogEvent's are evaluated using 'deepseq', __after__ they pass the 'LogPredicate'.+ --+ -- @since 1.0.0+ sendLogEvent :: HasCallStack => LogEvent -> a++-- | Extract the 'LogMsg' of the composed 'LogEvent'.+--+-- @since 1.0.0+instance LogEventSender LogMsg where+ sendLogEvent = view logEventMessage++-- | Log a 'LogEvent'.+--+-- Dispatch 'LogEvent's that match the 'LogPredicate'.+--+-- The 'LogEvent's are evaluated using 'deepseq', __after__ they pass the 'LogPredicate'.+--+-- @since 1.0.0+instance (a ~ (), Member Logs e) => LogEventSender (Eff e a) where+ sendLogEvent = withFrozenCallStack $ \msgIn -> do+ lf <- send AskLogFilter+ when (lf msgIn) $+ msgIn `deepseq` send @Logs (WriteLogMessage msgIn)++-- | Append a the 'toLogMsg' of a value, optionally appending a 'SeparationMsg'+-- to the previous 'logEventMessage'.+--+-- @since 1.0.0+instance (ToLogMsg x, LogEventSender a) => LogEventSender (x -> a) where+ sendLogEvent =+ withFrozenCallStack $ \logEvt x ->+ sendLogEvent+ ( logEvt+ & logEventMessage+ %~ ( \l ->+ if l /= mempty+ then l <> separatorMsg <> toLogMsg x+ else toLogMsg x+ )+ )++-- | This effect sends 'LogEvent's and is a reader for a 'LogPredicate'.+--+-- Logs are sent via 'sendLogEvent'; -- for more information about log predicates, see "Control.Eff.Log#LogPredicate" -- -- This effect is handled via 'withLogging'. data Logs v where- AskLogFilter- :: Logs LogPredicate- WriteLogMessage- :: !LogMessage -> Logs ()+ AskLogFilter ::+ Logs+ LogPredicate+ WriteLogMessage ::+ !LogEvent ->+ Logs () instance forall e a k. Handle Logs e a (LogPredicate -> k) where- handle h q AskLogFilter p = h (q ^$ p ) p- handle h q (WriteLogMessage _) p = h (q ^$ ()) p+ handle h q AskLogFilter p = h (q ^$ p) p+ handle h q (WriteLogMessage _) p = h (q ^$ ()) p +-- | Compose and dispatch a 'LogEvent' with 'emergencySeverity'.+--+-- @since 1.0.0+logEmergency :: (HasCallStack, LogEventSender a) => a+logEmergency = withFrozenCallStack $ sendLogEvent emptyLogMsg+ where+ emptyLogMsg = def & logEventSeverity .~ emergencySeverity++-- | Compose and dispatch a 'LogEvent' with 'alertSeverity'.+--+-- @since 1.0.0+logAlert :: (HasCallStack, LogEventSender a) => a+logAlert = withFrozenCallStack $ sendLogEvent emptyLogMsg+ where+ emptyLogMsg = def & logEventSeverity .~ alertSeverity++-- | Compose and dispatch a 'LogEvent' with 'criticalSeverity'.+--+-- @since 1.0.0+logCritical :: (HasCallStack, LogEventSender a) => a+logCritical = withFrozenCallStack $ sendLogEvent emptyLogMsg+ where+ emptyLogMsg = def & logEventSeverity .~ criticalSeverity++-- | Compose and dispatch a 'LogEvent' with 'errorSeverity'.+--+-- @since 1.0.0+logError :: (HasCallStack, LogEventSender a) => a+logError = withFrozenCallStack $ sendLogEvent emptyLogMsg+ where+ emptyLogMsg = def & logEventSeverity .~ errorSeverity++-- | Compose and dispatch a 'LogEvent' with 'warningSeverity'.+--+-- @since 1.0.0+logWarning :: (HasCallStack, LogEventSender a) => a+logWarning = withFrozenCallStack $ sendLogEvent emptyLogMsg+ where+ emptyLogMsg = def & logEventSeverity .~ warningSeverity++-- | Compose and dispatch a 'LogEvent' with 'noticeSeverity'.+--+-- @since 1.0.0+logNotice :: (HasCallStack, LogEventSender a) => a+logNotice = withFrozenCallStack $ sendLogEvent emptyLogMsg+ where+ emptyLogMsg = def & logEventSeverity .~ noticeSeverity++-- | Compose and dispatch a 'LogEvent' with 'informationalSeverity'.+--+-- @since 1.0.0+logInfo :: (HasCallStack, LogEventSender a) => a+logInfo = withFrozenCallStack $ sendLogEvent emptyLogMsg+ where+ emptyLogMsg = def & logEventSeverity .~ informationalSeverity++-- | Compose and dispatch a 'LogEvent' with 'debugSeverity'.+--+-- @since 1.0.0+logDebug :: (HasCallStack, LogEventSender a) => a+logDebug = withFrozenCallStack $ sendLogEvent emptyLogMsg+ where+ emptyLogMsg = def & logEventSeverity .~ debugSeverity++-- $PredefinedPredicates+-- == Log Message Predicates+--+-- These are the predefined 'LogPredicate's:+--+-- * 'allLogEvents'+-- * 'noLogEvents'+-- * 'logEventSeverityIsAtLeast'+-- * 'logEventSeverityIs'+-- * 'logEventMessageStartsWith'+-- * 'discriminateByAppName'+--+-- To find out how to use these predicates,+-- goto "Control.Eff.Log#LogPredicate"+ -- | This instance allows lifting the 'Logs' effect into a base monad, e.g. 'IO'. -- This instance needs a 'LogWriterReader' in the base monad,--- that is capable to handle 'logMsg' invocations.-instance forall m e. (MonadBase m IO, MonadBaseControl IO (Eff e), LiftedBase m e, Lifted IO e, IoLogging (Logs ': e))- => MonadBaseControl m (Eff (Logs ': e)) where- type StM (Eff (Logs ': e)) a = StM (Eff e) a- liftBaseWith f = do- lf <- askLogPredicate- raise (liftBaseWith (\runInBase -> f (runInBase . runLogs lf)))- restoreM = raise . restoreM+-- that is capable to handle 'sendLogEvent' invocations.+instance+ forall m e.+ (MonadBase m IO, MonadBaseControl IO (Eff e), LiftedBase m e, Lifted IO e, IoLogging (Logs ': e)) =>+ MonadBaseControl m (Eff (Logs ': e))+ where+ type StM (Eff (Logs ': e)) a = StM (Eff e) a+ liftBaseWith f = do+ lf <- askLogPredicate+ raise (liftBaseWith (\runInBase -> f (runInBase . runLogs lf)))+ restoreM = raise . restoreM -instance (LiftedBase m e, Catch.MonadThrow (Eff e))- => Catch.MonadThrow (Eff (Logs ': e)) where+instance+ (LiftedBase m e, Catch.MonadThrow (Eff e)) =>+ Catch.MonadThrow (Eff (Logs ': e))+ where throwM exception = raise (Catch.throwM exception) -instance (Applicative m, MonadBaseControl IO (Eff e), LiftedBase m e, Catch.MonadCatch (Eff e), IoLogging (Logs ': e), Lifted IO e)- => Catch.MonadCatch (Eff (Logs ': e)) where+instance+ (MonadBaseControl IO (Eff e), LiftedBase m e, Catch.MonadCatch (Eff e), IoLogging (Logs ': e), Lifted IO e) =>+ Catch.MonadCatch (Eff (Logs ': e))+ where catch effect handler = do lf <- askLogPredicate- let lower = runLogs lf- nestedEffects = lower effect+ let lower = runLogs lf+ nestedEffects = lower effect nestedHandler exception = lower (handler exception) raise (Catch.catch nestedEffects nestedHandler) -instance (Applicative m, MonadBaseControl IO (Eff e), LiftedBase m e, Catch.MonadMask (Eff e), IoLogging (Logs ': e), Lifted IO e)- => Catch.MonadMask (Eff (Logs ': e)) where+instance+ (MonadBaseControl IO (Eff e), LiftedBase m e, Catch.MonadMask (Eff e), IoLogging (Logs ': e), Lifted IO e) =>+ Catch.MonadMask (Eff (Logs ': e))+ where mask maskedEffect = do lf <- askLogPredicate- let- lower :: Eff (Logs ': e) a -> Eff e a- lower = runLogs lf+ let lower :: Eff (Logs ': e) a -> Eff e a+ lower = runLogs lf raise- (Catch.mask- (\nestedUnmask -> lower- (maskedEffect- ( raise . nestedUnmask . lower )- )+ ( Catch.mask+ ( \nestedUnmask ->+ lower+ ( maskedEffect+ (raise . nestedUnmask . lower)+ ) )- )+ ) uninterruptibleMask maskedEffect = do lf <- askLogPredicate- let- lower :: Eff (Logs ': e) a -> Eff e a- lower = runLogs lf+ let lower :: Eff (Logs ': e) a -> Eff e a+ lower = runLogs lf raise- (Catch.uninterruptibleMask- (\nestedUnmask -> lower- (maskedEffect- ( raise . nestedUnmask . lower )- )+ ( Catch.uninterruptibleMask+ ( \nestedUnmask ->+ lower+ ( maskedEffect+ (raise . nestedUnmask . lower)+ ) )- )+ ) generalBracket acquire release useIt = do lf <- askLogPredicate- let- lower :: Eff (Logs ': e) a -> Eff e a- lower = runLogs lf+ let lower :: Eff (Logs ': e) a -> Eff e a+ lower = runLogs lf raise- (Catch.generalBracket+ ( Catch.generalBracket (lower acquire)- (((.).(.)) lower release)+ (((.) . (.)) lower release) (lower . useIt) ) @@ -209,7 +352,6 @@ -- This also provides both 'IoLogging' and 'FilteredLogging'. type LoggingAndIo = '[Logs, LogWriterReader, Lift IO] - -- | Handle the 'Logs' and 'LogWriterReader' effects. -- -- It installs the given 'LogWriter', which determines the underlying@@ -226,9 +368,8 @@ -- This provides the 'IoLogging' and 'FilteredLogging' effects. -- -- See also 'runLogs'.--- withLogging :: Lifted IO e => LogWriter -> Eff (Logs ': LogWriterReader ': e) a -> Eff e a-withLogging lw = runLogWriterReader lw . runLogs allLogMessages+withLogging lw = runLogWriterReader lw . runLogs allLogEvents -- | Handles the 'Logs' and 'LogWriterReader' effects, while not invoking the 'LogWriter' at all. --@@ -245,248 +386,40 @@ -- This provides the 'FilteredLogging' effect. -- -- See also 'runLogsWithoutLogging'.--- withoutLogging :: Eff (Logs ': LogWriterReader ': e) a -> Eff e a-withoutLogging = runLogWriterReader mempty . runLogsWithoutLogging noLogMessages+withoutLogging = runLogWriterReader mempty . runLogsWithoutLogging noLogEvents -- | Raw handling of the 'Logs' effect. -- Exposed for custom extensions, if in doubt use 'withLogging'.-runLogs- :: forall e b .- ( Member LogWriterReader (Logs ': e)- , Lifted IO e- )- => LogPredicate- -> Eff (Logs ': e) b- -> Eff e b+runLogs ::+ forall e b.+ ( Member LogWriterReader (Logs ': e),+ Lifted IO e+ ) =>+ LogPredicate ->+ Eff (Logs ': e) b ->+ Eff e b runLogs p m =- fix (handle_relay (\a _ -> return a)) (sendLogMessageToLogWriter m) p+ fix (handle_relay (\a _ -> return a)) (sendLogMessageToLogWriter m) p -- | Raw handling of the 'Logs' effect. -- Exposed for custom extensions, if in doubt use 'withoutLogging'.-runLogsWithoutLogging- :: forall e b .- ( Member LogWriterReader (Logs ': e)- )- => LogPredicate- -> Eff (Logs ': e) b- -> Eff e b+runLogsWithoutLogging ::+ forall e b.+ LogPredicate ->+ Eff (Logs ': e) b ->+ Eff e b runLogsWithoutLogging p m = fix (handle_relay (\a _ -> return a)) m p --- | Log a message.------ All logging goes through this function.------ This function is the only place where the 'LogPredicate' is applied.------ Also, 'LogMessage's are evaluated using 'deepseq', __after__ they pass the 'LogPredicate'.-logMsg :: forall e . (HasCallStack, Member Logs e) => LogMessage -> Eff e ()-logMsg = withFrozenCallStack $ \msgIn -> do- lf <- askLogPredicate- when (lf msgIn) $- msgIn `deepseq` send @Logs (WriteLogMessage msgIn)---- | Log a 'T.Text' as 'LogMessage' with a given 'Severity'.-logWithSeverity- :: forall e .- ( HasCallStack- , Member Logs e- )- => Severity- -> Text- -> Eff e ()-logWithSeverity = withFrozenCallStack $ \s ->- logMsg- . setCallStack callStack- . set lmSeverity s- . flip (set lmMessage) def---- | Log a 'T.Text' as 'LogMessage' with a given 'Severity'.-logWithSeverity'- :: forall e .- ( HasCallStack- , Member Logs e- )- => Severity- -> String- -> Eff e ()-logWithSeverity' = withFrozenCallStack- (\s m ->- logMsg- $ setCallStack callStack- $ set lmSeverity s- $ ( def & lmMessage .~ T.pack m))---- | Log a 'String' as 'emergencySeverity'.-logEmergency- :: forall e .- ( HasCallStack- , Member Logs e- )- => Text- -> Eff e ()-logEmergency = withFrozenCallStack (logWithSeverity emergencySeverity)---- | Log a message with 'alertSeverity'.-logAlert- :: forall e .- ( HasCallStack- , Member Logs e- )- => Text- -> Eff e ()-logAlert = withFrozenCallStack (logWithSeverity alertSeverity)---- | Log a 'criticalSeverity' message.-logCritical- :: forall e .- ( HasCallStack- , Member Logs e- )- => Text- -> Eff e ()-logCritical = withFrozenCallStack (logWithSeverity criticalSeverity)---- | Log a 'errorSeverity' message.-logError- :: forall e .- ( HasCallStack- , Member Logs e- )- => Text- -> Eff e ()-logError = withFrozenCallStack (logWithSeverity errorSeverity)---- | Log a 'warningSeverity' message.-logWarning- :: forall e .- ( HasCallStack- , Member Logs e- )- => Text- -> Eff e ()-logWarning = withFrozenCallStack (logWithSeverity warningSeverity)---- | Log a 'noticeSeverity' message.-logNotice- :: forall e .- ( HasCallStack- , Member Logs e- )- => Text- -> Eff e ()-logNotice = withFrozenCallStack (logWithSeverity noticeSeverity)---- | Log a 'informationalSeverity' message.-logInfo- :: forall e .- ( HasCallStack- , Member Logs e- )- => Text- -> Eff e ()-logInfo = withFrozenCallStack (logWithSeverity informationalSeverity)---- | Log a 'debugSeverity' message.-logDebug- :: forall e .- ( HasCallStack- , Member Logs e- )- => Text- -> Eff e ()-logDebug = withFrozenCallStack (logWithSeverity debugSeverity)---- | Log a 'String' as 'emergencySeverity'.-logEmergency'- :: forall e .- ( HasCallStack- , Member Logs e- )- => String- -> Eff e ()-logEmergency' = withFrozenCallStack (logWithSeverity' emergencySeverity)---- | Log a message with 'alertSeverity'.-logAlert'- :: forall e .- ( HasCallStack- , Member Logs e- )- => String- -> Eff e ()-logAlert' = withFrozenCallStack (logWithSeverity' alertSeverity)---- | Log a 'criticalSeverity' message.-logCritical'- :: forall e .- ( HasCallStack- , Member Logs e- )- => String- -> Eff e ()-logCritical' = withFrozenCallStack (logWithSeverity' criticalSeverity)---- | Log a 'errorSeverity' message.-logError'- :: forall e .- ( HasCallStack- , Member Logs e- )- => String- -> Eff e ()-logError' = withFrozenCallStack (logWithSeverity' errorSeverity)---- | Log a 'warningSeverity' message.-logWarning'- :: forall e .- ( HasCallStack- , Member Logs e- )- => String- -> Eff e ()-logWarning' = withFrozenCallStack (logWithSeverity' warningSeverity)---- | Log a 'noticeSeverity' message.-logNotice'- :: forall e .- ( HasCallStack- , Member Logs e- )- => String- -> Eff e ()-logNotice' = withFrozenCallStack (logWithSeverity' noticeSeverity)---- | Log a 'informationalSeverity' message.-logInfo'- :: forall e .- ( HasCallStack- , Member Logs e- )- => String- -> Eff e ()-logInfo' = withFrozenCallStack (logWithSeverity' informationalSeverity)---- | Log a 'debugSeverity' message.-logDebug'- :: forall e .- ( HasCallStack- , Member Logs e- )- => String- -> Eff e ()-logDebug' = withFrozenCallStack (logWithSeverity' debugSeverity)- -- | Log the current 'callStack' using the given 'Severity'. -- -- @since 0.30.0-logCallStack :: forall e . (HasCallStack, Member Logs e) => Severity -> Eff e ()+logCallStack :: forall e. (HasCallStack, Member Logs e) => Severity -> Eff e () logCallStack = withFrozenCallStack $ \s ->- let stackTraceLines = T.lines (pack (prettyCallStack callStack))- in logMultiLine s stackTraceLines-+ let stackTraceLines = MkLogMsg <$> T.lines (pack (prettyCallStack callStack))+ in logMultiLine s stackTraceLines -- | Issue a log statement for each item in the list prefixed with a line number and a message hash. --@@ -498,56 +431,30 @@ -- multi-line log message. -- -- @since 0.30.0-logMultiLine- :: forall e- . ( HasCallStack- , Member Logs e- )- => Severity- -> [Text]- -> Eff e ()+logMultiLine ::+ forall e.+ ( HasCallStack,+ Member Logs e+ ) =>+ Severity ->+ [LogMsg] ->+ Eff e () logMultiLine = withFrozenCallStack $ \s messageLines -> do- let msgHash = T.pack $ printf "multi-line message %06X" $ hash messageLines `mod` 0x1000000+ let msgHash = T.pack $ printf "%06X" $ hash messageLines `mod` 0x1000000 messageLinesWithLineNum = let messageLineCount = Prelude.length messageLines- messageLineCountString = T.pack (show messageLineCount)- messageLineCountStringLen = T.length messageLineCountString+ messageLineCountString = packLogMsg (show messageLineCount) printLineNum i =- let i' = T.pack (show i)- padding = messageLineCountStringLen - T.length i'- in msgHash <> " line " <> T.replicate padding " " <> i' <> " of " <> messageLineCountString <> ": "- in Prelude.zipWith (<>) (printLineNum <$> [1 :: Int ..]) messageLines- traverse_ (logWithSeverity s) messageLinesWithLineNum----- | Issue a log statement for each item in the list prefixed with a line number and a message hash.------ When several concurrent processes issue log statements, multiline log statements are often--- interleaved.------ In order to make the logs easier to read, this function will count the items and calculate a unique--- hash and prefix each message, so a user can grep to get all the lines of an interleaved,--- multi-line log message.------ This function takes a list of 'String's as opposed to 'logMultiLine'.------ @since 0.30.0-logMultiLine'- :: forall e- . ( HasCallStack- , Member Logs e- )- => Severity- -> [String]- -> Eff e ()-logMultiLine' s = logMultiLine s . fmap pack-+ let !i' = packLogMsg (show i)+ in MkLogMsg msgHash <> packLogMsg ": " <> i' <> packLogMsg "/" <> messageLineCountString <> packLogMsg ": "+ in Prelude.zipWith (<>) (printLineNum <$> [1 :: Int ..]) messageLines+ traverse_ (sendLogEvent . set logEventSeverity s . infoMessage) messageLinesWithLineNum -- | Get the current 'Logs' filter/transformer function. -- -- See "Control.Eff.Log#LogPredicate"-askLogPredicate :: forall e . (Member Logs e) => Eff e LogPredicate+askLogPredicate :: forall e. (Member Logs e) => Eff e LogPredicate askLogPredicate = send @Logs AskLogFilter -- | Keep only those messages, for which a predicate holds.@@ -558,23 +465,23 @@ -- > exampleSetLogWriter = -- > runLift -- > $ withLogging consoleLogWriter--- > $ do logMsg "test"--- > setLogPredicate (\ msg -> case view lmMessage msg of+-- > $ do sendLogEvent "test"+-- > setLogPredicate (\ msg -> case view logEventMessage msg of -- > 'O':'M':'G':_ -> True -- > _ -> False)--- > (do logMsg "this message will not be logged"--- > logMsg "OMG logged"+-- > (do sendLogEvent "this message will not be logged"+-- > sendLogEvent "OMG logged" -- > return 42) -- -- In order to also delegate to the previous predicate, use 'modifyLogPredicate' -- -- See "Control.Eff.Log#LogPredicate"-setLogPredicate- :: forall r b- . (Member Logs r, HasCallStack)- => LogPredicate- -> Eff r b- -> Eff r b+setLogPredicate ::+ forall r b.+ (Member Logs r, HasCallStack) =>+ LogPredicate ->+ Eff r b ->+ Eff r b setLogPredicate = modifyLogPredicate . const -- | Change the 'LogPredicate'.@@ -585,66 +492,72 @@ -- that are to long: -- -- @--- modifyLogPredicate (\previousPredicate msg -> previousPredicate msg && length (lmMessage msg) < 29 )--- (do logMsg "this message will not be logged"--- logMsg "this message might be logged")+-- modifyLogPredicate (\previousPredicate msg -> previousPredicate msg && length (logEventMessage msg) < 29 )+-- (do sendLogEvent "this message will not be logged"+-- sendLogEvent "this message might be logged") -- @ -- -- See "Control.Eff.Log#LogPredicate"-modifyLogPredicate- :: forall e b- . (Member Logs e, HasCallStack)- => (LogPredicate -> LogPredicate)- -> Eff e b- -> Eff e b+modifyLogPredicate ::+ forall e b.+ (Member Logs e, HasCallStack) =>+ (LogPredicate -> LogPredicate) ->+ Eff e b ->+ Eff e b modifyLogPredicate lpIn e = askLogPredicate >>= fix step e . lpIn where ret x _ = return x- step :: (Eff e b -> LogPredicate -> Eff e b) -> Eff e b -> LogPredicate -> Eff e b+ step :: (Eff e b -> LogPredicate -> Eff e b) -> Eff e b -> LogPredicate -> Eff e b step k (E q (prj -> Just (WriteLogMessage !l))) lp = do- logMsg l+ sendLogEvent l respond_relay @Logs ret k (q ^$ ()) lp step k m lp = respond_relay @Logs ret k m lp --- | Include 'LogMessage's that match a 'LogPredicate'.+-- | Include 'LogEvent's that match a 'LogPredicate'. ----- @includeLogMessages p@ allows log message to be logged if @p m@+-- @whitelistLogEvents p@ allows log message to be logged if @p m@ -- -- Although it is enough if the previous predicate holds.--- See 'excludeLogMessages' and 'modifyLogPredicate'.+-- See 'blacklistLogEvents' and 'modifyLogPredicate'. -- -- See "Control.Eff.Log#LogPredicate"-includeLogMessages- :: forall e a . (Member Logs e)- => LogPredicate -> Eff e a -> Eff e a-includeLogMessages p = modifyLogPredicate (\p' m -> p' m || p m)+whitelistLogEvents ::+ forall e a.+ (Member Logs e) =>+ LogPredicate ->+ Eff e a ->+ Eff e a+whitelistLogEvents p = modifyLogPredicate (\p' m -> p' m || p m) --- | Exclude 'LogMessage's that match a 'LogPredicate'.+-- | Exclude 'LogEvent's that match a 'LogPredicate'. ----- @excludeLogMessages p@ discards logs if @p m@+-- @blacklistLogEvents p@ discards logs if @p m@ -- -- Also the previous predicate must also hold for a -- message to be logged.--- See 'excludeLogMessages' and 'modifyLogPredicate'.+-- See 'blacklistLogEvents' and 'modifyLogPredicate'. -- -- See "Control.Eff.Log#LogPredicate"-excludeLogMessages- :: forall e a . (Member Logs e)- => LogPredicate -> Eff e a -> Eff e a-excludeLogMessages p = modifyLogPredicate (\p' m -> not (p m) && p' m)+blacklistLogEvents ::+ forall e a.+ (Member Logs e) =>+ LogPredicate ->+ Eff e a ->+ Eff e a+blacklistLogEvents p = modifyLogPredicate (\p' m -> not (p m) && p' m) -- | Consume log messages. -- -- Exposed for custom extensions, if in doubt use 'withLogging'. ----- Respond to all 'LogMessage's logged from the given action,+-- Respond to all 'LogEvent's logged from the given action, -- up to any 'MonadBaseControl' liftings. ----- Note that all logging is done through 'logMsg' and that means+-- Note that all logging is done through 'sendLogEvent' and that means -- only messages passing the 'LogPredicate' are received. ----- The 'LogMessage's are __consumed__ once they are passed to the--- given callback function, previous 'respondToLogMessage' invocations+-- The 'LogEvent's are __consumed__ once they are passed to the+-- given callback function, previous 'respondToLogEvent' invocations -- further up in the call stack will not get the messages anymore. -- -- Use 'interceptLogMessages' if the messages shall be passed@@ -656,26 +569,26 @@ -- In contrast the functions based on modifying the 'LogWriter', -- such as 'addLogWriter' or 'censorLogs', are save to use in combination -- with the aforementioned liftings.-respondToLogMessage- :: forall r b- . (Member Logs r)- => (LogMessage -> Eff r ())- -> Eff r b- -> Eff r b-respondToLogMessage f e = askLogPredicate >>= fix step e+respondToLogEvent ::+ forall r b.+ (Member Logs r) =>+ (LogEvent -> Eff r ()) ->+ Eff r b ->+ Eff r b+respondToLogEvent f e = askLogPredicate >>= fix step e where- step :: (Eff r b -> LogPredicate -> Eff r b) -> Eff r b -> LogPredicate -> Eff r b+ step :: (Eff r b -> LogPredicate -> Eff r b) -> Eff r b -> LogPredicate -> Eff r b step k (E q (prj -> Just (WriteLogMessage !l))) lp = do f l respond_relay @Logs ret k (q ^$ ()) lp step k m lp = respond_relay @Logs ret k m lp ret x _lf = return x --- | Change the 'LogMessage's using an effectful function.+-- | Change the 'LogEvent's using an effectful function. -- -- Exposed for custom extensions, if in doubt use 'withLogging'. ----- This differs from 'respondToLogMessage' in that the intercepted messages will be+-- This differs from 'respondToLogEvent' in that the intercepted messages will be -- written either way, albeit in altered form. -- -- NOTE: The effects of this function are __lost__ when using@@ -684,17 +597,17 @@ -- In contrast the functions based on modifying the 'LogWriter', -- such as 'addLogWriter' or 'censorLogs', are save to use in combination -- with the aforementioned liftings.-interceptLogMessages- :: forall r b- . (Member Logs r)- => (LogMessage -> Eff r LogMessage)- -> Eff r b- -> Eff r b-interceptLogMessages f = respondToLogMessage (f >=> logMsg)+interceptLogMessages ::+ forall r b.+ (Member Logs r) =>+ (LogEvent -> Eff r LogEvent) ->+ Eff r b ->+ Eff r b+interceptLogMessages f = respondToLogEvent (f >=> sendLogEvent) -- | Internal function. sendLogMessageToLogWriter :: IoLogging e => Eff e b -> Eff e b-sendLogMessageToLogWriter = respondToLogMessage liftWriteLogMessage+sendLogMessageToLogWriter = respondToLogEvent liftWriteLogMessage -- | Change the current 'LogWriter'. modifyLogWriter :: IoLogging e => (LogWriter -> LogWriter) -> Eff e a -> Eff e a@@ -703,19 +616,19 @@ -- | Replace the current 'LogWriter'. -- To add an additional log message consumer use 'addLogWriter' setLogWriter :: IoLogging e => LogWriter -> Eff e a -> Eff e a-setLogWriter = modifyLogWriter . const+setLogWriter = modifyLogWriter . const --- | Modify the the 'LogMessage's written in the given sub-expression.+-- | Modify the the 'LogEvent's written in the given sub-expression. -- -- Note: This is equivalent to @'modifyLogWriter' . 'mappingLogWriter'@-censorLogs :: IoLogging e => (LogMessage -> LogMessage) -> Eff e a -> Eff e a+censorLogs :: IoLogging e => (LogEvent -> LogEvent) -> Eff e a -> Eff e a censorLogs = modifyLogWriter . mappingLogWriter --- | Modify the the 'LogMessage's written in the given sub-expression, as in 'censorLogs'+-- | Modify the the 'LogEvent's written in the given sub-expression, as in 'censorLogs' -- but with a effectful function. -- -- Note: This is equivalent to @'modifyLogWriter' . 'mappingLogWriterIO'@-censorLogsIo :: IoLogging e => (LogMessage -> IO LogMessage) -> Eff e a -> Eff e a+censorLogsIo :: IoLogging e => (LogEvent -> IO LogEvent) -> Eff e a -> Eff e a censorLogsIo = modifyLogWriter . mappingLogWriterIO -- | Combine the effects of a given 'LogWriter' and the existing one.@@ -725,12 +638,12 @@ -- > -- > exampleAddLogWriter :: IO () -- > exampleAddLogWriter = go >>= T.putStrLn--- > where go = fmap (unlines . map renderLogMessageConsoleLog . snd)+-- > where go = fmap (unlines . map renderLogEventConsoleLog . snd) -- > $ runLift -- > $ runCaptureLogWriter -- > $ withLogging captureLogWriter--- > $ addLogWriter (mappingLogWriter (lmMessage %~ ("CAPTURED "++)) captureLogWriter)--- > $ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("TRACED "++)) debugTraceLogWriter))+-- > $ addLogWriter (mappingLogWriter (logEventMessage %~ ("CAPTURED "++)) captureLogWriter)+-- > $ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (logEventMessage %~ ("TRACED "++)) debugTraceLogWriter)) -- > $ do -- > logEmergency "test emergencySeverity 1" -- > logCritical "test criticalSeverity 2"@@ -739,8 +652,7 @@ -- > logWarning "test warningSeverity 5" -- > logInfo "test informationalSeverity 6" -- > logDebug "test debugSeverity 7"--- > severeMessages = view (lmSeverity . to (<= errorSeverity))+-- > severeMessages = view (logEventSeverity . to (<= errorSeverity)) -- >--- addLogWriter :: IoLogging e => LogWriter -> Eff e a -> Eff e a addLogWriter lw2 = modifyLogWriter (\lw1 -> MkLogWriter (\m -> runLogWriter lw1 m >> runLogWriter lw2 m))
src/Control/Eff/Log/Message.hs view
@@ -1,595 +1,869 @@-{-# LANGUAGE QuantifiedConstraints #-}--- | An RFC 5434 inspired log message and convenience functions for--- logging them.-module Control.Eff.Log.Message- ( -- * Log Message Data Type- LogMessage(..)- -- ** Field Accessors- , lmFacility- , lmSeverity- , lmTimestamp- , lmHostname- , lmAppName- , lmProcessId- , lmMessageId- , lmStructuredData- , lmSrcLoc- , lmThreadId- , lmMessage-- -- *** IO Based 'LogMessage' Modification- , setCallStack- , prefixLogMessagesWith- , setLogMessageTimestamp- , setLogMessageThreadId- , setLogMessageHostname-- -- ** Log Message Construction- , errorMessage- , infoMessage- , debugMessage-- -- *** Type Class for Conversion to 'LogMessage'- , ToLogMessage(..)-- -- *** IO Based Constructor- , errorMessageIO- , infoMessageIO- , debugMessageIO-- -- * 'LogMessage' Predicates #PredefinedPredicates#- -- $PredefinedPredicates- , LogPredicate- , allLogMessages- , noLogMessages- , lmSeverityIs- , lmSeverityIsAtLeast- , lmMessageStartsWith- , discriminateByAppName-- -- ** RFC-5424 Structured Data- , StructuredDataElement(..)- , SdParameter(..)- , sdElementId- , sdElementParameters-- -- * RFC 5424 Severity- , Severity(fromSeverity)- , emergencySeverity- , alertSeverity- , criticalSeverity- , errorSeverity- , warningSeverity- , noticeSeverity- , informationalSeverity- , debugSeverity-- -- * RFC 5424 Facility- , Facility (..)- -- ** Facility Constructors- , kernelMessages- , userLevelMessages- , mailSystem- , systemDaemons- , securityAuthorizationMessages4- , linePrinterSubsystem- , networkNewsSubsystem- , uucpSubsystem- , clockDaemon- , securityAuthorizationMessages10- , ftpDaemon- , ntpSubsystem- , logAuditFacility- , logAlertFacility- , clockDaemon2- , local0- , local1- , local2- , local3- , local4- , local5- , local6- , local7- )-where--import Control.Concurrent-import Control.DeepSeq-import Control.Lens-import Control.Monad ( (>=>) )-import Control.Monad.IO.Class-import Data.Default-import Data.Maybe-import Data.String (IsString(..))-import qualified Data.Text as T-import Data.Time.Clock-import GHC.Generics hiding ( to )-import GHC.Stack-import Network.HostName as Network---- | A message data type inspired by the RFC-5424 Syslog Protocol-data LogMessage =- MkLogMessage { _lmFacility :: !Facility- , _lmSeverity :: !Severity- , _lmTimestamp :: (Maybe UTCTime)- , _lmHostname :: (Maybe T.Text)- , _lmAppName :: (Maybe T.Text)- , _lmProcessId :: (Maybe T.Text)- , _lmMessageId :: (Maybe T.Text)- , _lmStructuredData :: [StructuredDataElement]- , _lmThreadId :: (Maybe ThreadId)- , _lmSrcLoc :: (Maybe SrcLoc)- , _lmMessage :: T.Text}- deriving (Eq, Generic)--instance Default LogMessage where- def = MkLogMessage def def def def def def def def def def ""---- | This instance is __only__ supposed to be used for unit tests and debugging.-instance Show LogMessage where- show = T.unpack . _lmMessage--instance NFData LogMessage---- | RFC-5424 defines how structured data can be included in a log message.-data StructuredDataElement =- SdElement { _sdElementId :: !T.Text- , _sdElementParameters :: ![SdParameter]}- deriving (Eq, Ord, Generic, Show)--instance NFData StructuredDataElement---- | Component of an RFC-5424 'StructuredDataElement'-data SdParameter =- MkSdParameter !T.Text !T.Text- deriving (Eq, Ord, Generic, Show)--instance NFData SdParameter---- | An rfc 5424 severity-newtype Severity =- Severity {fromSeverity :: Int}- deriving (Eq, Ord, Generic, NFData)--instance Show Severity where- show (Severity 1) = "ALERT "- show (Severity 2) = "CRITICAL "- show (Severity 3) = "ERROR "- show (Severity 4) = "WARNING "- show (Severity 5) = "NOTICE "- show (Severity 6) = "INFO "- show (Severity x) | x <= 0 = "EMERGENCY"- | otherwise = "DEBUG "--- *** Severities---- | Smart constructor for the RFC-5424 __emergency__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __0__.--- See 'lmSeverity'.-emergencySeverity :: Severity-emergencySeverity = Severity 0---- | Smart constructor for the RFC-5424 __alert__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __1__.--- See 'lmSeverity'.-alertSeverity :: Severity-alertSeverity = Severity 1---- | Smart constructor for the RFC-5424 __critical__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __2__.--- See 'lmSeverity'.-criticalSeverity :: Severity-criticalSeverity = Severity 2---- | Smart constructor for the RFC-5424 __error__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __3__.--- See 'lmSeverity'.-errorSeverity :: Severity-errorSeverity = Severity 3---- | Smart constructor for the RFC-5424 __warning__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __4__.--- See 'lmSeverity'.-warningSeverity :: Severity-warningSeverity = Severity 4---- | Smart constructor for the RFC-5424 __notice__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __5__.--- See 'lmSeverity'.-noticeSeverity :: Severity-noticeSeverity = Severity 5---- | Smart constructor for the RFC-5424 __informational__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __6__.--- See 'lmSeverity'.-informationalSeverity :: Severity-informationalSeverity = Severity 6---- | Smart constructor for the RFC-5424 __debug__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __7__.--- See 'lmSeverity'.-debugSeverity :: Severity-debugSeverity = Severity 7--instance Default Severity where- def = debugSeverity----- | An rfc 5424 facility-newtype Facility = Facility {fromFacility :: Int}- deriving (Eq, Ord, Show, Generic, NFData)---- | Smart constructor for the RFC-5424 'LogMessage' facility @kernelMessages@.--- See 'lmFacility'.-kernelMessages :: Facility-kernelMessages = Facility 0---- | Smart constructor for the RFC-5424 'LogMessage' facility @userLevelMessages@.--- See 'lmFacility'.-userLevelMessages :: Facility-userLevelMessages = Facility 1---- | Smart constructor for the RFC-5424 'LogMessage' facility @mailSystem@.--- See 'lmFacility'.-mailSystem :: Facility-mailSystem = Facility 2---- | Smart constructor for the RFC-5424 'LogMessage' facility @systemDaemons@.--- See 'lmFacility'.-systemDaemons :: Facility-systemDaemons = Facility 3---- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages4@.--- See 'lmFacility'.-securityAuthorizationMessages4 :: Facility-securityAuthorizationMessages4 = Facility 4---- | Smart constructor for the RFC-5424 'LogMessage' facility @linePrinterSubsystem@.--- See 'lmFacility'.-linePrinterSubsystem :: Facility-linePrinterSubsystem = Facility 6---- | Smart constructor for the RFC-5424 'LogMessage' facility @networkNewsSubsystem@.--- See 'lmFacility'.-networkNewsSubsystem :: Facility-networkNewsSubsystem = Facility 7---- | Smart constructor for the RFC-5424 'LogMessage' facility @uucpSubsystem@.--- See 'lmFacility'.-uucpSubsystem :: Facility-uucpSubsystem = Facility 8---- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon@.--- See 'lmFacility'.-clockDaemon :: Facility-clockDaemon = Facility 9---- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages10@.--- See 'lmFacility'.-securityAuthorizationMessages10 :: Facility-securityAuthorizationMessages10 = Facility 10---- | Smart constructor for the RFC-5424 'LogMessage' facility @ftpDaemon@.--- See 'lmFacility'.-ftpDaemon :: Facility-ftpDaemon = Facility 11---- | Smart constructor for the RFC-5424 'LogMessage' facility @ntpSubsystem@.--- See 'lmFacility'.-ntpSubsystem :: Facility-ntpSubsystem = Facility 12---- | Smart constructor for the RFC-5424 'LogMessage' facility @logAuditFacility@.--- See 'lmFacility'.-logAuditFacility :: Facility-logAuditFacility = Facility 13---- | Smart constructor for the RFC-5424 'LogMessage' facility @logAlertFacility@.--- See 'lmFacility'.-logAlertFacility :: Facility-logAlertFacility = Facility 14---- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon2@.--- See 'lmFacility'.-clockDaemon2 :: Facility-clockDaemon2 = Facility 15---- | Smart constructor for the RFC-5424 'LogMessage' facility @local0@.--- See 'lmFacility'.-local0 :: Facility-local0 = Facility 16---- | Smart constructor for the RFC-5424 'LogMessage' facility @local1@.--- See 'lmFacility'.-local1 :: Facility-local1 = Facility 17---- | Smart constructor for the RFC-5424 'LogMessage' facility @local2@.--- See 'lmFacility'.-local2 :: Facility-local2 = Facility 18---- | Smart constructor for the RFC-5424 'LogMessage' facility @local3@.--- See 'lmFacility'.-local3 :: Facility-local3 = Facility 19---- | Smart constructor for the RFC-5424 'LogMessage' facility @local4@.--- See 'lmFacility'.-local4 :: Facility-local4 = Facility 20---- | Smart constructor for the RFC-5424 'LogMessage' facility @local5@.--- See 'lmFacility'.-local5 :: Facility-local5 = Facility 21---- | Smart constructor for the RFC-5424 'LogMessage' facility @local6@.--- See 'lmFacility'.-local6 :: Facility-local6 = Facility 22---- | Smart constructor for the RFC-5424 'LogMessage' facility @local7@.--- See 'lmFacility'.-local7 :: Facility-local7 = Facility 23--instance Default Facility where- def = local7--makeLensesWith (lensRules & generateSignatures .~ False) ''StructuredDataElement---- | A lens for 'SdParameter's-sdElementParameters- :: Functor f- => ([SdParameter] -> f [SdParameter])- -> StructuredDataElement- -> f StructuredDataElement---- | A lens for the key or ID of a group of RFC 5424 key-value pairs.-sdElementId- :: Functor f- => (T.Text -> f T.Text)- -> StructuredDataElement- -> f StructuredDataElement--makeLensesWith (lensRules & generateSignatures .~ False) ''LogMessage---- | A lens for the UTC time of a 'LogMessage'--- The function 'setLogMessageTimestamp' can be used to set the field.-lmTimestamp- :: Functor f- => (Maybe UTCTime -> f (Maybe UTCTime))- -> LogMessage- -> f LogMessage---- | A lens for the 'ThreadId' of a 'LogMessage'--- The function 'setLogMessageThreadId' can be used to set the field.-lmThreadId- :: Functor f- => (Maybe ThreadId -> f (Maybe ThreadId))- -> LogMessage- -> f LogMessage---- | A lens for the 'StructuredDataElement' of a 'LogMessage'-lmStructuredData- :: Functor f- => ([StructuredDataElement] -> f [StructuredDataElement])- -> LogMessage- -> f LogMessage---- | A lens for the 'SrcLoc' of a 'LogMessage'-lmSrcLoc- :: Functor f- => (Maybe SrcLoc -> f (Maybe SrcLoc))- -> LogMessage- -> f LogMessage---- | A lens for the 'Severity' of a 'LogMessage'-lmSeverity- :: Functor f => (Severity -> f Severity) -> LogMessage -> f LogMessage---- | A lens for a user defined of /process/ id of a 'LogMessage'-lmProcessId- :: Functor f- => (Maybe T.Text -> f (Maybe T.Text))- -> LogMessage- -> f LogMessage---- | A lens for a user defined /message id/ of a 'LogMessage'-lmMessageId- :: Functor f- => (Maybe T.Text -> f (Maybe T.Text))- -> LogMessage- -> f LogMessage---- | A lens for the user defined textual message of a 'LogMessage'-lmMessage :: Functor f => (T.Text -> f T.Text) -> LogMessage -> f LogMessage---- | A lens for the hostname of a 'LogMessage'--- The function 'setLogMessageHostname' can be used to set the field.-lmHostname- :: Functor f- => (Maybe T.Text -> f (Maybe T.Text))- -> LogMessage- -> f LogMessage---- | A lens for the 'Facility' of a 'LogMessage'-lmFacility- :: Functor f => (Facility -> f Facility) -> LogMessage -> f LogMessage---- | A lens for the RFC 5424 /application/ name of a 'LogMessage'------ One useful pattern for using this field, is to implement log filters that allow--- info and debug message from the application itself while only allowing warning and error--- messages from third party libraries:------ > debugLogsForAppName myAppName lm =--- > view lmAppName lm == Just myAppName || lmSeverityIsAtLeast warningSeverity lm------ This concept is also implemented in 'discriminateByAppName'.-lmAppName- :: Functor f- => (Maybe T.Text -> f (Maybe T.Text))- -> LogMessage- -> f LogMessage---- | Put the source location of the given callstack in 'lmSrcLoc'-setCallStack :: CallStack -> LogMessage -> LogMessage-setCallStack cs m = case getCallStack cs of- [] -> m- (_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc---- | Prefix the 'lmMessage'.-prefixLogMessagesWith :: T.Text -> LogMessage -> LogMessage-prefixLogMessagesWith = over lmMessage . (<>)---- | An IO action that sets the current UTC time in 'lmTimestamp'.-setLogMessageTimestamp :: LogMessage -> IO LogMessage-setLogMessageTimestamp m = if isNothing (m ^. lmTimestamp)- then do- now <- getCurrentTime- return (m & lmTimestamp ?~ now)- else return m---- | An IO action appends the the 'ThreadId' of the calling process (see 'myThreadId')--- to 'lmMessage'.-setLogMessageThreadId :: LogMessage -> IO LogMessage-setLogMessageThreadId m = if isNothing (m ^. lmThreadId)- then do- t <- myThreadId- return (m & lmThreadId ?~ t)- else return m---- | An IO action that sets the current hosts fully qualified hostname in 'lmHostname'.-setLogMessageHostname :: LogMessage -> IO LogMessage-setLogMessageHostname m = if isNothing (m ^. lmHostname)- then do- fqdn <- Network.getHostName- return (m & lmHostname ?~ T.pack fqdn)- else return m---- | Construct a 'LogMessage' with 'errorSeverity'-errorMessage :: HasCallStack => T.Text -> LogMessage-errorMessage m = withFrozenCallStack- (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack)---- | Construct a 'LogMessage' with 'informationalSeverity'-infoMessage :: HasCallStack => T.Text -> LogMessage-infoMessage m = withFrozenCallStack- ( def- & lmSeverity- .~ informationalSeverity- & lmMessage- .~ m- & setCallStack callStack- )---- | Construct a 'LogMessage' with 'debugSeverity'-debugMessage :: HasCallStack => T.Text -> LogMessage-debugMessage m = withFrozenCallStack- (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack)---- | Construct a 'LogMessage' with 'errorSeverity'-errorMessageIO :: (HasCallStack, MonadIO m) => T.Text -> m LogMessage-errorMessageIO =- withFrozenCallStack- $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)- . errorMessage---- | Construct a 'LogMessage' with 'informationalSeverity'-infoMessageIO :: (HasCallStack, MonadIO m) => T.Text -> m LogMessage-infoMessageIO =- withFrozenCallStack- $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)- . infoMessage---- | Construct a 'LogMessage' with 'debugSeverity'-debugMessageIO :: (HasCallStack, MonadIO m) => T.Text -> m LogMessage-debugMessageIO =- withFrozenCallStack- $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)- . debugMessage---- | Things that can become a 'LogMessage'-class ToLogMessage a where- -- | Convert the value to a 'LogMessage'- toLogMessage :: a -> LogMessage--instance ToLogMessage LogMessage where- toLogMessage = id--instance ToLogMessage T.Text where- toLogMessage = infoMessage--instance IsString LogMessage where- fromString = infoMessage . T.pack---- $PredefinedPredicates--- == Log Message Predicates------ These are the predefined 'LogPredicate's:------ * 'allLogMessages'--- * 'noLogMessages'--- * 'lmSeverityIsAtLeast'--- * 'lmSeverityIs'--- * 'lmMessageStartsWith'--- * 'discriminateByAppName'------ To find out how to use these predicates,--- goto "Control.Eff.Log#LogPredicate"----- | The filter predicate for message that shall be logged.------ See "Control.Eff.Log#LogPredicate"-type LogPredicate = LogMessage -> Bool---- | All messages.------ See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.-allLogMessages :: LogPredicate-allLogMessages = const True---- | No messages.------ See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.-noLogMessages :: LogPredicate-noLogMessages = const False---- | Match 'LogMessage's that have exactly the given severity.--- See 'lmSeverityIsAtLeast'.------ See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.-lmSeverityIs :: Severity -> LogPredicate-lmSeverityIs s = view (lmSeverity . to (== s))---- | Match 'LogMessage's that have the given severity __or worse__.--- See 'lmSeverityIs'.------ See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.-lmSeverityIsAtLeast :: Severity -> LogPredicate-lmSeverityIsAtLeast s = view (lmSeverity . to (<= s))---- | Match 'LogMessage's whose 'lmMessage' starts with the given string.------ See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.-lmMessageStartsWith :: T.Text -> LogPredicate-lmMessageStartsWith prefix lm = case T.length prefix of- 0 -> True- prefixLen -> T.take prefixLen (lm ^. lmMessage) == prefix---- | Apply a 'LogPredicate' based on the 'lmAppName' and delegate--- to one of two 'LogPredicate's.------ One useful application for this is to allow info and debug message--- from one application, e.g. the current application itself,--- while at the same time allowing only warning and error messages--- from third party libraries.------ See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.-discriminateByAppName :: T.Text -> LogPredicate -> LogPredicate -> LogPredicate-discriminateByAppName appName appPredicate otherPredicate lm =- if view lmAppName lm == Just appName+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeApplications #-}++-- | This modules contains RFC 5434 inspired logging data types for log events.+module Control.Eff.Log.Message+ ( -- * Log Event Data Type+ LogEvent (..),++ -- ** Field Accessors+ logEventFacility,+ logEventSeverity,+ logEventTimestamp,+ logEventHostname,+ logEventAppName,+ logEventProcessId,+ logEventMessageId,+ logEventStructuredData,+ logEventSrcLoc,+ logEventThreadId,+ logEventMessage,++ -- *** IO Based 'LogEvent' Modification+ setCallStack,+ prefixLogEventsWith,+ setLogEventsTimestamp,+ setLogEventsThreadId,+ setLogEventsHostname,++ -- ** Log Event Construction+ errorMessage,+ infoMessage,+ debugMessage,++ -- *** Log Message Texts+ LogMsg (..),+ fromLogMsg,+ ToLogMsg (..),+ packLogMsg,+ ToTypeLogMsg (..),+ StringLogMsg (..),+ AsLogMsg (..),+ showAsLogMsg,+ LabelMsg (..),+ SpaceMsg (..),+ spaceMsg,+ SeparatorMsg (..),+ separatorMsg,+ Returns,+ LogMsgAppender (..),+ concatMsgs,+ concatMsgsWith,+ spaced,+ separated,+ InBrackets (..),+ inBrackets,++ -- * 'LogEvent' Predicates #PredefinedPredicates#+ -- $PredefinedPredicates+ LogPredicate,+ allLogEvents,+ noLogEvents,+ logEventSeverityIs,+ logEventSeverityIsAtLeast,+ logEventMessageStartsWith,+ discriminateByAppName,++ -- ** RFC-5424 Structured Data+ StructuredDataElement (..),+ SdParameter (..),+ sdElementId,+ sdElementParameters,++ -- * RFC 5424 Severity+ Severity (fromSeverity),+ severityToText,+ emergencySeverity,+ alertSeverity,+ criticalSeverity,+ errorSeverity,+ warningSeverity,+ noticeSeverity,+ informationalSeverity,+ debugSeverity,++ -- * RFC 5424 Facility+ Facility (..),++ -- ** Facility Constructors+ kernelMessages,+ userLevelMessages,+ mailSystem,+ systemDaemons,+ securityAuthorizationMessages4,+ linePrinterSubsystem,+ networkNewsSubsystem,+ uucpSubsystem,+ clockDaemon,+ securityAuthorizationMessages10,+ ftpDaemon,+ ntpSubsystem,+ logAuditFacility,+ logAlertFacility,+ clockDaemon2,+ local0,+ local1,+ local2,+ local3,+ local4,+ local5,+ local6,+ local7,+ )+where++import Control.Concurrent+import Control.DeepSeq+import Control.Lens+import Data.Default+import Data.Function (on)+import Data.Hashable+import Data.Kind (Constraint)+import Data.Maybe+import Data.String+import qualified Data.Text as T+import Data.Time.Clock+import Data.Typeable+import Data.Void+import GHC.Generics hiding (to)+import GHC.Stack+import Network.HostName as Network++-- | A data type describing a complete logging event, usually consisting of+-- e.g. a log message, a timestamp and a severity.+-- The fields are modelled to ressamble all fields mentioned for the+-- RFC-5424 Syslog Protocol.+data LogEvent = MkLogEvent+ { _logEventFacility :: !Facility,+ _logEventSeverity :: !Severity,+ _logEventTimestamp :: (Maybe UTCTime),+ _logEventHostname :: (Maybe T.Text),+ _logEventAppName :: (Maybe T.Text),+ _logEventProcessId :: (Maybe T.Text),+ _logEventMessageId :: (Maybe T.Text),+ _logEventStructuredData :: [StructuredDataElement],+ _logEventThreadId :: (Maybe ThreadId),+ _logEventSrcLoc :: (Maybe SrcLoc),+ _logEventMessage :: LogMsg+ }+ deriving (Eq, Generic)++instance Default LogEvent where+ def = MkLogEvent def def def def def def def def def def (packLogMsg "")++-- | This instance is __only__ supposed to be used for unit tests and debugging.+instance Show LogEvent where+ show = T.unpack . _fromLogMsg . _logEventMessage++instance NFData LogEvent++-- | The main, human readable, log message text.+--+-- A newtype wrapper around 'T.Text'.+--+-- @since 1.0.0+newtype LogMsg = MkLogMsg {_fromLogMsg :: T.Text}+ deriving (Eq, Ord, NFData, Generic, Semigroup, Monoid, Hashable, IsString)++instance Show LogMsg where+ show (MkLogMsg x) = T.unpack x++-- | Convert a 'String' to a 'LogMsg'.+--+-- This function delegates the work to 'fromString'+--+-- @since 1.0.0+packLogMsg :: String -> LogMsg+packLogMsg = fromString++-- | RFC-5424 defines how structured data can be included in a log message.+data StructuredDataElement = SdElement+ { _sdElementId :: !T.Text,+ _sdElementParameters :: ![SdParameter]+ }+ deriving (Eq, Ord, Generic, Show)++instance NFData StructuredDataElement++-- | Component of an RFC-5424 'StructuredDataElement'+data SdParameter+ = MkSdParameter !T.Text !T.Text+ deriving (Eq, Ord, Generic, Show)++instance NFData SdParameter++-- | An rfc 5424 severity+newtype Severity = Severity {fromSeverity :: Int}+ deriving (Eq, Ord, Generic, NFData)++-- | Convert a 'Severity' to 'T.Text'+--+-- @since 1.0.0+severityToText :: Severity -> T.Text+severityToText (Severity 1) = T.pack "ALERT "+severityToText (Severity 2) = T.pack "CRITICAL "+severityToText (Severity 3) = T.pack "ERROR "+severityToText (Severity 4) = T.pack "WARNING "+severityToText (Severity 5) = T.pack "NOTICE "+severityToText (Severity 6) = T.pack "INFO "+severityToText (Severity x)+ | x <= 0 = T.pack "EMERGENCY"+ | otherwise = T.pack "DEBUG "++-- *** Severities++-- | Smart constructor for the RFC-5424 __emergency__ 'LogEvent' 'Severity'.+-- This corresponds to the severity value __0__.+-- See 'logEventSeverity'.+emergencySeverity :: Severity+emergencySeverity = Severity 0++-- | Smart constructor for the RFC-5424 __alert__ 'LogEvent' 'Severity'.+-- This corresponds to the severity value __1__.+-- See 'logEventSeverity'.+alertSeverity :: Severity+alertSeverity = Severity 1++-- | Smart constructor for the RFC-5424 __critical__ 'LogEvent' 'Severity'.+-- This corresponds to the severity value __2__.+-- See 'logEventSeverity'.+criticalSeverity :: Severity+criticalSeverity = Severity 2++-- | Smart constructor for the RFC-5424 __error__ 'LogEvent' 'Severity'.+-- This corresponds to the severity value __3__.+-- See 'logEventSeverity'.+errorSeverity :: Severity+errorSeverity = Severity 3++-- | Smart constructor for the RFC-5424 __warning__ 'LogEvent' 'Severity'.+-- This corresponds to the severity value __4__.+-- See 'logEventSeverity'.+warningSeverity :: Severity+warningSeverity = Severity 4++-- | Smart constructor for the RFC-5424 __notice__ 'LogEvent' 'Severity'.+-- This corresponds to the severity value __5__.+-- See 'logEventSeverity'.+noticeSeverity :: Severity+noticeSeverity = Severity 5++-- | Smart constructor for the RFC-5424 __informational__ 'LogEvent' 'Severity'.+-- This corresponds to the severity value __6__.+-- See 'logEventSeverity'.+informationalSeverity :: Severity+informationalSeverity = Severity 6++-- | Smart constructor for the RFC-5424 __debug__ 'LogEvent' 'Severity'.+-- This corresponds to the severity value __7__.+-- See 'logEventSeverity'.+debugSeverity :: Severity+debugSeverity = Severity 7++instance Default Severity where+ def = debugSeverity++-- | An rfc 5424 facility+newtype Facility = Facility {fromFacility :: Int}+ deriving (Eq, Ord, Show, Generic, NFData)++-- | Smart constructor for the RFC-5424 'LogEvent' facility @kernelMessages@.+-- See 'logEventFacility'.+kernelMessages :: Facility+kernelMessages = Facility 0++-- | Smart constructor for the RFC-5424 'LogEvent' facility @userLevelMessages@.+-- See 'logEventFacility'.+userLevelMessages :: Facility+userLevelMessages = Facility 1++-- | Smart constructor for the RFC-5424 'LogEvent' facility @mailSystem@.+-- See 'logEventFacility'.+mailSystem :: Facility+mailSystem = Facility 2++-- | Smart constructor for the RFC-5424 'LogEvent' facility @systemDaemons@.+-- See 'logEventFacility'.+systemDaemons :: Facility+systemDaemons = Facility 3++-- | Smart constructor for the RFC-5424 'LogEvent' facility @securityAuthorizationMessages4@.+-- See 'logEventFacility'.+securityAuthorizationMessages4 :: Facility+securityAuthorizationMessages4 = Facility 4++-- | Smart constructor for the RFC-5424 'LogEvent' facility @linePrinterSubsystem@.+-- See 'logEventFacility'.+linePrinterSubsystem :: Facility+linePrinterSubsystem = Facility 6++-- | Smart constructor for the RFC-5424 'LogEvent' facility @networkNewsSubsystem@.+-- See 'logEventFacility'.+networkNewsSubsystem :: Facility+networkNewsSubsystem = Facility 7++-- | Smart constructor for the RFC-5424 'LogEvent' facility @uucpSubsystem@.+-- See 'logEventFacility'.+uucpSubsystem :: Facility+uucpSubsystem = Facility 8++-- | Smart constructor for the RFC-5424 'LogEvent' facility @clockDaemon@.+-- See 'logEventFacility'.+clockDaemon :: Facility+clockDaemon = Facility 9++-- | Smart constructor for the RFC-5424 'LogEvent' facility @securityAuthorizationMessages10@.+-- See 'logEventFacility'.+securityAuthorizationMessages10 :: Facility+securityAuthorizationMessages10 = Facility 10++-- | Smart constructor for the RFC-5424 'LogEvent' facility @ftpDaemon@.+-- See 'logEventFacility'.+ftpDaemon :: Facility+ftpDaemon = Facility 11++-- | Smart constructor for the RFC-5424 'LogEvent' facility @ntpSubsystem@.+-- See 'logEventFacility'.+ntpSubsystem :: Facility+ntpSubsystem = Facility 12++-- | Smart constructor for the RFC-5424 'LogEvent' facility @logAuditFacility@.+-- See 'logEventFacility'.+logAuditFacility :: Facility+logAuditFacility = Facility 13++-- | Smart constructor for the RFC-5424 'LogEvent' facility @logAlertFacility@.+-- See 'logEventFacility'.+logAlertFacility :: Facility+logAlertFacility = Facility 14++-- | Smart constructor for the RFC-5424 'LogEvent' facility @clockDaemon2@.+-- See 'logEventFacility'.+clockDaemon2 :: Facility+clockDaemon2 = Facility 15++-- | Smart constructor for the RFC-5424 'LogEvent' facility @local0@.+-- See 'logEventFacility'.+local0 :: Facility+local0 = Facility 16++-- | Smart constructor for the RFC-5424 'LogEvent' facility @local1@.+-- See 'logEventFacility'.+local1 :: Facility+local1 = Facility 17++-- | Smart constructor for the RFC-5424 'LogEvent' facility @local2@.+-- See 'logEventFacility'.+local2 :: Facility+local2 = Facility 18++-- | Smart constructor for the RFC-5424 'LogEvent' facility @local3@.+-- See 'logEventFacility'.+local3 :: Facility+local3 = Facility 19++-- | Smart constructor for the RFC-5424 'LogEvent' facility @local4@.+-- See 'logEventFacility'.+local4 :: Facility+local4 = Facility 20++-- | Smart constructor for the RFC-5424 'LogEvent' facility @local5@.+-- See 'logEventFacility'.+local5 :: Facility+local5 = Facility 21++-- | Smart constructor for the RFC-5424 'LogEvent' facility @local6@.+-- See 'logEventFacility'.+local6 :: Facility+local6 = Facility 22++-- | Smart constructor for the RFC-5424 'LogEvent' facility @local7@.+-- See 'logEventFacility'.+local7 :: Facility+local7 = Facility 23++instance Default Facility where+ def = local7++makeLensesWith (lensRules & generateSignatures .~ False) ''StructuredDataElement++-- | A lens for 'SdParameter's+sdElementParameters ::+ Functor f =>+ ([SdParameter] -> f [SdParameter]) ->+ StructuredDataElement ->+ f StructuredDataElement++-- | A lens for the key or ID of a group of RFC 5424 key-value pairs.+sdElementId ::+ Functor f =>+ (T.Text -> f T.Text) ->+ StructuredDataElement ->+ f StructuredDataElement++makeLensesWith (lensRules & generateSignatures .~ False) ''LogEvent++-- | A lens for the UTC time of a 'LogEvent'+-- The function 'setLogEventsTimestamp' can be used to set the field.+logEventTimestamp ::+ Functor f =>+ (Maybe UTCTime -> f (Maybe UTCTime)) ->+ LogEvent ->+ f LogEvent++-- | A lens for the 'ThreadId' of a 'LogEvent'+-- The function 'setLogEventsThreadId' can be used to set the field.+logEventThreadId ::+ Functor f =>+ (Maybe ThreadId -> f (Maybe ThreadId)) ->+ LogEvent ->+ f LogEvent++-- | A lens for the 'StructuredDataElement' of a 'LogEvent'+logEventStructuredData ::+ Functor f =>+ ([StructuredDataElement] -> f [StructuredDataElement]) ->+ LogEvent ->+ f LogEvent++-- | A lens for the 'SrcLoc' of a 'LogEvent'+logEventSrcLoc ::+ Functor f =>+ (Maybe SrcLoc -> f (Maybe SrcLoc)) ->+ LogEvent ->+ f LogEvent++-- | A lens for the 'Severity' of a 'LogEvent'+logEventSeverity ::+ Functor f => (Severity -> f Severity) -> LogEvent -> f LogEvent++-- | A lens for a user defined of /process/ id of a 'LogEvent'+logEventProcessId ::+ Functor f =>+ (Maybe T.Text -> f (Maybe T.Text)) ->+ LogEvent ->+ f LogEvent++-- | A lens for a user defined /message id/ of a 'LogEvent'+logEventMessageId ::+ Functor f =>+ (Maybe T.Text -> f (Maybe T.Text)) ->+ LogEvent ->+ f LogEvent++-- | A lens for the user defined textual message of a 'LogEvent'+logEventMessage :: Functor f => (LogMsg -> f LogMsg) -> LogEvent -> f LogEvent++-- | A lens for the hostname of a 'LogEvent'+-- The function 'setLogEventsHostname' can be used to set the field.+logEventHostname ::+ Functor f =>+ (Maybe T.Text -> f (Maybe T.Text)) ->+ LogEvent ->+ f LogEvent++-- | A lens for the 'Facility' of a 'LogEvent'+logEventFacility ::+ Functor f => (Facility -> f Facility) -> LogEvent -> f LogEvent++-- | A lens for the RFC 5424 /application/ name of a 'LogEvent'+--+-- One useful pattern for using this field, is to implement log filters that allow+-- info and debug message from the application itself while only allowing warning and error+-- messages from third party libraries:+--+-- > debugLogsForAppName myAppName lm =+-- > view logEventAppName lm == Just myAppName || logEventSeverityIsAtLeast warningSeverity lm+--+-- This concept is also implemented in 'discriminateByAppName'.+logEventAppName ::+ Functor f =>+ (Maybe T.Text -> f (Maybe T.Text)) ->+ LogEvent ->+ f LogEvent++-- | Put the source location of the given callstack in 'logEventSrcLoc'+setCallStack :: CallStack -> LogEvent -> LogEvent+setCallStack cs m = case getCallStack cs of+ [] -> m+ (_, srcLoc) : _ -> m & logEventSrcLoc ?~ srcLoc++-- | An IO action that sets the current UTC time in 'logEventTimestamp'.+setLogEventsTimestamp :: LogEvent -> IO LogEvent+setLogEventsTimestamp m =+ if isNothing (m ^. logEventTimestamp)+ then do+ now <- getCurrentTime+ return (m & logEventTimestamp ?~ now)+ else return m++-- | An IO action appends the the 'ThreadId' of the calling process (see 'myThreadId')+-- to 'logEventMessage'.+setLogEventsThreadId :: LogEvent -> IO LogEvent+setLogEventsThreadId m =+ if isNothing (m ^. logEventThreadId)+ then do+ t <- myThreadId+ return (m & logEventThreadId ?~ t)+ else return m++-- | An IO action that sets the current hosts fully qualified hostname in 'logEventHostname'.+setLogEventsHostname :: LogEvent -> IO LogEvent+setLogEventsHostname m =+ if isNothing (m ^. logEventHostname)+ then do+ fqdn <- Network.getHostName+ return (m & logEventHostname ?~ T.pack fqdn)+ else return m++makeLensesWith (lensRules & generateSignatures .~ False) ''LogMsg++-- | A lens (iso) to access the 'T.Text' of a 'LogMsg'.+--+-- @since 1.0.0+fromLogMsg :: Iso' LogMsg T.Text++-- | A type class to convert a type to a log message+--+-- @since 1.0.0+class ToLogMsg a where+ toLogMsg :: a -> LogMsg+ default toLogMsg :: Show a => a -> LogMsg+ toLogMsg = packLogMsg . show++instance ToLogMsg String where+ toLogMsg = packLogMsg++instance ToLogMsg T.Text where+ toLogMsg = MkLogMsg++instance ToLogMsg ()++instance ToLogMsg Bool++instance ToLogMsg Char++instance ToLogMsg Int++instance ToLogMsg Double++instance ToLogMsg Float++instance ToLogMsg Integer++instance ToLogMsg LogMsg where+ toLogMsg = id++instance ToLogMsg a => ToLogMsg (Maybe a) where+ toLogMsg Nothing = mempty+ toLogMsg (Just b) = toLogMsg b++instance (ToLogMsg a, ToLogMsg b) => ToLogMsg (Either a b) where+ toLogMsg (Left a) = toLogMsg a+ toLogMsg (Right b) = toLogMsg b++instance (ToLogMsg a, ToLogMsg b) => ToLogMsg (a, b) where+ toLogMsg (a, b) = concatMsgs (inBrackets a) SPC (inBrackets b)++instance (ToLogMsg a, ToLogMsg b, ToLogMsg c) => ToLogMsg (a, b, c) where+ toLogMsg (a, b, c) =+ concatMsgs (inBrackets a) SPC (inBrackets b) SPC (inBrackets c)++instance (ToLogMsg a, ToLogMsg b, ToLogMsg c, ToLogMsg d) => ToLogMsg (a, b, c, d) where+ toLogMsg (a, b, c, d) =+ concatMsgs (inBrackets a) SPC (inBrackets b) SPC (inBrackets c) SPC (inBrackets d)++-- | A 'LogMsg' in brackets, i.e. @"(" <> logMsg <> ")"@.+--+-- @since 1.0.0+inBrackets :: ToLogMsg a => a -> InBrackets+inBrackets = InBrackets . toLogMsg++-- | A 'LogMsg' in brackets, i.e. @"(" <> logMsg <> ")"@.+newtype InBrackets = InBrackets LogMsg++instance ToLogMsg InBrackets where+ toLogMsg (InBrackets x) = concatMsgs (MSG "(") x (MSG ")")++-- | Concatenate several values to a single 'LogMsg' separated by the given 'LogMsg'.+--+-- @since 1.0.0+concatMsgsWith :: (LogMsgAppender a) => LogMsg -> a+concatMsgsWith sep = appendLogMsg sep mempty++-- | Concatenate several values to a single 'LogMsg'.+--+-- @since 1.0.0+concatMsgs :: (LogMsgAppender a) => a+concatMsgs = concatMsgsWith mempty++-- | Concatenate several values to a single 'LogMsg' separated by 'separatorMsg'.+--+-- @since 1.0.0+separated :: (LogMsgAppender a) => a+separated = concatMsgsWith separatorMsg++-- | Concatenate several values to a single 'LogMsg' separated by 'spaceMsg'.+--+-- @since 1.0.0+spaced :: (LogMsgAppender a) => a+spaced = concatMsgsWith spaceMsg++-- | Helper type class for 'concatMsgs'.+--+-- @since 1.0.0+class LogMsgAppender a where+ -- | Append to a log message using a seperator+ appendLogMsg :: LogMsg -> LogMsg -> a++instance LogMsgAppender LogMsg where+ appendLogMsg = const id++instance (ToLogMsg a, LogMsgAppender b) => LogMsgAppender (a -> b) where+ appendLogMsg sep lm a =+ appendLogMsg sep $+ let prefix = if lm == mempty then mempty else lm <> sep+ suffix = toLogMsg a+ in prefix <> suffix++-- | Internal helper for running 'LogMsgAppender's.+--+-- @since 1.0.0+type family Returns x a :: Constraint where+ Returns x (a -> b) = Returns x b+ Returns x x = ()++-- | The 'LogMsg' that **SHOULD** be used to concatenate+-- the distinct parts of a composed 'LogMsg': @"; "@+--+-- See 'SeparatorMsg'.+--+-- @since 1.0.0+separatorMsg :: LogMsg+separatorMsg = packLogMsg "; "++-- | The 'LogMsg' that **SHOULD** be used to concatenate+-- the distinct parts of a composed 'LogMsg'.+--+-- See 'separatorMsg'.+--+-- @since 1.0.0+data SeparatorMsg = SEP++-- | Render a @SeparatorMsg@ to @separatorMsg@+--+-- @since 1.0.0+instance ToLogMsg SeparatorMsg where+ toLogMsg SEP = separatorMsg++-- | A 'LogMsg' that is just a single space character.+--+-- @since 1.0.0+spaceMsg :: LogMsg+spaceMsg = packLogMsg " "++-- | A 'LogMsg' that is just a single space character.+--+-- @since 1.0.0+data SpaceMsg = SPC++-- | Render @SpaceMsg@ to @" "@+--+-- @since 1.0.0+instance ToLogMsg SpaceMsg where+ toLogMsg SPC = spaceMsg++-- | A 'String'-labelled 'LogMsg'.+--+-- @since 1.0.0+data LabelMsg a = LABEL String !a++-- | Render @LABEL "label" "value"@ to @"label: value"@+--+-- @since 1.0.0+instance ToLogMsg a => ToLogMsg (LabelMsg a) where+ toLogMsg (LABEL l v) = packLogMsg l <> packLogMsg ": " <> toLogMsg v++-- | A class for 'LogMsg' values for phantom types, like+-- those used to discern 'Pdu's.+--+-- Instead of a value, a proxy is used to form the log message,+-- which is why the log message generated for instances of this+-- class describe the given type.+--+-- @since 1.0.0+class ToTypeLogMsg (a :: k) where+ -- | Generate a 'LogMsg' for the given proxy value.+ toTypeLogMsg :: proxy a -> LogMsg++instance ToTypeLogMsg () where+ toTypeLogMsg _ = "()"++instance ToTypeLogMsg Bool where+ toTypeLogMsg _ = "Bool"++instance ToTypeLogMsg Int where+ toTypeLogMsg _ = "Int"++instance ToTypeLogMsg Double where+ toTypeLogMsg _ = "Double"++instance ToTypeLogMsg Float where+ toTypeLogMsg _ = "Float"++instance ToTypeLogMsg Integer where+ toTypeLogMsg _ = "Integer"++instance ToTypeLogMsg Void where+ toTypeLogMsg _ = packLogMsg "Void"++instance ToTypeLogMsg String where+ toTypeLogMsg _ = packLogMsg "String"++instance ToTypeLogMsg LogMsg where+ toTypeLogMsg _ = packLogMsg "LogMsg"++instance ToTypeLogMsg a => ToTypeLogMsg (Maybe a) where+ toTypeLogMsg _ = packLogMsg "[" <> toTypeLogMsg (Proxy @a) <> packLogMsg "]"++instance (ToTypeLogMsg a, ToTypeLogMsg b) => ToTypeLogMsg (Either a b) where+ toTypeLogMsg _ =+ packLogMsg "("+ <> toTypeLogMsg (Proxy @a)+ <> packLogMsg "|"+ <> toTypeLogMsg (Proxy @b)+ <> packLogMsg ")"++instance (ToTypeLogMsg a, ToTypeLogMsg b) => ToTypeLogMsg (a, b) where+ toTypeLogMsg _ = packLogMsg "(" <> toTypeLogMsg (Proxy @a) <> packLogMsg "," <> toTypeLogMsg (Proxy @b) <> packLogMsg ")"++instance (ToTypeLogMsg a, ToTypeLogMsg b, ToTypeLogMsg c) => ToTypeLogMsg (a, b, c) where+ toTypeLogMsg _ =+ packLogMsg "(" <> toTypeLogMsg (Proxy @a) <> packLogMsg ", " <> toTypeLogMsg (Proxy @b) <> packLogMsg ", " <> toTypeLogMsg (Proxy @c) <> packLogMsg ")"++-- | A 'String' wrapper needed in situations where @OverloadedStrings@ causes+-- ambiguous types, namely in conjunction with 'ToLogMsg'.+--+-- @since 1.0.0+newtype StringLogMsg = MSG {fromStringLogMsg :: String} deriving (NFData, Eq, Ord, Show, ToLogMsg, Typeable)++instance ToTypeLogMsg StringLogMsg where+ toTypeLogMsg _ = packLogMsg "StringLogMsg"++-- | Render a value to 'String'.+--+-- Render the value to a 'LogMsg' using the 'ToLogMsg' instance.+-- See 'AsLogMsg'.+--+-- @since 1.0.0+showAsLogMsg :: ToLogMsg a => a -> String+showAsLogMsg = show . AsLogMsg++-- | A wrapper for 'Show', 'Eq' and 'Ord' based on a 'LogMsg' of a value.+--+-- 'Eq', 'Show' and 'Ord' are implemented via the+-- 'LogMsg' obtained from the 'ToLogMsg' for a type.+--+-- @since 1.0.0+newtype AsLogMsg a = AsLogMsg {notAsLogMsg :: a}+ deriving (Typeable, NFData)++instance ToTypeLogMsg a => ToTypeLogMsg (AsLogMsg a) where+ toTypeLogMsg _ = toTypeLogMsg (Proxy @a)++instance ToLogMsg a => Eq (AsLogMsg a) where+ (==) = (==) `on` toLogMsg++instance ToLogMsg a => Ord (AsLogMsg a) where+ compare = compare `on` toLogMsg++instance ToLogMsg a => Show (AsLogMsg a) where+ show = show . toLogMsg . notAsLogMsg++instance ToLogMsg a => ToLogMsg (AsLogMsg a) where+ toLogMsg = toLogMsg . notAsLogMsg++-- | Prefix the 'logEventMessage'.+prefixLogEventsWith :: ToLogMsg a => a -> LogEvent -> LogEvent+prefixLogEventsWith = over logEventMessage . (<>) . toLogMsg++-- | Construct a 'LogEvent' with 'errorSeverity'+errorMessage :: (HasCallStack, ToLogMsg a) => a -> LogEvent+errorMessage m =+ withFrozenCallStack+ (def & logEventSeverity .~ errorSeverity & logEventMessage .~ toLogMsg m & setCallStack callStack)++-- | Construct a 'LogEvent' with 'informationalSeverity'+infoMessage :: (HasCallStack, ToLogMsg a) => a -> LogEvent+infoMessage m =+ withFrozenCallStack+ ( def+ & logEventSeverity+ .~ informationalSeverity+ & logEventMessage+ .~ toLogMsg m+ & setCallStack callStack+ )++-- | Construct a 'LogEvent' with 'debugSeverity'+debugMessage :: (HasCallStack, ToLogMsg a) => a -> LogEvent+debugMessage m =+ withFrozenCallStack+ (def & logEventSeverity .~ debugSeverity & logEventMessage .~ toLogMsg m & setCallStack callStack)++-- | The filter predicate for message that shall be logged.+--+-- See "Control.Eff.Log#LogPredicate"+type LogPredicate = LogEvent -> Bool++-- | All messages.+--+-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.+allLogEvents :: LogPredicate+allLogEvents = const True++-- | No messages.+--+-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.+noLogEvents :: LogPredicate+noLogEvents = const False++-- | Match 'LogEvent's that have exactly the given severity.+-- See 'logEventSeverityIsAtLeast'.+--+-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.+logEventSeverityIs :: Severity -> LogPredicate+logEventSeverityIs s = view (logEventSeverity . to (== s))++-- | Match 'LogEvent's that have the given severity __or worse__.+-- See 'logEventSeverityIs'.+--+-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.+logEventSeverityIsAtLeast :: Severity -> LogPredicate+logEventSeverityIsAtLeast s = view (logEventSeverity . to (<= s))++-- | Match 'LogEvent's whose 'logEventMessage' starts with the given string.+--+-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.+logEventMessageStartsWith :: ToLogMsg a => a -> LogPredicate+logEventMessageStartsWith aPrefix lm = case T.length prefix of+ 0 -> True+ prefixLen -> T.take prefixLen (lm ^. logEventMessage . fromLogMsg) == prefix+ where+ (MkLogMsg !prefix) = toLogMsg aPrefix++-- | Apply a 'LogPredicate' based on the 'logEventAppName' and delegate+-- to one of two 'LogPredicate's.+--+-- One useful application for this is to allow info and debug message+-- from one application, e.g. the current application itself,+-- while at the same time allowing only warning and error messages+-- from third party libraries.+--+-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates.+discriminateByAppName :: T.Text -> LogPredicate -> LogPredicate -> LogPredicate+discriminateByAppName appName appPredicate otherPredicate lm =+ if view logEventAppName lm == Just appName then appPredicate lm else otherPredicate lm
src/Control/Eff/Log/MessageRenderer.hs view
@@ -1,260 +1,274 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuantifiedConstraints #-}--- | Rendering functions for 'LogMessage's.-module Control.Eff.Log.MessageRenderer- ( - -- * Log Message Text Rendering- LogMessageRenderer- , LogMessageTextRenderer- , renderLogMessageSyslog- , renderLogMessageConsoleLog- , renderConsoleMinimalisticWide- , renderRFC3164- , renderRFC3164WithRFC5424Timestamps- , renderRFC3164WithTimestamp- , renderRFC5424- , renderRFC5424Header- , renderRFC5424NoLocation+-- | Rendering functions for 'LogEvent's.+module Control.Eff.Log.MessageRenderer+ ( -- * Log Message Text Rendering+ LogEventReader,+ LogEventPrinter,+ renderLogEventSyslog,+ renderLogEventConsoleLog,+ renderConsoleMinimalisticWide,+ renderRFC3164,+ renderRFC3164WithRFC5424Timestamps,+ renderRFC3164WithTimestamp,+ renderRFC5424,+ renderRFC5424Header,+ renderRFC5424NoLocation, - -- ** Partial Log Message Text Rendering- , renderSyslogSeverityAndFacility- , renderLogMessageSrcLoc- , renderMaybeLogMessageLens- , renderLogMessageBodyNoLocation- , renderLogMessageBody- , renderLogMessageBodyFixWidth+ -- ** Partial Log Message Text Rendering+ renderSyslogSeverityAndFacility,+ renderLogMessageSrcLoc,+ renderMaybeLogMessageLens,+ renderLogMessageBodyNoLocation,+ renderLogEventBody,+ renderLogEventBodyFixWidth, - -- ** Timestamp Rendering- , LogMessageTimeRenderer()- , mkLogMessageTimeRenderer- , suppressTimestamp- , rfc3164Timestamp- , rfc5424Timestamp- , rfc5424NoZTimestamp+ -- ** Timestamp Rendering+ LogEventTimeRenderer (),+ mkLogEventTimeRenderer,+ suppressTimestamp,+ rfc3164Timestamp,+ rfc5424Timestamp,+ rfc5424NoZTimestamp, ) where -import Control.Eff.Log.Message-import Control.Lens-import Data.Maybe-import qualified Data.Text as T-import Data.Time.Clock-import Data.Time.Format-import GHC.Stack-import System.FilePath.Posix-import Text.Printf-+import Control.Eff.Log.Message+import Control.Lens+import Data.Maybe+import qualified Data.Text as T+import Data.Time.Clock+import Data.Time.Format+import GHC.Stack+import System.FilePath.Posix+import Text.Printf --- | 'LogMessage' rendering function-type LogMessageRenderer a = LogMessage -> a+-- | 'LogEvent' rendering function+type LogEventReader a = LogEvent -> a --- | 'LogMessage' to 'T.Text' rendering function.+-- | 'LogEvent' to 'T.Text' rendering function. -- -- @since 0.31.0-type LogMessageTextRenderer = LogMessageRenderer T.Text+type LogEventPrinter = LogEventReader T.Text --- | A rendering function for the 'lmTimestamp' field.-newtype LogMessageTimeRenderer =- MkLogMessageTimeRenderer { renderLogMessageTime :: UTCTime -> T.Text }+-- | A rendering function for the 'logEventTimestamp' field.+newtype LogEventTimeRenderer = MkLogEventTimeRenderer {renderLogEventTime :: UTCTime -> T.Text} --- | Make a 'LogMessageTimeRenderer' using 'formatTime' in the 'defaultLocale'.-mkLogMessageTimeRenderer- :: String -- ^ The format string that is passed to 'formatTime'- -> LogMessageTimeRenderer-mkLogMessageTimeRenderer s =- MkLogMessageTimeRenderer (T.pack . formatTime defaultTimeLocale s)+-- | Make a 'LogEventTimeRenderer' using 'formatTime' in the 'defaultLocale'.+mkLogEventTimeRenderer ::+ -- | The format string that is passed to 'formatTime'+ String ->+ LogEventTimeRenderer+mkLogEventTimeRenderer s =+ MkLogEventTimeRenderer (T.pack . formatTime defaultTimeLocale s) -- | Don't render the time stamp-suppressTimestamp :: LogMessageTimeRenderer-suppressTimestamp = MkLogMessageTimeRenderer (const "")+suppressTimestamp :: LogEventTimeRenderer+suppressTimestamp = MkLogEventTimeRenderer (const "") -- | Render the time stamp using @"%h %d %H:%M:%S"@-rfc3164Timestamp :: LogMessageTimeRenderer-rfc3164Timestamp = mkLogMessageTimeRenderer "%h %d %H:%M:%S"+rfc3164Timestamp :: LogEventTimeRenderer+rfc3164Timestamp = mkLogEventTimeRenderer "%h %d %H:%M:%S" -- | Render the time stamp to @'iso8601DateFormat' (Just "%H:%M:%S%6QZ")@-rfc5424Timestamp :: LogMessageTimeRenderer+rfc5424Timestamp :: LogEventTimeRenderer rfc5424Timestamp =- mkLogMessageTimeRenderer (iso8601DateFormat (Just "%H:%M:%S%6QZ"))+ mkLogEventTimeRenderer (iso8601DateFormat (Just "%H:%M:%S%6QZ")) -- | Render the time stamp like 'rfc5424Timestamp' does, but omit the terminal @Z@ character.-rfc5424NoZTimestamp :: LogMessageTimeRenderer+rfc5424NoZTimestamp :: LogEventTimeRenderer rfc5424NoZTimestamp =- mkLogMessageTimeRenderer (iso8601DateFormat (Just "%H:%M:%S%6Q"))+ mkLogEventTimeRenderer (iso8601DateFormat (Just "%H:%M:%S%6Q")) -- | Print the thread id, the message and the source file location, seperated by simple white space.-renderLogMessageBody :: LogMessageTextRenderer-renderLogMessageBody = T.unwords . filter (not . T.null) <$> sequence- [ renderLogMessageBodyNoLocation- , fromMaybe "" <$> renderLogMessageSrcLoc- ]+renderLogEventBody :: LogEventPrinter+renderLogEventBody =+ T.unwords . filter (not . T.null)+ <$> sequence+ [ renderLogMessageBodyNoLocation,+ fromMaybe "" <$> renderLogMessageSrcLoc+ ] -- | Print the thread id, the message and the source file location, seperated by simple white space.-renderLogMessageBodyNoLocation :: LogMessageTextRenderer-renderLogMessageBodyNoLocation = T.unwords . filter (not . T.null) <$> sequence- [ renderShowMaybeLogMessageLens "" lmThreadId- , view lmMessage- ]+renderLogMessageBodyNoLocation :: LogEventPrinter+renderLogMessageBodyNoLocation =+ T.unwords . filter (not . T.null)+ <$> sequence+ [ renderShowMaybeLogMessageLens "" logEventThreadId,+ view (logEventMessage . fromLogMsg)+ ] --- | Print the /body/ of a 'LogMessage' with fix size fields (60) for the message itself+-- | Print the /body/ of a 'LogEvent' with fix size fields (60) for the message itself -- and 30 characters for the location-renderLogMessageBodyFixWidth :: LogMessageTextRenderer-renderLogMessageBodyFixWidth l@(MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti _ msg)- = T.unwords $ filter- (not . T.null)- [ maybe "" ((<> " ") . T.pack . show) ti- , msg <> T.replicate (max 0 (60 - T.length msg)) " "- , fromMaybe "" (renderLogMessageSrcLoc l)- ]+renderLogEventBodyFixWidth :: LogEventPrinter+renderLogEventBodyFixWidth l@(MkLogEvent _f _s _ts _hn _an _pid _mi _sd ti _ (MkLogMsg msg)) =+ T.unwords $+ filter+ (not . T.null)+ [ maybe "" ((<> " ") . T.pack . show) ti,+ msg <> T.replicate (max 0 (60 - T.length msg)) " ",+ fromMaybe "" (renderLogMessageSrcLoc l)+ ] --- | Render a field of a 'LogMessage' using the corresponsing lens.-renderMaybeLogMessageLens- :: T.Text -> Getter LogMessage (Maybe T.Text) -> LogMessageTextRenderer+-- | Render a field of a 'LogEvent' using the corresponsing lens.+renderMaybeLogMessageLens ::+ T.Text -> Getter LogEvent (Maybe T.Text) -> LogEventPrinter renderMaybeLogMessageLens x l = fromMaybe x . view l --- | Render a field of a 'LogMessage' using the corresponsing lens.-renderShowMaybeLogMessageLens- :: Show a- => T.Text- -> Getter LogMessage (Maybe a)- -> LogMessageTextRenderer+-- | Render a field of a 'LogEvent' using the corresponsing lens.+renderShowMaybeLogMessageLens ::+ Show a =>+ T.Text ->+ Getter LogEvent (Maybe a) ->+ LogEventPrinter renderShowMaybeLogMessageLens x l = renderMaybeLogMessageLens x (l . to (fmap (T.pack . show))) -- | Render the source location as: @at filepath:linenumber@.-renderLogMessageSrcLoc :: LogMessageRenderer (Maybe T.Text)-renderLogMessageSrcLoc = view- ( lmSrcLoc- . to- (fmap- (\sl -> T.pack $ printf "at %s:%i"- (takeFileName (srcLocFile sl))- (srcLocStartLine sl)- )- )- )-+renderLogMessageSrcLoc :: LogEventReader (Maybe T.Text)+renderLogMessageSrcLoc =+ view+ ( logEventSrcLoc+ . to+ ( fmap+ ( \sl ->+ T.pack $+ printf+ "at %s:%i"+ (takeFileName (srcLocFile sl))+ (srcLocStartLine sl)+ )+ )+ ) -- | Render the severity and facility as described in RFC-3164 -- -- Render e.g. as @\<192\>@. -- -- Useful as header for syslog compatible log output.-renderSyslogSeverityAndFacility :: LogMessageTextRenderer-renderSyslogSeverityAndFacility (MkLogMessage !f !s _ _ _ _ _ _ _ _ _) =+renderSyslogSeverityAndFacility :: LogEventPrinter+renderSyslogSeverityAndFacility (MkLogEvent !f !s _ _ _ _ _ _ _ _ _) = "<" <> T.pack (show (fromSeverity s + fromFacility f * 8)) <> ">" --- | Render the 'LogMessage' to contain the severity, message, message-id, pid.+-- | Render the 'LogEvent' to contain the severity, message, message-id, pid. -- -- Omit hostname, PID and timestamp. -- -- Render the header using 'renderSyslogSeverity' -- -- Useful for logging to @/dev/log@-renderLogMessageSyslog :: LogMessageTextRenderer-renderLogMessageSyslog l@(MkLogMessage _ _ _ _ an _ mi _ _ _ _)- = renderSyslogSeverityAndFacility l <> (T.unwords- . filter (not . T.null)- $ [ fromMaybe "" an- , fromMaybe "" mi- , renderLogMessageBody l- ])+renderLogEventSyslog :: LogEventPrinter+renderLogEventSyslog l@(MkLogEvent _ _ _ _ an _ mi _ _ _ _) =+ renderSyslogSeverityAndFacility l+ <> ( T.unwords+ . filter (not . T.null)+ $ [ fromMaybe "" an,+ fromMaybe "" mi,+ renderLogEventBody l+ ]+ ) --- | Render a 'LogMessage' human readable, for console logging-renderLogMessageConsoleLog :: LogMessageTextRenderer-renderLogMessageConsoleLog l@(MkLogMessage _ _ ts _ _ _ _ sd _ _ _) =- T.unwords $ filter- (not . T.null)- [ T.pack (show (view lmSeverity l))- , let p = fromMaybe "no process" (l ^. lmProcessId)- in p <> T.replicate (max 0 (55 - T.length p)) " "- , maybe "" (renderLogMessageTime rfc5424Timestamp) ts- , renderLogMessageBodyFixWidth l- , if null sd then "" else T.concat (renderSdElement <$> sd)- ]+-- | Render a 'LogEvent' human readable, for console logging+renderLogEventConsoleLog :: LogEventPrinter+renderLogEventConsoleLog l@(MkLogEvent _ _ ts _ _ _ _ sd _ _ _) =+ T.unwords $+ filter+ (not . T.null)+ [ severityToText (view logEventSeverity l),+ let p = fromMaybe "no process" (l ^. logEventProcessId)+ in p <> T.replicate (max 0 (55 - T.length p)) " ",+ maybe "" (renderLogEventTime rfc5424Timestamp) ts,+ renderLogEventBodyFixWidth l,+ if null sd then "" else T.concat (renderSdElement <$> sd)+ ] --- | Render a 'LogMessage' human readable, for console logging+-- | Render a 'LogEvent' human readable, for console logging -- -- @since 0.31.0-renderConsoleMinimalisticWide :: LogMessageRenderer T.Text+renderConsoleMinimalisticWide :: LogEventReader T.Text renderConsoleMinimalisticWide l =- T.unwords $ filter- (not . T.null)- [ let s = T.pack (show (view lmSeverity l))- in s <> T.replicate (max 0 (15 - T.length s)) " "- , let p = fromMaybe "no process" (l ^. lmProcessId)- in p <> T.replicate (max 0 (55 - T.length p)) " "- , let msg = l^.lmMessage- in msg <> T.replicate (max 0 (100 - T.length msg)) " "- -- , fromMaybe "" (renderLogMessageSrcLoc l)- ]+ T.unwords $+ filter+ (not . T.null)+ [ let s = severityToText (view logEventSeverity l)+ in s <> T.replicate (max 0 (15 - T.length s)) " ",+ let p = fromMaybe "no process" (l ^. logEventProcessId)+ in p <> T.replicate (max 0 (55 - T.length p)) " ",+ let msg = l ^. logEventMessage . fromLogMsg+ in msg <> T.replicate (max 0 (100 - T.length msg)) " "+ -- , fromMaybe "" (renderLogMessageSrcLoc l)+ ] --- | Render a 'LogMessage' according to the rules in the RFC-3164.-renderRFC3164 :: LogMessageTextRenderer+-- | Render a 'LogEvent' according to the rules in the RFC-3164.+renderRFC3164 :: LogEventPrinter renderRFC3164 = renderRFC3164WithTimestamp rfc3164Timestamp --- | Render a 'LogMessage' according to the rules in the RFC-3164 but use+-- | Render a 'LogEvent' according to the rules in the RFC-3164 but use -- RFC5424 time stamps.-renderRFC3164WithRFC5424Timestamps :: LogMessageTextRenderer+renderRFC3164WithRFC5424Timestamps :: LogEventPrinter renderRFC3164WithRFC5424Timestamps = renderRFC3164WithTimestamp rfc5424Timestamp --- | Render a 'LogMessage' according to the rules in the RFC-3164 but use the custom--- 'LogMessageTimeRenderer'.-renderRFC3164WithTimestamp :: LogMessageTimeRenderer -> LogMessageTextRenderer-renderRFC3164WithTimestamp renderTime l@(MkLogMessage _ _ ts hn an pid mi _ _ _ _) =+-- | Render a 'LogEvent' according to the rules in the RFC-3164 but use the custom+-- 'LogEventTimeRenderer'.+renderRFC3164WithTimestamp :: LogEventTimeRenderer -> LogEventPrinter+renderRFC3164WithTimestamp renderTime l@(MkLogEvent _ _ ts hn an pid mi _ _ _ _) = T.unwords . filter (not . T.null)- $ [ renderSyslogSeverityAndFacility l -- PRI- , maybe "1979-05-29T00:17:17.000001Z"- (renderLogMessageTime renderTime)- ts- , fromMaybe "localhost" hn- , fromMaybe "haskell" an <> maybe "" (("[" <>) . (<> "]")) pid <> ":"- , fromMaybe "" mi- , renderLogMessageBody l+ $ [ renderSyslogSeverityAndFacility l, -- PRI+ maybe+ "1979-05-29T00:17:17.000001Z"+ (renderLogEventTime renderTime)+ ts,+ fromMaybe "localhost" hn,+ fromMaybe "haskell" an <> maybe "" (("[" <>) . (<> "]")) pid <> ":",+ fromMaybe "" mi,+ renderLogEventBody l ] --- | Render a 'LogMessage' according to the rules in the RFC-5424.+-- | Render a 'LogEvent' according to the rules in the RFC-5424. ----- Equivalent to @'renderRFC5424Header' <> const " " <> 'renderLogMessageBody'@.+-- Equivalent to @'renderRFC5424Header' <> const " " <> 'renderLogEventBody'@. -- -- @since 0.21.0-renderRFC5424 :: LogMessageTextRenderer-renderRFC5424 = renderRFC5424Header <> const " " <> renderLogMessageBody+renderRFC5424 :: LogEventPrinter+renderRFC5424 = renderRFC5424Header <> const " " <> renderLogEventBody --- | Render a 'LogMessage' according to the rules in the RFC-5424, like 'renderRFC5424' but+-- | Render a 'LogEvent' according to the rules in the RFC-5424, like 'renderRFC5424' but -- suppress the source location information. -- -- Equivalent to @'renderRFC5424Header' <> const " " <> 'renderLogMessageBodyNoLocation'@. -- -- @since 0.21.0-renderRFC5424NoLocation :: LogMessageTextRenderer-renderRFC5424NoLocation = renderRFC5424Header <> const " " <> renderLogMessageBodyNoLocation+renderRFC5424NoLocation :: LogEventPrinter+renderRFC5424NoLocation = renderRFC5424Header <> const " " <> renderLogMessageBodyNoLocation --- | Render the header and strucuted data of a 'LogMessage' according to the rules in the RFC-5424, but do not--- render the 'lmMessage'.+-- | Render the header and strucuted data of a 'LogEvent' according to the rules in the RFC-5424, but do not+-- render the 'logEventMessage'. -- -- @since 0.22.0-renderRFC5424Header :: LogMessageTextRenderer-renderRFC5424Header l@(MkLogMessage _ _ ts hn an pid mi sd _ _ _) =+renderRFC5424Header :: LogEventPrinter+renderRFC5424Header l@(MkLogEvent _ _ ts hn an pid mi sd _ _ _) = T.unwords . filter (not . T.null)- $ [ renderSyslogSeverityAndFacility l <> "1" -- PRI VERSION- , maybe "-" (renderLogMessageTime rfc5424Timestamp) ts- , fromMaybe "-" hn- , fromMaybe "-" an- , fromMaybe "-" pid- , fromMaybe "-" mi- , structuredData+ $ [ renderSyslogSeverityAndFacility l <> "1", -- PRI VERSION+ maybe "-" (renderLogEventTime rfc5424Timestamp) ts,+ fromMaybe "-" hn,+ fromMaybe "-" an,+ fromMaybe "-" pid,+ fromMaybe "-" mi,+ structuredData ]- where- structuredData = if null sd then "-" else T.concat (renderSdElement <$> sd)+ where+ structuredData = if null sd then "-" else T.concat (renderSdElement <$> sd) renderSdElement :: StructuredDataElement -> T.Text-renderSdElement (SdElement sdId params) = "[" <> sdName sdId <> if null params- then ""- else " " <> T.unwords (renderSdParameter <$> params) <> "]"+renderSdElement (SdElement sdId params) =+ "[" <> sdName sdId+ <> if null params+ then ""+ else " " <> T.unwords (renderSdParameter <$> params) <> "]" renderSdParameter :: SdParameter -> T.Text renderSdParameter (MkSdParameter k v) =@@ -268,7 +282,7 @@ -- | Extract the value of an 'SdParameter'. sdParamValue :: T.Text -> T.Text sdParamValue = T.concatMap $ \case- '"' -> "\\\""+ '"' -> "\\\"" '\\' -> "\\\\"- ']' -> "\\]"- x -> T.singleton x+ ']' -> "\\]"+ x -> T.singleton x
src/Control/Eff/Log/Writer.hs view
@@ -1,40 +1,43 @@ {-# LANGUAGE UndecidableInstances #-}--- | The 'LogWriter' type encapsulates an 'IO' action to write 'LogMessage's.++-- | The 'LogWriter' type encapsulates an 'IO' action to write 'LogEvent's. module Control.Eff.Log.Writer- (- -- * 'LogWriter' Definition- LogWriter(..)- -- * LogWriter Reader Effect- , LogWriterReader- , localLogWriterReader- , askLogWriter- , runLogWriterReader- -- * LogWriter utilities- , liftWriteLogMessage- , noOpLogWriter- , filteringLogWriter- , mappingLogWriter- , mappingLogWriterIO- , ioHandleLogWriter- , stdoutLogWriter+ ( -- * 'LogWriter' Definition+ LogWriter (..),++ -- * LogWriter Reader Effect+ LogWriterReader,+ localLogWriterReader,+ askLogWriter,+ runLogWriterReader,++ -- * LogWriter utilities+ liftWriteLogMessage,+ noOpLogWriter,+ filteringLogWriter,+ mappingLogWriter,+ mappingLogWriterIO,+ ioHandleLogWriter,+ stdoutLogWriter, ) where -import Control.Eff-import Control.Eff.Reader.Strict-import Control.Eff.Log.Message-import Control.Eff.Log.MessageRenderer-import Control.Monad ( (>=>)- , when- )+import Control.Eff+import Control.Eff.Log.Message+import Control.Eff.Log.MessageRenderer+import Control.Eff.Reader.Strict+import Control.Monad+ ( when,+ (>=>),+ )+import Data.Text (Text) import qualified Data.Text.IO as Text-import Data.Text (Text) import qualified System.IO as IO -- | A function that takes a log message and returns an effect that -- /logs/ the message. newtype LogWriter = MkLogWriter- { runLogWriter :: LogMessage -> IO ()+ { runLogWriter :: LogEvent -> IO () } instance Semigroup LogWriter where@@ -59,19 +62,19 @@ askLogWriter = ask -- | Modify the current 'LogWriter'.-localLogWriterReader- :: forall e a- . Member LogWriterReader e- => (LogWriter -> LogWriter)- -> Eff e a- -> Eff e a+localLogWriterReader ::+ forall e a.+ Member LogWriterReader e =>+ (LogWriter -> LogWriter) ->+ Eff e a ->+ Eff e a localLogWriterReader = local -- | Write a message using the 'LogWriter' found in the environment.-liftWriteLogMessage- :: ( Member LogWriterReader e, Lifted IO e)- => LogMessage- -> Eff e ()+liftWriteLogMessage ::+ (Member LogWriterReader e, Lifted IO e) =>+ LogEvent ->+ Eff e () liftWriteLogMessage m = do w <- askLogWriter lift (runLogWriter w m)@@ -82,36 +85,36 @@ noOpLogWriter :: LogWriter noOpLogWriter = mempty --- | A 'LogWriter' that applies a predicate to the 'LogMessage' and delegates to+-- | A 'LogWriter' that applies a predicate to the 'LogEvent' and delegates to -- to the given writer of the predicate is satisfied. filteringLogWriter :: LogPredicate -> LogWriter -> LogWriter filteringLogWriter p lw = MkLogWriter (\msg -> when (p msg) (runLogWriter lw msg)) --- | A 'LogWriter' that applies a function to the 'LogMessage' and delegates the result to+-- | A 'LogWriter' that applies a function to the 'LogEvent' and delegates the result to -- to the given writer.-mappingLogWriter :: (LogMessage -> LogMessage) -> LogWriter -> LogWriter+mappingLogWriter :: (LogEvent -> LogEvent) -> LogWriter -> LogWriter mappingLogWriter f lw = MkLogWriter (runLogWriter lw . f) --- | Like 'mappingLogWriter' allow the function that changes the 'LogMessage' to have effects.-mappingLogWriterIO- :: (LogMessage -> IO LogMessage) -> LogWriter -> LogWriter+-- | Like 'mappingLogWriter' allow the function that changes the 'LogEvent' to have effects.+mappingLogWriterIO ::+ (LogEvent -> IO LogEvent) -> LogWriter -> LogWriter mappingLogWriterIO f lw = MkLogWriter (f >=> runLogWriter lw) --- | Append the 'LogMessage' to an 'IO.Handle' after rendering it.+-- | Append the 'LogEvent' to an 'IO.Handle' after rendering it. -- -- @since 0.31.0-ioHandleLogWriter :: IO.Handle -> LogMessageRenderer Text -> LogWriter+ioHandleLogWriter :: IO.Handle -> LogEventReader Text -> LogWriter ioHandleLogWriter outH r = MkLogWriter (Text.hPutStrLn outH . r) --- | Render a 'LogMessage' to 'IO.stdout'.+-- | Render a 'LogEvent' to 'IO.stdout'. -- -- This function will also set the 'IO.BufferMode' of 'IO.stdout' to 'IO.LineBuffering'. -- -- See 'ioHandleLogWriter'. -- -- @since 0.31.0-stdoutLogWriter :: LogMessageRenderer Text -> IO LogWriter+stdoutLogWriter :: LogEventReader Text -> IO LogWriter stdoutLogWriter render = do IO.hSetBuffering IO.stdout IO.LineBuffering return (ioHandleLogWriter IO.stdout render)
src/Control/Eff/LogWriter/Async.hs view
@@ -1,27 +1,26 @@ -- | This module only exposes a 'LogWriter' for asynchronous logging; module Control.Eff.LogWriter.Async- ( withAsyncLogWriter- , withAsyncLogging+ ( withAsyncLogWriter,+ withAsyncLogging, ) where -import Control.Concurrent (threadDelay)-import Control.Concurrent.Async-import Control.Concurrent.STM-import Control.DeepSeq-import Control.Eff as Eff-import Control.Eff.Log-import Control.Eff.LogWriter.Rich-import Control.Exception ( evaluate )-import Control.Lens-import Control.Monad ( unless, when )-import Control.Monad.Trans.Control ( MonadBaseControl- , liftBaseOp- )-import Data.Foldable ( traverse_ )-import Data.Kind ( )-import Data.Text as T-+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.DeepSeq+import Control.Eff as Eff+import Control.Eff.Log+import Control.Eff.LogWriter.Rich+import Control.Exception (evaluate)+import Control.Lens+import Control.Monad (unless, when)+import Control.Monad.Trans.Control+ ( MonadBaseControl,+ liftBaseOp,+ )+import Data.Foldable (traverse_)+import Data.Kind () -- | This is a wrapper around 'withAsyncLogWriter' and 'withRichLogging'. --@@ -30,26 +29,29 @@ -- > exampleWithAsyncLogging :: IO () -- > exampleWithAsyncLogging = -- > runLift--- > $ withAsyncLogWriter consoleLogWriter (1000::Int) "my-app" local0 allLogMessages--- > $ do logMsg "test 1"--- > logMsg "test 2"--- > logMsg "test 3"+-- > $ withAsyncLogWriter consoleLogWriter (1000::Int) "my-app" local0 allLogEvents+-- > $ do sendLogEvent "test 1"+-- > sendLogEvent "test 2"+-- > sendLogEvent "test 3" -- >----withAsyncLogging- :: (Lifted IO e, MonadBaseControl IO (Eff e), Integral len)- => LogWriter- -> len -- ^ Size of the log message input queue. If the queue is full, message- -- are dropped silently.- -> Text -- ^ The default application name to put into the 'lmAppName' field.- -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.- -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"- -> Eff (Logs : LogWriterReader : e) a- -> Eff e a-withAsyncLogging lw queueLength a f p e = liftBaseOp- (withAsyncLogChannel queueLength (runLogWriter lw . force))- (\lc -> withRichLogging (makeLogChannelWriter lc) a f p e)-+withAsyncLogging ::+ (Lifted IO e, MonadBaseControl IO (Eff e), Integral len) =>+ LogWriter ->+ -- | Size of the log message input queue. If the queue is full, message+ -- are dropped silently.+ len ->+ -- | The default application name to put into the 'logEventAppName' field.+ String ->+ -- | The default RFC-5424 facility to put into the 'logEventFacility' field.+ Facility ->+ -- | The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+ LogPredicate ->+ Eff (Logs : LogWriterReader : e) a ->+ Eff e a+withAsyncLogging lw queueLength a f p e =+ liftBaseOp+ (withAsyncLogChannel queueLength (runLogWriter lw . force))+ (\lc -> withRichLogging (makeLogChannelWriter lc) a f p e) -- | /Move/ the current 'LogWriter' into its own thread. --@@ -68,60 +70,63 @@ -- > runLift -- > $ withLogging consoleLogWriter -- > $ withAsyncLogWriter (1000::Int)--- > $ do logMsg "test 1"--- > logMsg "test 2"--- > logMsg "test 3"+-- > $ do sendLogEvent "test 1"+-- > sendLogEvent "test 2"+-- > sendLogEvent "test 3" -- >----withAsyncLogWriter- :: (IoLogging e, MonadBaseControl IO (Eff e), Integral len)- => len -- ^ Size of the log message input queue. If the queue is full, message- -- are dropped silently.- -> Eff e a- -> Eff e a+withAsyncLogWriter ::+ (IoLogging e, MonadBaseControl IO (Eff e), Integral len) =>+ -- | Size of the log message input queue. If the queue is full, message+ -- are dropped silently.+ len ->+ Eff e a ->+ Eff e a withAsyncLogWriter queueLength e = do lw <- askLogWriter- liftBaseOp (withAsyncLogChannel queueLength (runLogWriter lw . force))- (\lc -> setLogWriter (makeLogChannelWriter lc) e)+ liftBaseOp+ (withAsyncLogChannel queueLength (runLogWriter lw . force))+ (\lc -> setLogWriter (makeLogChannelWriter lc) e) -withAsyncLogChannel- :: forall a len- . (Integral len)- => len- -> (LogMessage -> IO ())- -> (LogChannel -> IO a)- -> IO a+withAsyncLogChannel ::+ forall a len.+ (Integral len) =>+ len ->+ (LogEvent -> IO ()) ->+ (LogChannel -> IO a) ->+ IO a withAsyncLogChannel queueLen ioWriter action = do msgQ <- newTBQueueIO (fromIntegral queueLen) withAsync (logLoop msgQ) (action . ConcurrentLogChannel msgQ)- where- logLoop tq = do- ms <- atomically $ do- isEmpty <- isEmptyTBQueue tq- when isEmpty retry- flushTBQueue tq- traverse_ ioWriter ms- logLoop tq+ where+ logLoop tq = do+ ms <- atomically $ do+ isEmpty <- isEmptyTBQueue tq+ when isEmpty retry+ flushTBQueue tq+ traverse_ ioWriter ms+ logLoop tq makeLogChannelWriter :: LogChannel -> LogWriter makeLogChannelWriter lc = MkLogWriter logChannelPutIO- where- logChannelPutIO (force -> me) = do- !m <- evaluate me- isFull <- atomically (- if m^.lmSeverity <= warningSeverity then do- writeTBQueue logQ m- return False- else do- isFull <- isFullTBQueue logQ- unless isFull (writeTBQueue logQ m)- return isFull- )- when isFull $- threadDelay 1_000- logQ = fromLogChannel lc+ where+ logChannelPutIO (force -> me) = do+ !m <- evaluate me+ isFull <-+ atomically+ ( if m ^. logEventSeverity <= warningSeverity+ then do+ writeTBQueue logQ m+ return False+ else do+ isFull <- isFullTBQueue logQ+ unless isFull (writeTBQueue logQ m)+ return isFull+ )+ when isFull $+ threadDelay 1_000+ logQ = fromLogChannel lc data LogChannel = ConcurrentLogChannel- { fromLogChannel :: TBQueue LogMessage- , _logChannelThread :: Async ()+ { fromLogChannel :: TBQueue LogEvent,+ _logChannelThread :: Async () }
src/Control/Eff/LogWriter/Console.hs view
@@ -1,44 +1,46 @@ -- | This helps to setup logging to /standard ouput/. module Control.Eff.LogWriter.Console- ( withConsoleLogWriter- , withConsoleLogging- , consoleLogWriter- ) where+ ( withConsoleLogWriter,+ withConsoleLogging,+ consoleLogWriter,+ )+where import Control.Eff as Eff import Control.Eff.Log import Control.Eff.LogWriter.Rich-import Data.Text --- | Enable logging to @standard output@ using the 'consoleLogWriter', with some 'LogMessage' fields preset+-- | Enable logging to @standard output@ using the 'consoleLogWriter', with some 'LogEvent' fields preset -- as in 'withRichLogging'. ----- Log messages are rendered using 'renderLogMessageConsoleLog'.+-- Log messages are rendered using 'renderLogEventConsoleLog'. -- -- Example: -- -- > exampleWithConsoleLogging :: IO () -- > exampleWithConsoleLogging = -- > runLift--- > $ withConsoleLogging "my-app" local7 allLogMessages+-- > $ withConsoleLogging "my-app" local7 allLogEvents -- > $ logInfo "Oh, hi there" -- -- To vary the 'LogWriter' use 'withRichLogging'.-withConsoleLogging- :: Lifted IO e- => Text -- ^ The default application name to put into the 'lmAppName' field.- -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.- -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"- -> Eff (Logs : LogWriterReader : e) a- -> Eff e a+withConsoleLogging ::+ Lifted IO e =>+ -- | The default application name to put into the 'logEventAppName' field.+ String ->+ -- | The default RFC-5424 facility to put into the 'logEventFacility' field.+ Facility ->+ -- | The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+ LogPredicate ->+ Eff (Logs : LogWriterReader : e) a ->+ Eff e a withConsoleLogging a b c d = do lw <- lift consoleLogWriter withRichLogging lw a b c d - -- | Enable logging to @standard output@ using the 'consoleLogWriter'. ----- Log messages are rendered using 'renderLogMessageConsoleLog'.+-- Log messages are rendered using 'renderLogEventConsoleLog'. -- -- Example: --@@ -48,18 +50,18 @@ -- > $ withoutLogging @IO -- > $ withConsoleLogWriter -- > $ logInfo "Oh, hi there"-withConsoleLogWriter- :: (IoLogging e)- => Eff e a -> Eff e a+withConsoleLogWriter ::+ (IoLogging e) =>+ Eff e a ->+ Eff e a withConsoleLogWriter e = do lw <- lift consoleLogWriter addLogWriter lw e ---- | Render a 'LogMessage' to 'IO.stdout' using 'renderLogMessageConsoleLog'.+-- | Render a 'LogEvent' to 'IO.stdout' using 'renderLogEventConsoleLog'. -- -- See 'stdoutLogWriter'. -- -- @since 0.31.0 consoleLogWriter :: IO LogWriter-consoleLogWriter = stdoutLogWriter renderLogMessageConsoleLog+consoleLogWriter = stdoutLogWriter renderLogEventConsoleLog
src/Control/Eff/LogWriter/DebugTrace.hs view
@@ -1,43 +1,45 @@ -- | This helps to setup logging via "Debug.Trace". module Control.Eff.LogWriter.DebugTrace- ( withTraceLogWriter- , withTraceLogging- , debugTraceLogWriter+ ( withTraceLogWriter,+ withTraceLogging,+ debugTraceLogWriter, ) where -import Debug.Trace-import Control.Eff as Eff-import Control.Eff.Log-import Control.Eff.LogWriter.Rich-import Data.Text as T+import Control.Eff as Eff+import Control.Eff.Log+import Control.Eff.LogWriter.Rich+import Data.Text as T+import Debug.Trace --- | Enable logging via 'traceM' using the 'debugTraceLogWriter', with some 'LogMessage' fields preset+-- | Enable logging via 'traceM' using the 'debugTraceLogWriter', with some 'LogEvent' fields preset -- as in 'withRichLogging'. ----- Log messages are rendered using 'renderLogMessageConsoleLog'.+-- Log messages are rendered using 'renderLogEventConsoleLog'. -- -- Example: -- -- > exampleWithTraceLogging :: IO () -- > exampleWithTraceLogging = -- > runLift--- > $ withTraceLogging "my-app" local7 allLogMessages+-- > $ withTraceLogging "my-app" local7 allLogEvents -- > $ logInfo "Oh, hi there"-withTraceLogging- :: Lifted IO e- => Text -- ^ The default application name to put into the 'lmAppName' field.- -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.- -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"- -> Eff (Logs : LogWriterReader : e) a- -> Eff e a-withTraceLogging = withRichLogging (debugTraceLogWriter renderLogMessageConsoleLog)-+withTraceLogging ::+ Lifted IO e =>+ -- | The default application name to put into the 'logEventAppName' field.+ String ->+ -- | The default RFC-5424 facility to put into the 'logEventFacility' field.+ Facility ->+ -- | The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+ LogPredicate ->+ Eff (Logs : LogWriterReader : e) a ->+ Eff e a+withTraceLogging = withRichLogging (debugTraceLogWriter renderLogEventConsoleLog) -- | Enable logging via 'traceM' using the 'debugTraceLogWriter'. The -- logging monad type can be /any/ type with a 'Monad' instance. ----- Log messages are rendered using 'renderLogMessageConsoleLog'.+-- Log messages are rendered using 'renderLogEventConsoleLog'. -- -- Example: --@@ -48,8 +50,8 @@ -- > $ withTraceLogWriter -- > $ logInfo "Oh, hi there" withTraceLogWriter :: IoLogging e => Eff e a -> Eff e a-withTraceLogWriter = addLogWriter (debugTraceLogWriter renderLogMessageConsoleLog)+withTraceLogWriter = addLogWriter (debugTraceLogWriter renderLogEventConsoleLog) --- | Write 'LogMessage's via 'traceM'.-debugTraceLogWriter :: LogMessageTextRenderer -> LogWriter+-- | Write 'LogEvent's via 'traceM'.+debugTraceLogWriter :: LogEventPrinter -> LogWriter debugTraceLogWriter render = MkLogWriter (traceM . T.unpack . render)
src/Control/Eff/LogWriter/File.hs view
@@ -1,27 +1,29 @@+{-# LANGUAGE TypeApplications #-}+ -- | This helps to setup logging to a /file/. module Control.Eff.LogWriter.File- ( withFileLogging- , withFileLogWriter+ ( withFileLogging,+ withFileLogWriter, ) where -import Control.Eff as Eff-import Control.Eff.Log-import Control.Eff.LogWriter.Rich-import GHC.Stack-import Data.Text as T-import qualified System.IO as IO-import System.Directory ( canonicalizePath- , createDirectoryIfMissing- )-import System.FilePath ( takeDirectory )-import qualified Control.Exception.Safe as Safe-import qualified Control.Monad.Catch as Catch-import Control.Monad.Trans.Control ( MonadBaseControl- , liftBaseOp- )+import Control.Eff as Eff+import Control.Eff.Log+import Control.Eff.LogWriter.Rich+import qualified Control.Exception.Safe as Safe+import qualified Control.Monad.Catch as Catch+import Control.Monad.Trans.Control+ ( MonadBaseControl,+ liftBaseOp,+ )+import System.Directory+ ( canonicalizePath,+ createDirectoryIfMissing,+ )+import System.FilePath (takeDirectory)+import qualified System.IO as IO --- | Enable logging to a file, with some 'LogMessage' fields preset+-- | Enable logging to a file, with some 'LogEvent' fields preset -- as described in 'withRichLogging'. -- -- If the file or its directory does not exist, it will be created.@@ -31,23 +33,27 @@ -- > exampleWithFileLogging :: IO () -- > exampleWithFileLogging = -- > runLift--- > $ withFileLogging "/var/log/my-app.log" "my-app" local7 allLogMessages renderLogMessageConsoleLog+-- > $ withFileLogging "/var/log/my-app.log" "my-app" local7 allLogEvents renderLogEventConsoleLog -- > $ logInfo "Oh, hi there" -- -- To vary the 'LogWriter' use 'withRichLogging'.-withFileLogging- :: (Lifted IO e, MonadBaseControl IO (Eff e), HasCallStack)- => FilePath -- ^ Path to the log-file.- -> Text -- ^ The default application name to put into the 'lmAppName' field.- -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.- -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"- -> LogMessageTextRenderer -- ^ The 'LogMessage' render function- -> Eff (Logs : LogWriterReader : e) a- -> Eff e a+withFileLogging ::+ (Lifted IO e, MonadBaseControl IO (Eff e)) =>+ -- | Path to the log-file.+ FilePath ->+ -- | The default application name to put into the 'logEventAppName' field.+ String ->+ -- | The default RFC-5424 facility to put into the 'logEventFacility' field.+ Facility ->+ -- | The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+ LogPredicate ->+ -- | The 'LogEvent' render function+ LogEventPrinter ->+ Eff (Logs : LogWriterReader : e) a ->+ Eff e a withFileLogging fnIn a f p render e = do liftBaseOp (withOpenedLogFile fnIn render) (\lw -> withRichLogging lw a f p e) - -- | Enable logging to a file. -- -- If the file or its directory does not exist, it will be created.@@ -57,30 +63,31 @@ -- > exampleWithFileLogWriter = -- > runLift -- > $ withoutLogging--- > $ withFileLogWriter "test.log" renderLogMessageConsoleLog+-- > $ withFileLogWriter "test.log" renderLogEventConsoleLog -- > $ logInfo "Oh, hi there"-withFileLogWriter- :: (IoLogging e, MonadBaseControl IO (Eff e), HasCallStack)- => FilePath -- ^ Path to the log-file.- -> LogMessageTextRenderer- -> Eff e b- -> Eff e b+withFileLogWriter ::+ (IoLogging e, MonadBaseControl IO (Eff e)) =>+ -- | Path to the log-file.+ FilePath ->+ LogEventPrinter ->+ Eff e b ->+ Eff e b withFileLogWriter fnIn render e = liftBaseOp (withOpenedLogFile fnIn render) (`addLogWriter` e) -withOpenedLogFile- :: HasCallStack- => FilePath- -> LogMessageTextRenderer- -> (LogWriter -> IO a)- -> IO a-withOpenedLogFile fnIn render ioE = Safe.bracket- (do- fnCanon <- canonicalizePath fnIn- createDirectoryIfMissing True (takeDirectory fnCanon)- h <- IO.openFile fnCanon IO.AppendMode- IO.hSetBuffering h IO.LineBuffering- return h- )- (\h -> Safe.try @IO @Catch.SomeException (IO.hFlush h) >> IO.hClose h)- (\h -> ioE (ioHandleLogWriter h render))+withOpenedLogFile ::+ FilePath ->+ LogEventPrinter ->+ (LogWriter -> IO a) ->+ IO a+withOpenedLogFile fnIn render ioE =+ Safe.bracket+ ( do+ fnCanon <- canonicalizePath fnIn+ createDirectoryIfMissing True (takeDirectory fnCanon)+ h <- IO.openFile fnCanon IO.AppendMode+ IO.hSetBuffering h IO.LineBuffering+ return h+ )+ (\h -> Safe.try @IO @Catch.SomeException (IO.hFlush h) >> IO.hClose h)+ (\h -> ioE (ioHandleLogWriter h render))
src/Control/Eff/LogWriter/Rich.hs view
@@ -1,16 +1,16 @@--- | Enrich 'LogMessage's with timestamps and OS dependent information.+-- | Enrich 'LogEvent's with timestamps and OS dependent information. module Control.Eff.LogWriter.Rich- ( richLogWriter- , withRichLogging- , stdoutLogWriter+ ( richLogWriter,+ withRichLogging,+ stdoutLogWriter, ) where -import Control.Eff as Eff-import Control.Eff.Log-import Control.Monad ( (>=>) )-import Control.Lens (set)-import Data.Text+import Control.Eff as Eff+import Control.Eff.Log+import Control.Lens (set)+import Control.Monad ((>=>))+import Data.Text -- | Enable logging to IO using the 'richLogWriter'. --@@ -22,40 +22,47 @@ -- > $ withRichLogging debugTraceLogWriter -- > "my-app" -- > local7--- > (lmSeverityIsAtLeast informationalSeverity)+-- > (logEventSeverityIsAtLeast informationalSeverity) -- > $ logInfo "Oh, hi there"----withRichLogging- :: Lifted IO e- => LogWriter -- ^ The 'LogWriter' that will be used to write log messages.- -> Text -- ^ The default application name to put into the 'lmAppName' field.- -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.- -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"- -> Eff (Logs : LogWriterReader : e) a- -> Eff e a+withRichLogging ::+ Lifted IO e =>+ -- | The 'LogWriter' that will be used to write log messages.+ LogWriter ->+ -- | The default application name to put into the 'logEventAppName' field.+ String ->+ -- | The default RFC-5424 facility to put into the 'logEventFacility' field.+ Facility ->+ -- | The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+ LogPredicate ->+ Eff (Logs : LogWriterReader : e) a ->+ Eff e a withRichLogging lw appName facility defaultPredicate = withLogging (richLogWriter appName facility lw) . setLogPredicate defaultPredicate --- | Decorate an IO based 'LogWriter' to fill out these fields in 'LogMessage's:+-- | Decorate an IO based 'LogWriter' to fill out these fields in 'LogEvent's: ----- * The messages will carry the given application name in the 'lmAppName' field.--- * The 'lmTimestamp' field contains the UTC time of the log event--- * The 'lmHostname' field contains the FQDN of the current host--- * The 'lmFacility' field contains the given 'Facility'+-- * The messages will carry the given application name in the 'logEventAppName' field.+-- * The 'logEventTimestamp' field contains the UTC time of the log event+-- * The 'logEventHostname' field contains the FQDN of the current host+-- * The 'logEventFacility' field contains the given 'Facility' -- -- It works by using 'mappingLogWriterIO'.-richLogWriter- :: Text -- ^ The default application name to put into the 'lmAppName' field.- -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.- -> LogWriter -- ^ The IO based writer to decorate- -> LogWriter+richLogWriter ::+ -- | The default application name to put into the 'logEventAppName' field.+ String ->+ -- | The default RFC-5424 facility to put into the 'logEventFacility' field.+ Facility ->+ -- | The IO based writer to decorate+ LogWriter ->+ LogWriter richLogWriter appName facility = mappingLogWriterIO- ( setLogMessageTimestamp- >=> setLogMessageHostname- )- . mappingLogWriter- ( set lmFacility facility- . set lmAppName (Just appName)+ ( setLogEventsTimestamp+ >=> setLogEventsHostname+ >=> setLogEventsThreadId )+ . mappingLogWriter+ ( set logEventFacility facility+ . set logEventAppName (Just (pack appName))+ )
src/Control/Eff/LogWriter/UDP.hs view
@@ -1,80 +1,94 @@ -- | This helps to setup logging to /standard ouput/. module Control.Eff.LogWriter.UDP- ( withUDPLogWriter- , withUDPLogging+ ( withUDPLogWriter,+ withUDPLogging, ) where -import Control.Eff as Eff-import Control.Eff.Log-import Control.Eff.LogWriter.Rich-import Data.Text as T-import Data.Text.Encoding as T-import qualified Control.Exception.Safe as Safe-import Control.Monad ( void )-import qualified Control.Monad.Catch as Catch-import Control.Monad.Trans.Control ( MonadBaseControl- , liftBaseOp- )-import GHC.Stack-import Network.Socket hiding ( sendTo )-import Network.Socket.ByteString+import Control.Eff as Eff+import Control.Eff.Log+import Control.Eff.LogWriter.Rich+import qualified Control.Exception.Safe as Safe+import Control.Monad (void)+import qualified Control.Monad.Catch as Catch+import Control.Monad.Trans.Control+ ( MonadBaseControl,+ liftBaseOp,+ )+import Data.Text as T+import Data.Text.Encoding as T+import qualified Network.Socket as Network+import Network.Socket.ByteString as Network --- | Enable logging to a remote host via __UDP__, with some 'LogMessage' fields preset+-- | Enable logging to a remote host via __UDP__, with some 'LogEvent' fields preset -- as in 'withRichLogging'. -- -- See 'Control.Eff.Log.Examples.exampleUdpRFC3164Logging'-withUDPLogging- :: (HasCallStack, MonadBaseControl IO (Eff e), Lifted IO e)- => (LogMessage -> Text) -- ^ 'LogMessage' rendering function- -> String -- ^ Hostname or IP- -> String -- ^ Port e.g. @"514"@- -> Text -- ^ The default application name to put into the 'lmAppName' field.- -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.- -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"- -> Eff (Logs : LogWriterReader : e) a- -> Eff e a-withUDPLogging render hostname port a f p e = liftBaseOp- (withUDPSocket render hostname port)- (\lw -> withRichLogging lw a f p e)-+withUDPLogging ::+ (MonadBaseControl IO (Eff e), Lifted IO e) =>+ -- | 'LogEvent' rendering function+ (LogEvent -> Text) ->+ -- | Hostname or IP+ String ->+ -- | Port e.g. @"514"@+ String ->+ -- | The default application name to put into the 'logEventAppName' field.+ String ->+ -- | The default RFC-5424 facility to put into the 'logEventFacility' field.+ Facility ->+ -- | The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+ LogPredicate ->+ Eff (Logs : LogWriterReader : e) a ->+ Eff e a+withUDPLogging render hostname port a f p e =+ liftBaseOp+ (withUDPSocket render hostname port)+ (\lw -> withRichLogging lw a f p e) -- | Enable logging to a (remote-) host via UDP. -- -- See 'Control.Eff.Log.Examples.exampleUdpRFC3164Logging'-withUDPLogWriter- :: (IoLogging e, MonadBaseControl IO (Eff e), HasCallStack)- => (LogMessage -> Text) -- ^ 'LogMessage' rendering function- -> String -- ^ Hostname or IP- -> String -- ^ Port e.g. @"514"@- -> Eff e b- -> Eff e b+withUDPLogWriter ::+ (IoLogging e, MonadBaseControl IO (Eff e)) =>+ -- | 'LogEvent' rendering function+ (LogEvent -> Text) ->+ -- | Hostname or IP+ String ->+ -- | Port e.g. @"514"@+ String ->+ Eff e b ->+ Eff e b withUDPLogWriter render hostname port e = liftBaseOp (withUDPSocket render hostname port) (`addLogWriter` e) --withUDPSocket- :: HasCallStack- => (LogMessage -> Text) -- ^ 'LogMessage' rendering function- -> String -- ^ Hostname or IP- -> String -- ^ Port e.g. @"514"@- -> (LogWriter -> IO a)- -> IO a-withUDPSocket render hostname port ioE = Safe.bracket- (do- let hints = defaultHints { addrSocketType = Datagram }- addr : _ <- getAddrInfo (Just hints) (Just hostname) (Just port)- s <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)- return (addr, s)- )- (Safe.try @IO @Catch.SomeException . close . snd)- (\(a, s) ->- let addr = addrAddress a- in- ioE- (MkLogWriter- (\lmStr ->- void $ sendTo s (T.encodeUtf8 (render lmStr)) addr- )- )- )+withUDPSocket ::+ -- | 'LogEvent' rendering function+ (LogEvent -> Text) ->+ -- | Hostname or IP+ String ->+ -- | Port e.g. @"514"@+ String ->+ (LogWriter -> IO a) ->+ IO a+withUDPSocket render hostname port ioE =+ Safe.bracket+ ( do+ let hints = Network.defaultHints {Network.addrSocketType = Network.Datagram}+ addr : _ <- Network.getAddrInfo (Just hints) (Just hostname) (Just port)+ s <-+ Network.socket+ (Network.addrFamily addr)+ (Network.addrSocketType addr)+ (Network.addrProtocol addr)+ return (addr, s)+ )+ (Safe.try @IO @Catch.SomeException . Network.close . snd)+ ( \(a, s) ->+ let addr = Network.addrAddress a+ in ioE+ ( MkLogWriter+ ( \lmStr ->+ void $ sendTo s (T.encodeUtf8 (render lmStr)) addr+ )+ )+ )
src/Control/Eff/LogWriter/UnixSocket.hs view
@@ -1,70 +1,79 @@ -- | This helps to setup logging to /standard ouput/. module Control.Eff.LogWriter.UnixSocket- ( withUnixSocketLogWriter- , withUnixSocketLogging+ ( withUnixSocketLogWriter,+ withUnixSocketLogging, ) where -import Control.Eff as Eff-import Control.Eff.Log-import Control.Eff.LogWriter.Rich-import Data.Text as T-import Data.Text.Encoding as T-import qualified Control.Exception.Safe as Safe-import Control.Monad ( void )-import qualified Control.Monad.Catch as Catch-import Control.Monad.Trans.Control ( MonadBaseControl- , liftBaseOp- )-import GHC.Stack-import Network.Socket hiding ( sendTo )-import Network.Socket.ByteString+import Control.Eff as Eff+import Control.Eff.Log+import Control.Eff.LogWriter.Rich+import qualified Control.Exception.Safe as Safe+import Control.Monad (void)+import qualified Control.Monad.Catch as Catch+import Control.Monad.Trans.Control+ ( MonadBaseControl,+ liftBaseOp,+ )+import Data.Text as T+import Data.Text.Encoding as T+import qualified Network.Socket as Net+import qualified Network.Socket.ByteString as Net --- | Enable logging to a /unix domain socket/, with some 'LogMessage' fields preset+-- | Enable logging to a /unix domain socket/, with some 'LogEvent' fields preset -- as in 'withRichLogging'. -- -- See 'Control.Eff.Log.Examples.exampleDevLogSyslogLogging'-withUnixSocketLogging- :: (HasCallStack, MonadBaseControl IO (Eff e), Lifted IO e)- => LogMessageRenderer Text -- ^ 'LogMessage' rendering function- -> FilePath -- ^ Path to the socket file- -> Text -- ^ The default application name to put into the 'lmAppName' field.- -> Facility -- ^ The default RFC-5424 facility to put into the 'lmFacility' field.- -> LogPredicate -- ^ The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"- -> Eff (Logs : LogWriterReader : e) a- -> Eff e a-withUnixSocketLogging render socketPath a f p e = liftBaseOp- (withUnixSocketSocket render socketPath)- (\lw -> withRichLogging lw a f p e)+withUnixSocketLogging ::+ (MonadBaseControl IO (Eff e), Lifted IO e) =>+ -- | 'LogEvent' rendering function+ LogEventReader Text ->+ -- | Path to the socket file+ FilePath ->+ -- | The default application name to put into the 'logEventAppName' field.+ String ->+ -- | The default RFC-5424 facility to put into the 'logEventFacility' field.+ Facility ->+ -- | The inital predicate for log messages, there are some pre-defined in "Control.Eff.Log.Message#PredefinedPredicates"+ LogPredicate ->+ Eff (Logs : LogWriterReader : e) a ->+ Eff e a+withUnixSocketLogging render socketPath a f p e =+ liftBaseOp+ (withUnixSocketSocket render socketPath)+ (\lw -> withRichLogging lw a f p e) -- | Enable logging to a (remote-) host via UnixSocket. -- -- See 'Control.Eff.Log.Examples.exampleDevLogSyslogLogging'-withUnixSocketLogWriter- :: (IoLogging e, MonadBaseControl IO (Eff e), HasCallStack)- => LogMessageRenderer Text -- ^ 'LogMessage' rendering function- -> FilePath -- ^ Path to the socket file- -> Eff e b- -> Eff e b+withUnixSocketLogWriter ::+ (IoLogging e, MonadBaseControl IO (Eff e)) =>+ -- | 'LogEvent' rendering function+ LogEventReader Text ->+ -- | Path to the socket file+ FilePath ->+ Eff e b ->+ Eff e b withUnixSocketLogWriter render socketPath e = liftBaseOp (withUnixSocketSocket render socketPath) (`addLogWriter` e) -withUnixSocketSocket- :: HasCallStack- => LogMessageRenderer Text -- ^ 'LogMessage' rendering function- -> FilePath -- ^ Path to the socket file- -> (LogWriter -> IO a)- -> IO a-withUnixSocketSocket render socketPath ioE = Safe.bracket- (socket AF_UNIX Datagram defaultProtocol)- (Safe.try @IO @Catch.SomeException . close)- (\s ->- let addr = SockAddrUnix socketPath- in- ioE- (MkLogWriter- (\lmStr ->- void $ sendTo s (T.encodeUtf8 (render lmStr)) addr- )- )- )+withUnixSocketSocket ::+ -- | 'LogEvent' rendering function+ LogEventReader Text ->+ -- | Path to the socket file+ FilePath ->+ (LogWriter -> IO a) ->+ IO a+withUnixSocketSocket render socketPath ioE =+ Safe.bracket+ (Net.socket Net.AF_UNIX Net.Datagram Net.defaultProtocol)+ (Safe.try @IO @Catch.SomeException . Net.close)+ ( \s ->+ let addr = Net.SockAddrUnix socketPath+ in ioE+ ( MkLogWriter+ ( \lmStr ->+ void $ Net.sendTo s (T.encodeUtf8 (render lmStr)) addr+ )+ )+ )
src/Control/Eff/Loop.hs view
@@ -18,12 +18,12 @@ -- -- @since 0.4.0.0 module Control.Eff.Loop- ( foreverCheap- , replicateCheapM_+ ( foreverCheap,+ replicateCheapM_, ) where -import Control.Monad ( void )+import Control.Monad (void) -- | A version of 'Control.Monad.forever' that hopefully tricks -- GHC into __/not/__ creating a space leak.@@ -43,11 +43,13 @@ -- @since 0.4.0.0 {-# NOINLINE replicateCheapM_ #-} replicateCheapM_ :: Monad m => Int -> m a -> m ()-replicateCheapM_ n e = if n <= 0- then return ()- else if n == 1- then void e+replicateCheapM_ n e =+ if n <= 0+ then return () else- let nL = n `div` 2- nR = n - nL- in replicateCheapM_ nL e >> replicateCheapM_ nR e+ if n == 1+ then void e+ else+ let nL = n `div` 2+ nR = n - nL+ in replicateCheapM_ nL e >> replicateCheapM_ nR e
stack.yaml view
@@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml"-resolver: lts-13.13+resolver: lts-14.7 # User packages to be built. # Various formats can be used as shown in the example below.@@ -63,4 +63,4 @@ # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor-ghc-options: {"$locals": -ddump-to-file -ddump-hi}+#ghc-options: {"$locals": -ddump-to-file -ddump-hi}
test/BrokerTests.hs view
@@ -1,367 +1,392 @@+{-# LANGUAGE NoOverloadedStrings #-}+ module BrokerTests- ( test_Broker- ) where+ ( test_Broker,+ )+where import Common-import Control.Eff.Concurrent.Protocol.EffectfulServer (Event(..))-import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful import Control.Eff.Concurrent.Protocol.Broker as Broker+import Control.Eff.Concurrent.Protocol.EffectfulServer (Event (..)) import qualified Control.Eff.Concurrent.Protocol.Observer.Queue as OQ+import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful import Control.Lens+import Data.Function (on)+import Data.String test_Broker :: HasCallStack => TestTree test_Broker = setTravisTestOptions $- testGroup- "Broker"- (let startTestBroker = startTestBrokerWith ExitWhenRequested (TimeoutMicros 500000)- startTestBrokerWith e t = Broker.startLink (MkBrokerConfig t (Stateful.Init . TestServerArgs e))- spawnTestChild broker i = Broker.spawnChild broker i >>= either (lift . assertFailure . show) pure- in [ runTestCase "The broker starts and is shut down" $ do- outerSelf <- self- testWorker <-- spawn "test-worker" $ do- broker <- startTestBroker- sendMessage outerSelf broker- () <- receiveMessage- sendMessage outerSelf ()- () <- receiveMessage- Broker.stopBroker broker- unlinkProcess testWorker- broker <- receiveMessage :: Eff Effects (Endpoint (Broker.Broker (Stateful.Stateful TestProtocol)))- brokerAliveAfter1 <- isBrokerAlive broker- logInfo ("still alive 1: " <> pack (show brokerAliveAfter1))- lift (brokerAliveAfter1 @=? True)- sendMessage testWorker ()- () <- receiveMessage- brokerAliveAfter2 <- isBrokerAlive broker- logInfo ("still alive 2: " <> pack (show brokerAliveAfter2))- lift (brokerAliveAfter2 @=? True)- sendMessage testWorker ()- testWorkerMonitorRef <- monitor testWorker- d1 <- receiveSelectedMessage (selectProcessDown testWorkerMonitorRef)- logInfo ("got test worker down: " <> pack (show d1))- testBrokerMonitorRef <- monitorBroker broker- d2 <- receiveSelectedMessage (selectProcessDown testBrokerMonitorRef)- logInfo ("got broker down: " <> pack (show d2))- brokerAliveAfterOwnerExited <- isBrokerAlive broker- logInfo ("still alive after owner exited: " <> pack (show brokerAliveAfterOwnerExited))- lift (brokerAliveAfterOwnerExited @=? False)- , testGroup- "Diagnostics"- [ runTestCase "When only time passes the diagnostics do not change" $ do- broker <- startTestBroker- info1 <- Broker.getDiagnosticInfo broker- lift (threadDelay 10000)- info2 <- Broker.getDiagnosticInfo broker- lift (assertEqual "diagnostics should not differ: " info1 info2)- , runTestCase "When a child is started the diagnostics change" $ do- broker <- startTestBroker- info1 <- Broker.getDiagnosticInfo broker- logInfo ("got diagnostics: " <> info1)- let childId = 1- _child <- fromRight (error "failed to spawn child") <$> Broker.spawnChild broker childId- info2 <- Broker.getDiagnosticInfo broker- logInfo ("got diagnostics: " <> info2)- lift $ assertBool ("diagnostics should differ: " ++ show (info1, info2)) (info1 /= info2)- ]- , let childId = 1- in testGroup- "Startup and shutdown"- [ runTestCase "When a broker is shut down, all children are shutdown" $ do- broker <- startTestBroker- child <- spawnTestChild broker childId- let childPid = _fromEndpoint child- brokerMon <- monitorBroker broker- childMon <- monitor childPid- isProcessAlive childPid >>= lift . assertBool "child process not running"- isBrokerAlive broker >>= lift . assertBool "broker process not running"- call child (TestGetStringLength "123") >>= lift . assertEqual "child not working" 3- stopBroker broker- d1@(ProcessDown mon1 er1 _) <-- fromMaybe (error "receive timeout 1") <$> receiveAfter (TimeoutMicros 1000000)- logInfo ("got process down: " <> pack (show d1))- d2@(ProcessDown mon2 er2 _) <-- fromMaybe (error "receive timeout 2") <$> receiveAfter (TimeoutMicros 1000000)- logInfo ("got process down: " <> pack (show d2))- case if mon1 == brokerMon && mon2 == childMon- then Right (er1, er2)- else if mon1 == childMon && mon2 == brokerMon- then Right (er2, er1)- else Left- ("unexpected monitor down: first: " <> show (mon1, er1) <> ", and then: " <>- show (mon2, er2) <>- ", brokerMon: " <>- show brokerMon <>- ", childMon: " <>- show childMon) of- Right (brokerER, childER) -> do- lift (assertEqual "bad broker exit reason" ExitNormally brokerER)- lift (assertEqual "bad child exit reason" ExitNormally childER)- Left x -> lift (assertFailure x)- , runTestCase- "When a broker is shut down, children that won't shutdown, are killed after some time" $ do- broker <- startTestBrokerWith IgnoreNormalExitRequest (TimeoutMicros 10000)- child <- spawnTestChild broker childId- let childPid = _fromEndpoint child- brokerMon <- monitorBroker broker- childMon <- monitor childPid- isProcessAlive childPid >>= lift . assertBool "child process not running"- isBrokerAlive broker >>= lift . assertBool "broker process not running"- call child (TestGetStringLength "123") >>= lift . assertEqual "child not working" 3- stopBroker broker- d1@(ProcessDown mon1 er1 _) <-- fromMaybe (error "receive timeout 1") <$> receiveAfter (TimeoutMicros 1000000)- logInfo ("got process down: " <> pack (show d1))- d2@(ProcessDown mon2 er2 _) <-- fromMaybe (error "receive timeout 2") <$> receiveAfter (TimeoutMicros 1000000)- logInfo ("got process down: " <> pack (show d2))- case if mon1 == brokerMon && mon2 == childMon+ testGroup+ "Broker"+ ( let startTestBroker = startTestBrokerWith ExitWhenRequested (TimeoutMicros 500000)+ startTestBrokerWith e t = Broker.startLink (MkBrokerConfig t (Stateful.Init . TestServerArgs e))+ spawnTestChild broker i = Broker.spawnChild broker i >>= either (lift . assertFailure . show . toLogMsg) pure+ in [ runTestCase "The broker starts and is shut down" $ do+ outerSelf <- self+ testWorker <-+ spawn (fromString "test-worker") $ do+ broker <- startTestBroker+ sendMessage outerSelf broker+ () <- receiveMessage+ sendMessage outerSelf ()+ () <- receiveMessage+ Broker.stopBroker broker+ unlinkProcess testWorker+ broker <- receiveMessage :: Eff Effects (Endpoint (Broker.Broker (Stateful.Stateful TestProtocol)))+ brokerAliveAfter1 <- isBrokerAlive broker+ logInfo (LABEL "still alive 1" brokerAliveAfter1)+ lift (brokerAliveAfter1 @=? True)+ sendMessage testWorker ()+ () <- receiveMessage+ brokerAliveAfter2 <- isBrokerAlive broker+ logInfo (LABEL "still alive 2" brokerAliveAfter2)+ lift (brokerAliveAfter2 @=? True)+ sendMessage testWorker ()+ testWorkerMonitorRef <- monitor testWorker+ d1 <- receiveSelectedMessage (selectProcessDown testWorkerMonitorRef)+ logInfo (LABEL "got test worker down" d1)+ testBrokerMonitorRef <- monitorBroker broker+ d2 <- receiveSelectedMessage (selectProcessDown testBrokerMonitorRef)+ logInfo (LABEL "got broker down" d2)+ brokerAliveAfterOwnerExited <- isBrokerAlive broker+ logInfo (LABEL "still alive after owner exited" brokerAliveAfterOwnerExited)+ lift (brokerAliveAfterOwnerExited @=? False),+ testGroup+ "Diagnostics"+ [ runTestCase "When only time passes the diagnostics do not change" $ do+ broker <- startTestBroker+ info1 <- Broker.getDiagnosticInfo broker+ lift (threadDelay 10000)+ info2 <- Broker.getDiagnosticInfo broker+ lift (assertEqual "diagnostics should not differ: " info1 info2),+ runTestCase "When a child is started the diagnostics change" $ do+ broker <- startTestBroker+ info1 <- Broker.getDiagnosticInfo broker+ logInfo (LABEL "got diagnostics" info1)+ let childId = 1+ _child <- fromRight (error "failed to spawn child") <$> Broker.spawnChild broker childId+ info2 <- Broker.getDiagnosticInfo broker+ logInfo (LABEL "got diagnostics" info2)+ lift $ assertBool ("diagnostics should differ: " ++ show (info1, info2)) (info1 /= info2)+ ],+ let childId = 1+ in testGroup+ "Startup and shutdown"+ [ runTestCase "When a broker is shut down, all children are shutdown" $ do+ broker <- startTestBroker+ child <- spawnTestChild broker childId+ let childPid = _fromEndpoint child+ brokerMon <- monitorBroker broker+ childMon <- monitor childPid+ isProcessAlive childPid >>= lift . assertBool "child process not running"+ isBrokerAlive broker >>= lift . assertBool "broker process not running"+ call child (TestGetStringLength "123") >>= lift . assertEqual "child not working" 3+ stopBroker broker+ d1@(ProcessDown mon1 er1 _) <-+ fromMaybe (error "receive timeout 1") <$> receiveAfter (TimeoutMicros 1000000)+ logInfo (LABEL "got process down" d1)+ d2@(ProcessDown mon2 er2 _) <-+ fromMaybe (error "receive timeout 2") <$> receiveAfter (TimeoutMicros 1000000)+ logInfo (LABEL "got process down" d2)+ case if mon1 == brokerMon && mon2 == childMon+ then Right (er1, er2)+ else+ if mon1 == childMon && mon2 == brokerMon+ then Right (er2, er1)+ else+ Left+ ( packLogMsg "unexpected monitor down: first: "+ <> toLogMsg (mon1, er1)+ <> packLogMsg ", and then: "+ <> toLogMsg (mon2, er2)+ <> packLogMsg ", brokerMon: "+ <> toLogMsg brokerMon+ <> packLogMsg ", childMon: "+ <> toLogMsg childMon+ ) of+ Right (brokerER, childER) -> do+ lift (assertEqual "bad broker exit reason" ExitNormally brokerER)+ lift (assertEqual "bad child exit reason" ExitNormally childER)+ Left x -> lift (assertFailure (show x)),+ runTestCase+ "When a broker is shut down, children that won't shutdown, are killed after some time"+ $ do+ broker <- startTestBrokerWith IgnoreNormalExitRequest (TimeoutMicros 10000)+ child <- spawnTestChild broker childId+ let childPid = _fromEndpoint child+ brokerMon <- monitorBroker broker+ childMon <- monitor childPid+ isProcessAlive childPid >>= lift . assertBool "child process not running"+ isBrokerAlive broker >>= lift . assertBool "broker process not running"+ call child (TestGetStringLength "123") >>= lift . assertEqual "child not working" 3+ stopBroker broker+ d1@(ProcessDown mon1 er1 _) <-+ fromMaybe (error "receive timeout 1") <$> receiveAfter (TimeoutMicros 1000000)+ logInfo (LABEL "got process down" d1)+ d2@(ProcessDown mon2 er2 _) <-+ fromMaybe (error "receive timeout 2") <$> receiveAfter (TimeoutMicros 1000000)+ logInfo (LABEL "got process down" d2)+ case if mon1 == brokerMon && mon2 == childMon then Right er1- else if mon1 == childMon && mon2 == brokerMon- then Right er2- else Left- ("unexpected monitor down: first: " <> show (mon1, er1) <> ", and then: " <>- show (mon2, er2) <>- ", brokerMon: " <>- show brokerMon <>- ", childMon: " <>- show childMon) of- Right brokerER -> do- lift (assertEqual "bad broker exit reason" ExitNormally brokerER)- Left x -> lift (assertFailure x)- ]- , let i = 123- in testGroup- "Spawning and Using Children"- [ runTestCase- "When a broker is requested to start two children with the same id, an already started error is returned" $ do- broker <- startTestBroker- c <- spawnTestChild broker i- x <- Broker.spawnChild broker i- case x of- Left (AlreadyStarted i' c') ->- lift $ do- assertEqual "bad pid returned" c c'- assertEqual "bad child id returned" 123 i'- _ -> lift (assertFailure "AlreadyStarted expected!")- , runTestCase "When a child is started it can be lookup up" $ do- broker <- startTestBroker- c <- spawnTestChild broker i- c' <- Broker.lookupChild broker i >>= maybe (lift (assertFailure "child not found")) pure- lift (assertEqual "lookupChild returned wrong child" c c')- , runTestCase "When several children are started they can be lookup up and don't crash" $ do- broker <- startTestBroker- c <- spawnTestChild broker i- someOtherChild <- spawnTestChild broker (i + 1)- c' <- Broker.lookupChild broker i >>= maybe (lift (assertFailure "child not found")) pure- lift (assertEqual "lookupChild returned wrong child" c c')- childStillRunning <- isProcessAlive (_fromEndpoint c)- lift (assertBool "child not running" childStillRunning)- someOtherChildStillRunning <- isProcessAlive (_fromEndpoint someOtherChild)- lift (assertBool "someOtherChild not running" someOtherChildStillRunning)- , let startTestBrokerAndChild = do- broker <- startTestBroker- c <- spawnTestChild broker i- cm <- monitor (_fromEndpoint c)- return (broker, cm)- in testGroup- "Stopping children"- [ runTestCase "When a child is started it can be stopped" $ do- (broker, cm) <- startTestBrokerAndChild- Broker.stopChild broker i >>= lift . assertBool "child not found"- (ProcessDown _ r _) <- receiveSelectedMessage (selectProcessDown cm)- lift (assertEqual "bad exit reason" ExitNormally r)- , runTestCase- "When a child is stopped but doesn't exit voluntarily, it is kill after some time" $ do- broker <- startTestBrokerWith IgnoreNormalExitRequest (TimeoutMicros 5000)- c <- spawnTestChild broker i- cm <- monitor (_fromEndpoint c)- Broker.stopChild broker i >>= lift . assertBool "child not found"- (ProcessDown _ r _) <- receiveSelectedMessage (selectProcessDown cm)- case r of- ExitUnhandledError _ -> return ()- _ -> lift (assertFailure ("bad exit reason: " ++ show r))- , runTestCase "When a stopChild is called with an unallocated ID, False is returned" $ do- (broker, _) <- startTestBrokerAndChild- Broker.stopChild broker (i + 1) >>= lift . assertBool "child not found" . not- , runTestCase "When a child is stopped, lookup won't find it" $ do- (broker, _) <- startTestBrokerAndChild- Broker.stopChild broker i >>= lift . assertBool "child not found"- x <- Broker.lookupChild broker i- lift (assertEqual "lookup should not find a child" Nothing x)- , runTestCase "When a child is stopped, the child id can be reused" $ do- (broker, _) <- startTestBrokerAndChild- Broker.stopChild broker i >>= lift . assertBool "child not found"- Broker.spawnChild broker i >>= lift . assertBool "id could not be reused" . isRight- ]- , let startTestBrokerAndChild = do- broker <- startTestBroker- c <- spawnTestChild broker i- cm <- monitor (_fromEndpoint c)- return (broker, c, cm)- in testGroup- "Child exit handling"- [ runTestCase "When a child exits normally, lookupChild will not find it" $ do- (broker, c, cm) <- startTestBrokerAndChild- cast c (TestInterruptWith NormalExitRequested)- (ProcessDown _ r _) <- receiveSelectedMessage (selectProcessDown cm)- lift (assertEqual "bad exit reason" ExitNormally r)- x <- Broker.lookupChild broker i- lift (assertEqual "lookup should not find a child" Nothing x)- , runTestCase "When a child exits with an error, lookupChild will not find it" $ do- (broker, c, cm) <- startTestBrokerAndChild- cast c (TestInterruptWith (ErrorInterrupt "test error reason"))- (ProcessDown _ _ _) <- receiveSelectedMessage (selectProcessDown cm)- x <- Broker.lookupChild broker i- lift (assertEqual "lookup should not find a child" Nothing x)- , runTestCase "When a child is interrupted from another process and dies, lookupChild will not find it" $ do- (broker, c, cm) <- startTestBrokerAndChild- sendInterrupt (_fromEndpoint c) NormalExitRequested- (ProcessDown _ _ _) <- receiveSelectedMessage (selectProcessDown cm)- x <- Broker.lookupChild broker i- lift (assertEqual "lookup should not find a child" Nothing x)- , runTestCase "When a child is shutdown from another process and dies, lookupChild will not find it" $ do- (broker, c, cm) <- startTestBrokerAndChild- self >>= sendShutdown (_fromEndpoint c) . ExitProcessCancelled . Just- (ProcessDown _ _ _) <- receiveSelectedMessage (selectProcessDown cm)- x <- Broker.lookupChild broker i- lift (assertEqual "lookup should not find a child" Nothing x)- ]- , testGroup "broker events"- [ runTestCase "when a child starts the observer is notified" $ do- broker <- startTestBroker- OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (100 :: Int) broker $ do- c <- Broker.spawnChild @(Stateful.Stateful TestProtocol) broker i >>= either (lift . assertFailure . show) pure- e <- OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))- case e of- Broker.OnChildSpawned broker' i' c' -> do- lift (assertEqual "wrong endpoint" broker broker')- lift (assertEqual "wrong child" c c')- lift (assertEqual "wrong child-id" i i')- _ ->- lift (assertFailure ("unexpected event: " ++ show e))- , runTestCase "when a child stops the observer is notified" $ do- broker <- startTestBroker- c <- Broker.spawnChild @(Stateful.Stateful TestProtocol) broker i >>= either (lift . assertFailure . show) pure- OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (100 :: Int) broker $ do- Broker.stopChild broker i >>= lift . assertBool "child not found"- OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))- >>= \case- Broker.OnChildDown broker' i' c' e -> do- lift (assertEqual "wrong endpoint" broker broker')- lift (assertEqual "wrong child" c c')- lift (assertEqual "wrong child-id" i i')- lift (assertEqual "wrong exit reason" ExitNormally e)- e ->- lift (assertFailure ("unexpected event: " ++ show e))-- , runTestCase "when a child crashes the observer is notified" $ do- broker <- startTestBroker- OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (100 :: Int) broker $ do- c <- Broker.spawnChild @(Stateful.Stateful TestProtocol) broker i >>= either (lift . assertFailure . show) pure- let expectedError = ExitUnhandledError "test error"- sendShutdown (_fromEndpoint c) expectedError- OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))- >>= \case- Broker.OnChildSpawned broker' i' c' -> do- lift (assertEqual "wrong endpoint" broker broker')- lift (assertEqual "wrong child" c c')- lift (assertEqual "wrong child-id" i i')- e ->- lift (assertFailure ("unexpected event: " ++ show e))- OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))- >>= \case- Broker.OnChildDown broker' i' c' e -> do- lift (assertEqual "wrong endpoint" broker broker')- lift (assertEqual "wrong child" c c')- lift (assertEqual "wrong child-id" i i')- lift (assertEqual "wrong exit reason" expectedError e)- e ->- lift (assertFailure ("unexpected event: " ++ show e))- , runTestCase "when a child does not stop when requested and is killed, the oberser is notified correspondingly" $ do- broker <- startTestBrokerWith IgnoreNormalExitRequest (TimeoutMicros 5000)- c <- spawnTestChild broker i- OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (100 :: Int) broker $ do- cm <- monitor (_fromEndpoint c)- Broker.stopChild broker i >>= lift . assertBool "child not found"- (ProcessDown _ expectedError _) <- receiveSelectedMessage (selectProcessDown cm)- OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))- >>= \case- Broker.OnChildDown broker' i' c' e -> do- lift (assertEqual "wrong endpoint" broker broker')- lift (assertEqual "wrong child" c c')- lift (assertEqual "wrong child-id" i i')- lift (assertEqual "wrong exit reason" expectedError e)- e ->- lift (assertFailure ("unexpected event: " ++ show e))-- , runTestCase "when the broker stops, an OnBrokerShuttingDown is emitted before any child is stopped" $ do- broker <- startTestBroker- unlinkProcess (broker ^. fromEndpoint)- void (Broker.spawnChild @(Stateful.Stateful TestProtocol) broker i- >>= either (lift . assertFailure . show) pure)- OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (1000 :: Int) broker $ do- Broker.stopBroker broker- OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))- >>= \case- Broker.OnBrokerShuttingDown _ -> logNotice "received OnBrokerShuttingDown"- e ->- lift (assertFailure ("unexpected event: " ++ show e))- OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))- >>= \case+ else+ if mon1 == childMon && mon2 == brokerMon+ then Right er2+ else+ Left+ ( "unexpected monitor down: first: " <> show (mon1, er1) <> ", and then: "+ <> show (mon2, er2)+ <> ", brokerMon: "+ <> show brokerMon+ <> ", childMon: "+ <> show childMon+ ) of+ Right brokerER -> do+ lift (assertEqual "bad broker exit reason" ExitNormally brokerER)+ Left x -> lift (assertFailure x)+ ],+ let i = 123+ in testGroup+ "Spawning and Using Children"+ [ runTestCase+ "When a broker is requested to start two children with the same id, an already started error is returned"+ $ do+ broker <- startTestBroker+ c <- spawnTestChild broker i+ x <- Broker.spawnChild broker i+ case x of+ Left (AlreadyStarted i' c') ->+ lift $ do+ ((assertEqual "bad pid returned") `on` (show . toLogMsg)) c c'+ assertEqual "bad child id returned" 123 i'+ _ -> lift (assertFailure "AlreadyStarted expected!"),+ runTestCase "When a child is started it can be lookup up" $ do+ broker <- startTestBroker+ c <- spawnTestChild broker i+ c' <- Broker.lookupChild broker i >>= maybe (lift (assertFailure "child not found")) pure+ lift (((assertEqual "lookupChild returned wrong child") `on` (show . toLogMsg)) c c'),+ runTestCase "When several children are started they can be lookup up and don't crash" $ do+ broker <- startTestBroker+ c <- spawnTestChild broker i+ someOtherChild <- spawnTestChild broker (i + 1)+ c' <- Broker.lookupChild broker i >>= maybe (lift (assertFailure "child not found")) pure+ lift (((assertEqual "lookupChild returned wrong child") `on` (show . toLogMsg)) c c')+ childStillRunning <- isProcessAlive (_fromEndpoint c)+ lift (assertBool "child not running" childStillRunning)+ someOtherChildStillRunning <- isProcessAlive (_fromEndpoint someOtherChild)+ lift (assertBool "someOtherChild not running" someOtherChildStillRunning),+ let startTestBrokerAndChild = do+ broker <- startTestBroker+ c <- spawnTestChild broker i+ cm <- monitor (_fromEndpoint c)+ return (broker, cm)+ in testGroup+ "Stopping children"+ [ runTestCase "When a child is started it can be stopped" $ do+ (broker, cm) <- startTestBrokerAndChild+ Broker.stopChild broker i >>= lift . assertBool "child not found"+ (ProcessDown _ r _) <- receiveSelectedMessage (selectProcessDown cm)+ lift (assertEqual "bad exit reason" ExitNormally r),+ runTestCase+ "When a child is stopped but doesn't exit voluntarily, it is kill after some time"+ $ do+ broker <- startTestBrokerWith IgnoreNormalExitRequest (TimeoutMicros 5000)+ c <- spawnTestChild broker i+ cm <- monitor (_fromEndpoint c)+ Broker.stopChild broker i >>= lift . assertBool "child not found"+ (ProcessDown _ r _) <- receiveSelectedMessage (selectProcessDown cm)+ case r of+ ExitUnhandledError _ -> return ()+ _ -> lift (assertFailure ("bad exit reason: " ++ show r)),+ runTestCase "When a stopChild is called with an unallocated ID, False is returned" $ do+ (broker, _) <- startTestBrokerAndChild+ Broker.stopChild broker (i + 1) >>= lift . assertBool "child not found" . not,+ runTestCase "When a child is stopped, lookup won't find it" $ do+ (broker, _) <- startTestBrokerAndChild+ Broker.stopChild broker i >>= lift . assertBool "child not found"+ x <- Broker.lookupChild broker i+ lift ((assertEqual "lookup should not find a child" `on` (show . toLogMsg)) Nothing x),+ runTestCase "When a child is stopped, the child id can be reused" $ do+ (broker, _) <- startTestBrokerAndChild+ Broker.stopChild broker i >>= lift . assertBool "child not found"+ Broker.spawnChild broker i >>= lift . assertBool "id could not be reused" . isRight+ ],+ let startTestBrokerAndChild = do+ broker <- startTestBroker+ c <- spawnTestChild broker i+ cm <- monitor (_fromEndpoint c)+ return (broker, c, cm)+ in testGroup+ "Child exit handling"+ [ runTestCase "When a child exits normally, lookupChild will not find it" $ do+ (broker, c, cm) <- startTestBrokerAndChild+ cast c (TestInterruptWith NormalExitRequested)+ (ProcessDown _ r _) <- receiveSelectedMessage (selectProcessDown cm)+ lift (assertEqual "bad exit reason" ExitNormally r)+ x <- Broker.lookupChild broker i+ lift ((assertEqual "lookup should not find a child" `on` (show . toLogMsg)) Nothing x),+ runTestCase "When a child exits with an error, lookupChild will not find it" $ do+ (broker, c, cm) <- startTestBrokerAndChild+ cast c (TestInterruptWith (ErrorInterrupt (fromString "test error reason")))+ (ProcessDown _ _ _) <- receiveSelectedMessage (selectProcessDown cm)+ x <- Broker.lookupChild broker i+ lift ((assertEqual "lookup should not find a child" `on` (show . toLogMsg)) Nothing x),+ runTestCase "When a child is interrupted from another process and dies, lookupChild will not find it" $ do+ (broker, c, cm) <- startTestBrokerAndChild+ sendInterrupt (_fromEndpoint c) NormalExitRequested+ (ProcessDown _ _ _) <- receiveSelectedMessage (selectProcessDown cm)+ x <- Broker.lookupChild broker i+ lift ((assertEqual "lookup should not find a child" `on` (show . toLogMsg)) Nothing x),+ runTestCase "When a child is shutdown from another process and dies, lookupChild will not find it" $ do+ (broker, c, cm) <- startTestBrokerAndChild+ self >>= sendShutdown (_fromEndpoint c) . ExitProcessCancelled . Just+ (ProcessDown _ _ _) <- receiveSelectedMessage (selectProcessDown cm)+ x <- Broker.lookupChild broker i+ lift ((assertEqual "lookup should not find a child" `on` (show . toLogMsg)) Nothing x)+ ],+ testGroup+ "broker events"+ [ runTestCase "when a child starts the observer is notified" $ do+ broker <- startTestBroker+ OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (100 :: Int) broker $ do+ c <- Broker.spawnChild @(Stateful.Stateful TestProtocol) broker i >>= either (lift . assertFailure . show . toLogMsg) pure+ e <- OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))+ lift $ case e of+ Broker.OnChildSpawned broker' i' c' -> do+ ((assertEqual "wrong endpoint") `on` (show . toLogMsg)) broker broker'+ ((assertEqual "wrong child") `on` (show . toLogMsg)) c c'+ assertEqual "wrong child-id" i i'+ _ ->+ assertFailure ("unexpected event: " ++ show (toLogMsg e)),+ runTestCase "when a child stops the observer is notified" $ do+ broker <- startTestBroker+ c <- Broker.spawnChild @(Stateful.Stateful TestProtocol) broker i >>= either (lift . assertFailure . show . toLogMsg) pure+ OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (100 :: Int) broker $ do+ Broker.stopChild broker i >>= lift . assertBool "child not found"+ OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))+ >>= \case+ Broker.OnChildDown broker' i' c' e -> lift $ do+ ((assertEqual "wrong endpoint") `on` (show . toLogMsg)) broker broker'+ ((assertEqual "wrong child") `on` (show . toLogMsg)) c c'+ assertEqual "wrong child-id" i i'+ assertEqual "wrong exit reason" ExitNormally e+ e ->+ lift (assertFailure ("unexpected event: " ++ show (toLogMsg e))),+ runTestCase "when a child crashes the observer is notified" $ do+ broker <- startTestBroker+ OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (100 :: Int) broker $ do+ c <- Broker.spawnChild @(Stateful.Stateful TestProtocol) broker i >>= either (lift . assertFailure . show . toLogMsg) pure+ let expectedError = ExitUnhandledError (fromString "test error")+ sendShutdown (_fromEndpoint c) expectedError+ OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))+ >>= \case+ Broker.OnChildSpawned broker' i' c' -> lift $ do+ ((assertEqual "wrong endpoint") `on` (show . toLogMsg)) broker broker'+ ((assertEqual "wrong child") `on` (show . toLogMsg)) c c'+ assertEqual "wrong child-id" i i'+ e ->+ lift (assertFailure ("unexpected event: " ++ show (toLogMsg e)))+ OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))+ >>= \case+ Broker.OnChildDown broker' i' c' e -> lift $ do+ ((assertEqual "wrong endpoint") `on` (show . toLogMsg)) broker broker'+ ((assertEqual "wrong child") `on` (show . toLogMsg)) c c'+ assertEqual "wrong child-id" i i'+ assertEqual "wrong exit reason" expectedError e+ e ->+ lift (assertFailure ("unexpected event: " ++ show (toLogMsg e))),+ runTestCase "when a child does not stop when requested and is killed, the oberser is notified correspondingly" $ do+ broker <- startTestBrokerWith IgnoreNormalExitRequest (TimeoutMicros 5000)+ c <- spawnTestChild broker i+ OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (100 :: Int) broker $ do+ cm <- monitor (_fromEndpoint c)+ Broker.stopChild broker i >>= lift . assertBool "child not found"+ (ProcessDown _ expectedError _) <- receiveSelectedMessage (selectProcessDown cm)+ OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))+ >>= \case+ Broker.OnChildDown broker' i' c' e -> lift $ do+ ((assertEqual "wrong endpoint") `on` (show . toLogMsg)) broker broker'+ ((assertEqual "wrong child") `on` (show . toLogMsg)) c c'+ assertEqual "wrong child-id" i i'+ assertEqual "wrong exit reason" expectedError e+ e ->+ lift (assertFailure ("unexpected event: " ++ show (toLogMsg e))),+ runTestCase "when the broker stops, an OnBrokerShuttingDown is emitted before any child is stopped" $ do+ broker <- startTestBroker+ unlinkProcess (broker ^. fromEndpoint)+ void+ ( Broker.spawnChild @(Stateful.Stateful TestProtocol) broker i+ >>= either (lift . assertFailure . show . toLogMsg) pure+ )+ OQ.observe @(Broker.ChildEvent (Stateful.Stateful TestProtocol)) (1000 :: Int) broker $ do+ Broker.stopBroker broker+ OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))+ >>= \case+ Broker.OnBrokerShuttingDown _ -> logNotice "received OnBrokerShuttingDown"+ e ->+ lift (assertFailure ("unexpected event: " ++ show (toLogMsg e)))+ OQ.await @(Broker.ChildEvent (Stateful.Stateful TestProtocol))+ >>= \case Broker.OnChildDown _ _ _ e -> lift (assertEqual "wrong exit reason" ExitNormally e) e ->- lift (assertFailure ("unexpected event: " ++ show e))+ lift (assertFailure ("unexpected event: " ++ show (toLogMsg e)))+ ] ]- ]- ])+ ]+ ) -data TestProtocol- deriving (Typeable)+data TestProtocol deriving (Typeable) -type instance ToPretty TestProtocol = PutStr "test"+instance ToTypeLogMsg TestProtocol where+ toTypeLogMsg _ = fromString "TestProtocol" instance HasPdu TestProtocol where- data instance Pdu TestProtocol x where+ data Pdu TestProtocol x where TestGetStringLength :: String -> Pdu TestProtocol ('Synchronous Int)- TestInterruptWith :: Interrupt 'Recoverable -> Pdu TestProtocol 'Asynchronous- deriving Typeable+ TestInterruptWith :: InterruptReason -> Pdu TestProtocol 'Asynchronous+ deriving (Typeable) instance NFData (Pdu TestProtocol x) where rnf (TestGetStringLength x) = rnf x rnf (TestInterruptWith x) = rnf x -instance Show (Pdu TestProtocol r) where- show (TestGetStringLength s) = "TestGetStringLength " ++ show s- show (TestInterruptWith s) = "TestInterruptWith " ++ show s+instance ToLogMsg (Pdu TestProtocol r) where+ toLogMsg (TestGetStringLength s) = packLogMsg "TestGetStringLength " <> toLogMsg s+ toLogMsg (TestInterruptWith s) = packLogMsg "TestInterruptWith " <> toLogMsg s data TestProtocolServerMode = IgnoreNormalExitRequest | ExitWhenRequested- deriving Eq+ deriving (Eq) instance Stateful.Server TestProtocol Effects where- newtype instance Model TestProtocol = TestProtocolModel () deriving Default+ newtype Model TestProtocol = TestProtocolModel () deriving (Default) update _me (TestServerArgs testMode tId) evt = case evt of OnCast (TestInterruptWith i) -> do- logInfo (pack (show tId) <> ": stopping with: " <> pack (show i))+ logInfo tId (LABEL "stopping with" i) interrupt i OnCall rt (TestGetStringLength str) -> do- logInfo (pack (show tId) <> ": calculating length of: " <> pack str)+ logInfo tId (LABEL "calculating length of" str) sendReply rt (length str) OnInterrupt x -> do- logNotice (pack (show tId) <> ": " <> pack (show x))+ logNotice tId (LABEL "interrupt" x) if testMode == IgnoreNormalExitRequest- then- logNotice $ pack (show tId) <> ": ignoring normal exit request"+ then logNotice tId "ignoring normal exit request" else do- logNotice $ pack (show tId) <> ": exitting normally"+ logNotice tId "exitting normally" exitBecause (interruptToExit x) _ ->- logDebug (pack (show tId) <> ": got some info: " <> pack (show evt))- data instance StartArgument TestProtocol = TestServerArgs TestProtocolServerMode Int+ logDebug tId (LABEL "got some info" evt)+ data StartArgument TestProtocol = TestServerArgs TestProtocolServerMode Int type instance ChildId TestProtocol = Int +instance ToLogMsg (StartArgument TestProtocol) where+ toLogMsg (TestServerArgs mode x) =+ packLogMsg "TestProtocol-" <> packLogMsg modeMsg <> packLogMsg "-" <> toLogMsg x+ where+ modeMsg =+ case mode of+ IgnoreNormalExitRequest -> "IgnoreNormalExitRequest"+ ExitWhenRequested -> "ExitWhenRequested"
test/Common.hs view
@@ -1,58 +1,56 @@ module Common- ( module Common- , module Test.Tasty- , module Test.Tasty.HUnit- , module Test.Tasty.Runners- , module Control.Eff.Extend- , module Control.Monad- , module GHC.Stack- , module Control.Concurrent- , module Control.Concurrent.STM- , module Control.DeepSeq- , module Control.Eff- , module Control.Eff.Concurrent- , module Control.Eff.Concurrent.Misc- , module Data.Default- , module Data.Foldable- , module Data.Typeable- , module Data.Text- , module Data.Either- , module Data.Maybe- , module Data.Type.Pretty+ ( module Common,+ module Test.Tasty,+ module Test.Tasty.HUnit,+ module Test.Tasty.Runners,+ module Control.Eff.Extend,+ module Control.Monad,+ module GHC.Stack,+ module Control.Concurrent,+ module Control.Concurrent.STM,+ module Control.DeepSeq,+ module Control.Eff,+ module Control.Eff.Concurrent,+ module Data.Default,+ module Data.Foldable,+ module Data.Typeable,+ module Data.Text,+ module Data.Either,+ module Data.Maybe, ) where -import Control.Concurrent-import Control.Concurrent.STM-import Control.DeepSeq-import Control.Eff+import Control.Concurrent+import Control.Concurrent.STM+import Control.DeepSeq+import Control.Eff --import Control.Eff.Log-import Control.Eff.Concurrent-import Control.Eff.Concurrent.Misc-import Control.Eff.Concurrent.Process.ForkIOScheduler- as Scheduler-import Control.Eff.Extend-import Control.Monad-import Data.Default-import Data.Foldable-import Data.Text ( Text- , pack- )-import Data.Typeable hiding ( cast )-import GHC.Stack-import Test.Tasty hiding ( Timeout- , defaultMain- )-import qualified Test.Tasty as Tasty-import Test.Tasty.HUnit-import Test.Tasty.Runners-import Data.Either ( fromRight- , isLeft- , isRight- )-import Data.Maybe ( fromMaybe )-import Data.Type.Pretty-import qualified System.IO as IO+import Control.Eff.Concurrent+import Control.Eff.Concurrent.Process.ForkIOScheduler as Scheduler+import Control.Eff.Extend+import Control.Monad+import Data.Default+import Data.Either+ ( fromRight,+ isLeft,+ isRight,+ )+import Data.Foldable+import Data.Maybe (fromMaybe)+import Data.Text+ ( Text,+ pack,+ )+import Data.Typeable hiding (cast)+import GHC.Stack+import qualified System.IO as IO+import Test.Tasty hiding+ ( Timeout,+ defaultMain,+ )+import qualified Test.Tasty as Tasty+import Test.Tasty.HUnit+import Test.Tasty.Runners setTravisTestOptions :: TestTree -> TestTree setTravisTestOptions =@@ -66,12 +64,14 @@ runTestCase msg et = testCase msg $ do lw <- stdoutLogWriter renderConsoleMinimalisticWide- runLift- $ withRichLogging lw "unit-tests" local0 allLogMessages- $ Scheduler.schedule- $ handleInterrupts onInt- et- where onInt = lift . assertFailure . show+ runLift $+ withRichLogging lw "unit-tests" local0 allLogEvents $+ Scheduler.schedule $+ handleInterrupts+ onInt+ et+ where+ onInt = lift . assertFailure . show . MkUnhandledProcessInterrupt withTestLogC :: (e -> IO ()) -> (IO (e -> IO ()) -> TestTree) -> TestTree withTestLogC doSchedule k = k (return doSchedule)@@ -81,77 +81,65 @@ r <- send pa case r of Interrupted _ -> return ()- _ -> untilInterrupted pa+ _ -> untilInterrupted pa -scheduleAndAssert- :: forall r- . (IoLogging r)- => IO (Eff (Processes r) () -> IO ())- -> ((String -> Bool -> Eff (Processes r) ()) -> Eff (Processes r) ())- -> IO ()+scheduleAndAssert ::+ forall r.+ (IoLogging r) =>+ IO (Eff (Processes r) () -> IO ()) ->+ ((String -> Bool -> Eff (Processes r) ()) -> Eff (Processes r) ()) ->+ IO () scheduleAndAssert schedulerFactory testCaseAction = withFrozenCallStack $ do IO.hSetBuffering IO.stdout IO.LineBuffering resultVar <- newEmptyTMVarIO void- (applySchedulerFactory- schedulerFactory- (testCaseAction- (\title cond -> lift (atomically (putTMVar resultVar (title, cond))))- )+ ( applySchedulerFactory+ schedulerFactory+ ( testCaseAction+ (\title cond -> lift (atomically (putTMVar resultVar (title, cond))))+ ) ) (title, result) <- atomically (takeTMVar resultVar) assertBool title result -applySchedulerFactory- :: forall r- . (IoLogging r)- => IO (Eff (Processes r) () -> IO ())- -> Eff (Processes r) ()- -> IO ()+applySchedulerFactory ::+ forall r.+ (IoLogging r) =>+ IO (Eff (Processes r) () -> IO ()) ->+ Eff (Processes r) () ->+ IO () applySchedulerFactory factory procAction = do scheduler <- factory scheduler (procAction >> lift (threadDelay 20000)) -assertShutdown- :: (Member Logs r, HasCallStack, HasProcesses r q, Lifted IO r)- => ProcessId- -> Interrupt 'NoRecovery- -> Eff r ()+assertShutdown ::+ (Member Logs r, HasCallStack, HasProcesses r q, Lifted IO r) =>+ ProcessId ->+ ShutdownReason ->+ Eff r () assertShutdown p r = do unlinkProcess p m <- monitor p sendShutdown p r- logInfo- ( "awaitProcessDown: "- <> pack (show p)- <> " "- <> pack (show m)- )+ logInfo (LABEL "awaitProcessDown" p) m logCallStack debugSeverity receiveSelectedMessage (selectProcessDown m)- >>= lift . assertEqual "bad exit reason" r . downReason+ >>= lift . assertEqual "bad exit reason" (MkUnhandledProcessExit r) . MkUnhandledProcessExit . downReason -awaitProcessDown- :: (Member Logs r, HasCallStack, HasProcesses r q)- => ProcessId- -> Eff r ProcessDown+awaitProcessDown ::+ (Member Logs r, HasCallStack, HasProcesses r q) =>+ ProcessId ->+ Eff r ProcessDown awaitProcessDown p = do m <- monitor p- logInfo- ( "awaitProcessDown: "- <> pack (show p)- <> " "- <> pack (show m)- )+ logInfo (LABEL "awaitProcessDown" p) m logCallStack debugSeverity receiveSelectedMessage (selectProcessDown m) -awaitProcessDownAny- :: (Member Logs r, HasCallStack, HasProcesses r q)- => Eff r ProcessDown+awaitProcessDownAny ::+ (Member Logs r, HasCallStack, HasProcesses r q) =>+ Eff r ProcessDown awaitProcessDownAny = do- logInfo "awaitProcessDownAny"+ logInfo (MSG "awaitProcessDownAny") logCallStack debugSeverity receiveMessage--
test/Debug.hs view
@@ -1,8 +1,7 @@-module Debug-where+module Debug where -import ProcessBehaviourTestCases-import Test.Tasty+import ProcessBehaviourTestCases+import Test.Tasty debugMain :: IO () debugMain = defaultMain test_forkIo
test/Driver.hs view
@@ -1,1 +1,11 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+module Driver where++import Test.Tasty+import Test.Tasty.HUnit+import qualified BrokerTests++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+ [ BrokerTests.test_Broker ]
test/ForkIOScheduler.hs view
@@ -1,183 +1,179 @@ module ForkIOScheduler where -import Control.Exception-import Control.Concurrent-import Control.Concurrent.Async-import Control.Concurrent.STM-import Control.Eff.Extend-import Control.Eff.Loop-import Control.Eff.Concurrent.Process-import Control.Eff.Concurrent.Process.Timer-import Control.Eff.Concurrent.Process.ForkIOScheduler- as Scheduler-import Control.Monad ( void- , replicateM_- )-import Test.Tasty-import Test.Tasty.HUnit-import Common+import Common+import Control.Concurrent.Async+import Control.Eff.Concurrent.Process.ForkIOScheduler as Scheduler+import Control.Exception test_IOExceptionsIsolated :: TestTree-test_IOExceptionsIsolated = setTravisTestOptions $ testGroup- "one process throws an IO exception, the other continues unimpaired"- [ testCase- ( "process 2 exits with: "- ++ howToExit- ++ " - while process 1 is busy with: "- ++ busyWith- )- $ do- aVar <- newEmptyTMVarIO- (Scheduler.defaultMain- (do- p1 <- spawn "test" $ foreverCheap busyEffect- lift (threadDelay 1000)- void $ spawn "test" $ do- lift (threadDelay 1000)- doExit- lift (threadDelay 100000)-- me <- self- spawn_ "test" (lift (threadDelay 10000) >> sendMessage me ())- resultOrError <- receiveWithMonitor p1 (selectMessage @())- case resultOrError of- Left _down -> lift (atomically (putTMVar aVar False))- Right () -> withMonitor p1 $ \ref -> do- sendShutdown p1 (interruptToExit (ErrorInterrupt "test 123"))- _down <- receiveSelectedMessage (selectProcessDown ref)- lift (atomically (putTMVar aVar True))- )- )-- wasStillRunningP1 <- atomically (takeTMVar aVar)- assertBool "the other process was still running" wasStillRunningP1- | (busyWith , busyEffect) <-- [ ( "receiving"- , void (send (ReceiveSelectedMessage @BaseEffects selectAnyMessage))- )- , ( "sending"- , void (send (SendMessage @BaseEffects 44444 (toStrictDynamic ("test message" :: String))))- )- , ( "sending shutdown"- , void (send (SendShutdown @BaseEffects 44444 ExitNormally))- )- , ("selfpid-ing", void (send (SelfPid @BaseEffects)))- , ( "spawn-ing"- , void- (send- (Spawn @BaseEffects "test"- (void- (send (ReceiveSelectedMessage @BaseEffects selectAnyMessage))- )+test_IOExceptionsIsolated =+ setTravisTestOptions $+ testGroup+ "one process throws an IO exception, the other continues unimpaired"+ [ testCase+ ( "process 2 exits with: "+ ++ howToExit+ ++ " - while process 1 is busy with: "+ ++ busyWith )- )- )- ]- , (howToExit, doExit ) <-- [ ("throw async exception", void (lift (throw UserInterrupt)))- , ("cancel process" , void (lift (throw AsyncCancelled)))- , ("division by zero" , void ((lift . print) ((123 :: Int) `div` 0)))- , ("call 'fail'" , void (fail "test fail"))- , ("call 'error'" , void (error "test error"))- ]- ]+ $ do+ aVar <- newEmptyTMVarIO+ ( Scheduler.defaultMain+ ( do+ p1 <- spawn "test" $ foreverCheap busyEffect+ lift (threadDelay 1000)+ void $+ spawn "test" $ do+ lift (threadDelay 1000)+ doExit+ lift (threadDelay 100000)+ me <- self+ spawn_ "test" (lift (threadDelay 10000) >> sendMessage me ())+ resultOrError <- receiveWithMonitor p1 (selectMessage @())+ case resultOrError of+ Left _down -> lift (atomically (putTMVar aVar False))+ Right () -> withMonitor p1 $ \ref -> do+ sendShutdown p1 (interruptToExit (ErrorInterrupt "test 123"))+ _down <- receiveSelectedMessage (selectProcessDown ref)+ lift (atomically (putTMVar aVar True))+ )+ )+ wasStillRunningP1 <- atomically (takeTMVar aVar)+ assertBool "the other process was still running" wasStillRunningP1+ | (busyWith, busyEffect) <-+ [ ( "receiving",+ void (send (ReceiveSelectedMessage @BaseEffects selectAnyMessage))+ ),+ ( "sending",+ void (send (SendMessage @BaseEffects 44444 (toMessage ("test message" :: String))))+ ),+ ( "sending shutdown",+ void (send (SendShutdown @BaseEffects 44444 ExitNormally))+ ),+ ("selfpid-ing", void (send (SelfPid @BaseEffects))),+ ( "spawn-ing",+ void+ ( send+ ( Spawn @BaseEffects+ "test"+ ( void+ (send (ReceiveSelectedMessage @BaseEffects selectAnyMessage))+ )+ )+ )+ )+ ],+ (howToExit, doExit) <-+ [ ("throw async exception", void (lift (throw UserInterrupt))),+ ("cancel process", void (lift (throw AsyncCancelled))),+ ("division by zero", void ((lift . print) ((123 :: Int) `div` 0))),+ ("call 'error'", void (error "test error"))+ ]+ ] test_mainProcessSpawnsAChildAndReturns :: TestTree-test_mainProcessSpawnsAChildAndReturns = setTravisTestOptions- (testCase- "spawn a child and return"- (Scheduler.defaultMain- (void (spawn "test" (void receiveAnyMessage)))- )- )+test_mainProcessSpawnsAChildAndReturns =+ setTravisTestOptions+ ( testCase+ "spawn a child and return"+ ( Scheduler.defaultMain+ (void (spawn "test" (void receiveAnyMessage)))+ )+ ) test_mainProcessSpawnsAChildAndExitsNormally :: TestTree-test_mainProcessSpawnsAChildAndExitsNormally = setTravisTestOptions- (testCase- "spawn a child and exit normally"- (Scheduler.defaultMain- (do- void (spawn "test" (void receiveAnyMessage))- void exitNormally- fail "This should not happen!!"+test_mainProcessSpawnsAChildAndExitsNormally =+ setTravisTestOptions+ ( testCase+ "spawn a child and exit normally"+ ( Scheduler.defaultMain+ ( do+ void (spawn "test" (void receiveAnyMessage))+ void exitNormally+ ) ) )- ) - test_mainProcessSpawnsAChildInABusySendLoopAndExitsNormally :: TestTree test_mainProcessSpawnsAChildInABusySendLoopAndExitsNormally = setTravisTestOptions- (testCase- "spawn a child with a busy send loop and exit normally"- (Scheduler.defaultMain- (do- void (spawn "test" (foreverCheap (void (sendMessage 1000 ("test" :: String)))))- void exitNormally- fail "This should not happen!!"- )+ ( testCase+ "spawn a child with a busy send loop and exit normally"+ ( Scheduler.defaultMain+ ( do+ void (spawn "test" (foreverCheap (void (sendMessage 1000 ("test" :: String)))))+ void exitNormally+ error "This should not happen!!"+ ) )- )-+ ) test_mainProcessSpawnsAChildBothReturn :: TestTree-test_mainProcessSpawnsAChildBothReturn = setTravisTestOptions- (testCase- "spawn a child and let it return and return"- (Scheduler.defaultMain- (do- child <- spawn "test" (void (receiveMessage @String))- sendMessage child ("test" :: String)- return ()+test_mainProcessSpawnsAChildBothReturn =+ setTravisTestOptions+ ( testCase+ "spawn a child and let it return and return"+ ( Scheduler.defaultMain+ ( do+ child <- spawn "test" (void (receiveMessage @String))+ sendMessage child ("test" :: String)+ return ()+ ) )- ))+ ) test_mainProcessSpawnsAChildBothExitNormally :: TestTree-test_mainProcessSpawnsAChildBothExitNormally = setTravisTestOptions- (testCase- "spawn a child and let it exit and exit"- (Scheduler.defaultMain- (do- child <- spawn "test" $ void $ provideInterrupts $ exitOnInterrupt- (do- void (receiveMessage @String)- void exitNormally- error "This should not happen (child)!!"- )- sendMessage child ("test" :: String)- void exitNormally- error "This should not happen!!"+test_mainProcessSpawnsAChildBothExitNormally =+ setTravisTestOptions+ ( testCase+ "spawn a child and let it exit and exit"+ ( Scheduler.defaultMain+ ( do+ child <-+ spawn "test" $+ void $+ provideInterrupts $+ exitOnInterrupt+ ( do+ void (receiveMessage @String)+ void exitNormally+ error "This should not happen (child)!!"+ )+ sendMessage child ("test" :: String)+ void exitNormally+ error "This should not happen!!" )- )+ ) ) test_timer :: TestTree test_timer =- setTravisTestOptions- $ testCase "flush via timer"- $ Scheduler.defaultMain- $ do- let n = 100- testMsg :: Float- testMsg = 123- flushMessagesLoop = do- res <- receiveSelectedAfter (selectDynamicMessage Just) 0- case res of- Left _to -> return ()- Right _ -> flushMessagesLoop- me <- self- spawn_ "test-worker"- (do- replicateM_ n $ sendMessage me ("bad message" :: String)- replicateM_ n $ sendMessage me (3123 :: Integer)- sendMessage me testMsg- )+ setTravisTestOptions $+ testCase "flush via timer" $+ Scheduler.defaultMain $ do- res <- receiveAfter @Float 1000000- lift (res @?= Just testMsg)- flushMessagesLoop- res <- receiveSelectedAfter (selectDynamicMessage Just) 10000- case res of- Left _ -> return ()- Right x -> lift (False @? "unexpected message in queue " ++ show x)- lift (threadDelay 100)+ let n = 100+ testMsg :: Float+ testMsg = 123+ flushMessagesLoop = do+ res <- receiveSelectedAfter (selectDynamicMessage Just) 0+ case res of+ Left _to -> return ()+ Right _ -> flushMessagesLoop+ me <- self+ spawn_+ "test-worker"+ ( do+ replicateM_ n $ sendMessage me ("bad message" :: String)+ replicateM_ n $ sendMessage me (3123 :: Integer)+ sendMessage me testMsg+ )+ do+ res <- receiveAfter @Float 1000000+ lift (res @?= Just testMsg)+ flushMessagesLoop+ res <- receiveSelectedAfter (selectDynamicMessage Just) 10000+ case res of+ Left _ -> return ()+ Right x -> lift (False @? "unexpected message in queue " ++ show x)+ lift (threadDelay 100)
test/GenServerTests.hs view
@@ -1,73 +1,78 @@ {-# LANGUAGE UndecidableInstances #-}+ module GenServerTests- ( test_genServer- ) where+ ( test_genServer,+ )+where import Common import Control.Eff.Concurrent.Protocol.Broker as Broker import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as E import qualified Control.Eff.Concurrent.Protocol.StatefulServer as S-import Data.Typeable (Typeable)+import Data.Coerce (coerce) -- ------------------------------ -data Small deriving Typeable--type instance ToPretty Small = PutStr "small"+data Small deriving (Typeable) instance HasPdu Small where- data instance Pdu Small r where- SmallCall :: Bool -> Pdu Small ('Synchronous Bool)- SmallCast :: String -> Pdu Small 'Asynchronous- deriving Typeable+ data Pdu Small r where+ SmallCall :: Bool -> Pdu Small ('Synchronous Bool)+ SmallCast :: String -> Pdu Small 'Asynchronous+ deriving (Typeable) instance NFData (Pdu Small r) where rnf (SmallCall x) = rnf x rnf (SmallCast x) = rnf x -instance Show (Pdu Small r) where- showsPrec d (SmallCall x) = showParen (d > 10) (showString "SmallCall " . shows x)- showsPrec d (SmallCast x) = showParen (d > 10) (showString "SmallCast " . showString x)-+instance ToLogMsg (Pdu Small r) where+ toLogMsg (SmallCall x) = "SmallCall " <> toLogMsg x+ toLogMsg (SmallCast x) = "SmallCast " <> toLogMsg x -- ----------------------------------------------------------------------------+instance ToTypeLogMsg Small where+ toTypeLogMsg _ = "Small" instance IoLogging e => S.Server Small (Processes e) where- data StartArgument Small = MkSmall- newtype instance Model Small = SmallModel String deriving Default+ data StartArgument Small = MkSmall deriving (Show)+ newtype Model Small = SmallModel String deriving (Default) update _me MkSmall x = case x of E.OnCall rt (SmallCall f) ->- do S.modifyModel (\(SmallModel y) -> SmallModel (y ++ ", " ++ show f))+ do+ S.modifyModel (\(SmallModel y) -> SmallModel (y ++ ", " ++ show f)) sendReply rt f E.OnCast msg ->- logInfo' (show msg)+ logInfo msg other ->- interrupt (ErrorInterrupt (show other))+ interrupt (ErrorInterrupt (toLogMsg other)) +instance ToLogMsg (S.StartArgument Small)+ -- ---------------------------------------------------------------------------- data Big deriving (Typeable) -type instance ToPretty Big = PutStr "big"+instance ToTypeLogMsg Big where+ toTypeLogMsg _ = "Big" instance HasPdu Big where- type instance EmbeddedPduList Big = '[Small]- data instance Pdu Big r where+ type EmbeddedPduList Big = '[Small]+ data Pdu Big r where BigCall :: Bool -> Pdu Big ('Synchronous Bool) BigCast :: String -> Pdu Big 'Asynchronous BigSmall :: Pdu Small r -> Pdu Big r- deriving Typeable+ deriving (Typeable) instance NFData (Pdu Big r) where rnf (BigCall x) = rnf x rnf (BigCast x) = rnf x rnf (BigSmall x) = rnf x -instance Show (Pdu Big r) where- showsPrec d (BigCall x) = showParen (d > 10) (showString "SmallCall " . shows x)- showsPrec d (BigCast x) = showParen (d > 10) (showString "SmallCast " . showString x)- showsPrec d (BigSmall x) = showParen (d > 10) (showString "BigSmall " . showsPrec 11 x)+instance ToLogMsg (Pdu Big r) where+ toLogMsg (BigCall x) = "SmallCall " <> toLogMsg x+ toLogMsg (BigCast x) = "SmallCast " <> toLogMsg x+ toLogMsg (BigSmall x) = "BigSmall " <> toLogMsg x instance HasPduPrism Big Small where embedPdu = BigSmall@@ -77,41 +82,47 @@ -- ---------------------------------------------------------------------------- instance IoLogging e => S.Server Big (Processes e) where- data instance StartArgument Big = MkBig- newtype Model Big = BigModel String deriving Default+ data StartArgument Big = MkBig deriving (Show)+ newtype Model Big = BigModel String deriving (Default) update me MkBig = \case E.OnCall rt req ->- case req of- BigCall o -> do- logNotice ("BigCall " <> pack (show o))- sendReply rt o- BigSmall x ->- S.coerceEffects- (S.update- (toEmbeddedEndpoint me)- MkSmall- (S.OnCall (toEmbeddedReplyTarget rt) x))+ case req of+ BigCall o -> do+ logNotice (LABEL "BigCall" o)+ sendReply rt o+ BigSmall x ->+ S.coerceEffects+ ( S.update+ (coerce me)+ MkSmall+ (S.OnCall (toEmbeddedReplyTarget rt) x)+ ) E.OnCast req ->- case req of- BigCast o -> S.putModel (BigModel o)- BigSmall x -> S.coerceEffects (S.update (toEmbeddedEndpoint me) MkSmall (S.OnCast x))+ case req of+ BigCast o -> S.putModel (BigModel o)+ BigSmall x -> S.coerceEffects (S.update (coerce me) MkSmall (S.OnCast x)) other ->- interrupt (ErrorInterrupt (show other))+ interrupt (ErrorInterrupt (toLogMsg other)) +instance ToLogMsg (StartArgument Big)+ -- ---------------------------------------------------------------------------- test_genServer :: HasCallStack => TestTree-test_genServer = setTravisTestOptions $ testGroup "Server" [- runTestCase "When a server is started it handles call Pdus without dieing" $ do- big <- S.startLink MkBig- call big (BigCall True) >>= lift . assertBool "invalid result 1"- isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"- call big (BigCall False) >>= lift . assertBool "invalid result 2" . not- isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"- cast big (BigCast "rezo")- isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"- cast big (BigSmall (SmallCast "yo diggi"))- isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"- call big (BigSmall (SmallCall False )) >>= lift . assertBool "invalid result 3" . not- isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"- ]+test_genServer =+ setTravisTestOptions $+ testGroup+ "Server"+ [ runTestCase "When a server is started it handles call Pdus without dieing" $ do+ big <- S.startLink MkBig+ call big (BigCall True) >>= lift . assertBool "invalid result 1"+ isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"+ call big (BigCall False) >>= lift . assertBool "invalid result 2" . not+ isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"+ cast big (BigCast "rezo")+ isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"+ cast big (BigSmall (SmallCast "yo diggi"))+ isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"+ call big (BigSmall (SmallCall False)) >>= lift . assertBool "invalid result 3" . not+ isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"+ ]
test/Interactive.hs view
@@ -1,34 +1,29 @@ module Interactive where -import Control.Concurrent-import Control.Eff-import Control.Eff.Concurrent.Process-import Control.Eff.Concurrent.Process.Interactive-import qualified Control.Eff.Concurrent.Process.SingleThreadedScheduler- as SingleThreaded-import qualified Control.Eff.Concurrent.Process.ForkIOScheduler- as ForkIOScheduler-import Test.Tasty-import Test.Tasty.HUnit-import Common+import Common+import qualified Control.Eff.Concurrent.Process.ForkIOScheduler as ForkIOScheduler+import Control.Eff.Concurrent.Process.Interactive+import qualified Control.Eff.Concurrent.Process.SingleThreadedScheduler as SingleThreaded test_interactive :: TestTree-test_interactive = setTravisTestOptions $ testGroup- "Interactive"- [ testGroup "SingleThreadedScheduler" $ allTests SingleThreaded.defaultMain- , testGroup "ForkIOScheduler" $ allTests ForkIOScheduler.defaultMain- ]+test_interactive =+ setTravisTestOptions $+ testGroup+ "Interactive"+ [ testGroup "SingleThreadedScheduler" $ allTests SingleThreaded.defaultMain,+ testGroup "ForkIOScheduler" $ allTests ForkIOScheduler.defaultMain+ ] -allTests- :: SetMember Lift (Lift IO) r- => (Eff (Processes r) () -> IO ())- -> [TestTree]+allTests ::+ SetMember Lift (Lift IO) r =>+ (Eff (Processes r) () -> IO ()) ->+ [TestTree] allTests scheduler = [happyCaseTest scheduler] -happyCaseTest- :: SetMember Lift (Lift IO) r- => (Eff (Processes r) () -> IO ())- -> TestTree+happyCaseTest ::+ SetMember Lift (Lift IO) r =>+ (Eff (Processes r) () -> IO ()) ->+ TestTree happyCaseTest scheduler = testCase "start, wait and stop interactive scheduler" $ do s <- forkInteractiveScheduler scheduler
− test/LogMessageIdeaTest.hs
@@ -1,482 +0,0 @@-module LogMessageIdeaTest where--import Control.Concurrent-import Control.DeepSeq-import Control.Lens-import Data.Default-import Data.Maybe-import qualified Data.Text as T-import Data.Time.Clock-import Data.Time.Format-import GHC.Generics hiding ( to )-import GHC.Stack-import System.FilePath.Posix-import Text.Printf-import Control.Eff-import Control.Eff.Reader.Lazy----- | A message data type inspired by the RFC-5424 Syslog Protocol-data LogMessage =- MkLogMessage { _lmFacility :: !Facility- , _lmSeverity :: !Severity- , _lmTimestamp :: (Maybe UTCTime)- , _lmHostname :: (Maybe T.Text)- , _lmAppName :: (Maybe T.Text)- , _lmProcessId :: (Maybe T.Text)- , _lmMessageId :: (Maybe T.Text)- , _lmStructuredData :: [StructuredDataElement]- , _lmThreadId :: (Maybe ThreadId)- , _lmSrcLoc :: (Maybe SrcLoc)- , _lmMessage :: T.Text}- deriving (Eq, Generic)--instance Default LogMessage where- def = MkLogMessage def def def def def def def def def def ""--instance NFData LogMessage---- | RFC-5424 defines how structured data can be included in a log message.-data StructuredDataElement =- SdElement { _sdElementId :: !T.Text- , _sdElementParameters :: ![SdParameter]}- deriving (Eq, Ord, Generic, Show)---renderSdElement :: StructuredDataElement -> T.Text-renderSdElement (SdElement sdId params) = "[" <> sdName sdId <> if null params- then ""- else " " <> T.unwords (renderSdParameter <$> params) <> "]"--instance NFData StructuredDataElement---- | Component of an RFC-5424 'StructuredDataElement'-data SdParameter =- MkSdParameter !T.Text !T.Text- deriving (Eq, Ord, Generic, Show)--renderSdParameter :: SdParameter -> T.Text-renderSdParameter (MkSdParameter k v) =- sdName k <> "=\"" <> sdParamValue v <> "\""---- | Extract the name of an 'SdParameter' the length is cropped to 32 according to RFC 5424.-sdName :: T.Text -> T.Text-sdName =- T.take 32 . T.filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"')---- | Extract the value of an 'SdParameter'.-sdParamValue :: T.Text -> T.Text-sdParamValue = T.concatMap $ \case- '"' -> "\\\""- '\\' -> "\\\\"- ']' -> "\\]"- x -> T.singleton x--instance NFData SdParameter---- | An rfc 5424 severity-newtype Severity =- Severity {fromSeverity :: Int}- deriving (Eq, Ord, Generic, NFData)--instance Show Severity where- show (Severity 1) = "ALERT "- show (Severity 2) = "CRITICAL "- show (Severity 3) = "ERROR "- show (Severity 4) = "WARNING "- show (Severity 5) = "NOTICE "- show (Severity 6) = "INFO "- show (Severity x) | x <= 0 = "EMERGENCY"- | otherwise = "DEBUG "--- *** Severities---- | Smart constructor for the RFC-5424 __emergency__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __0__.--- See 'lmSeverity'.-emergencySeverity :: Severity-emergencySeverity = Severity 0---- | Smart constructor for the RFC-5424 __alert__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __1__.--- See 'lmSeverity'.-alertSeverity :: Severity-alertSeverity = Severity 1---- | Smart constructor for the RFC-5424 __critical__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __2__.--- See 'lmSeverity'.-criticalSeverity :: Severity-criticalSeverity = Severity 2---- | Smart constructor for the RFC-5424 __error__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __3__.--- See 'lmSeverity'.-errorSeverity :: Severity-errorSeverity = Severity 3---- | Smart constructor for the RFC-5424 __warning__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __4__.--- See 'lmSeverity'.-warningSeverity :: Severity-warningSeverity = Severity 4---- | Smart constructor for the RFC-5424 __notice__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __5__.--- See 'lmSeverity'.-noticeSeverity :: Severity-noticeSeverity = Severity 5---- | Smart constructor for the RFC-5424 __informational__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __6__.--- See 'lmSeverity'.-informationalSeverity :: Severity-informationalSeverity = Severity 6---- | Smart constructor for the RFC-5424 __debug__ 'LogMessage' 'Severity'.--- This corresponds to the severity value __7__.--- See 'lmSeverity'.-debugSeverity :: Severity-debugSeverity = Severity 7--instance Default Severity where- def = debugSeverity----- | An rfc 5424 facility-newtype Facility = Facility {fromFacility :: Int}- deriving (Eq, Ord, Show, Generic, NFData)---- | Smart constructor for the RFC-5424 'LogMessage' facility @kernelMessages@.--- See 'lmFacility'.-kernelMessages :: Facility-kernelMessages = Facility 0---- | Smart constructor for the RFC-5424 'LogMessage' facility @userLevelMessages@.--- See 'lmFacility'.-userLevelMessages :: Facility-userLevelMessages = Facility 1---- | Smart constructor for the RFC-5424 'LogMessage' facility @mailSystem@.--- See 'lmFacility'.-mailSystem :: Facility-mailSystem = Facility 2---- | Smart constructor for the RFC-5424 'LogMessage' facility @systemDaemons@.--- See 'lmFacility'.-systemDaemons :: Facility-systemDaemons = Facility 3---- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages4@.--- See 'lmFacility'.-securityAuthorizationMessages4 :: Facility-securityAuthorizationMessages4 = Facility 4---- | Smart constructor for the RFC-5424 'LogMessage' facility @linePrinterSubsystem@.--- See 'lmFacility'.-linePrinterSubsystem :: Facility-linePrinterSubsystem = Facility 6---- | Smart constructor for the RFC-5424 'LogMessage' facility @networkNewsSubsystem@.--- See 'lmFacility'.-networkNewsSubsystem :: Facility-networkNewsSubsystem = Facility 7---- | Smart constructor for the RFC-5424 'LogMessage' facility @uucpSubsystem@.--- See 'lmFacility'.-uucpSubsystem :: Facility-uucpSubsystem = Facility 8---- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon@.--- See 'lmFacility'.-clockDaemon :: Facility-clockDaemon = Facility 9---- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages10@.--- See 'lmFacility'.-securityAuthorizationMessages10 :: Facility-securityAuthorizationMessages10 = Facility 10---- | Smart constructor for the RFC-5424 'LogMessage' facility @ftpDaemon@.--- See 'lmFacility'.-ftpDaemon :: Facility-ftpDaemon = Facility 11---- | Smart constructor for the RFC-5424 'LogMessage' facility @ntpSubsystem@.--- See 'lmFacility'.-ntpSubsystem :: Facility-ntpSubsystem = Facility 12---- | Smart constructor for the RFC-5424 'LogMessage' facility @logAuditFacility@.--- See 'lmFacility'.-logAuditFacility :: Facility-logAuditFacility = Facility 13---- | Smart constructor for the RFC-5424 'LogMessage' facility @logAlertFacility@.--- See 'lmFacility'.-logAlertFacility :: Facility-logAlertFacility = Facility 14---- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon2@.--- See 'lmFacility'.-clockDaemon2 :: Facility-clockDaemon2 = Facility 15---- | Smart constructor for the RFC-5424 'LogMessage' facility @local0@.--- See 'lmFacility'.-local0 :: Facility-local0 = Facility 16---- | Smart constructor for the RFC-5424 'LogMessage' facility @local1@.--- See 'lmFacility'.-local1 :: Facility-local1 = Facility 17---- | Smart constructor for the RFC-5424 'LogMessage' facility @local2@.--- See 'lmFacility'.-local2 :: Facility-local2 = Facility 18---- | Smart constructor for the RFC-5424 'LogMessage' facility @local3@.--- See 'lmFacility'.-local3 :: Facility-local3 = Facility 19---- | Smart constructor for the RFC-5424 'LogMessage' facility @local4@.--- See 'lmFacility'.-local4 :: Facility-local4 = Facility 20---- | Smart constructor for the RFC-5424 'LogMessage' facility @local5@.--- See 'lmFacility'.-local5 :: Facility-local5 = Facility 21---- | Smart constructor for the RFC-5424 'LogMessage' facility @local6@.--- See 'lmFacility'.-local6 :: Facility-local6 = Facility 22---- | Smart constructor for the RFC-5424 'LogMessage' facility @local7@.--- See 'lmFacility'.-local7 :: Facility-local7 = Facility 23--instance Default Facility where- def = local7--makeLensesWith (lensRules & generateSignatures .~ False) ''StructuredDataElement---- | A lens for 'SdParameter's-sdElementParameters- :: Functor f- => ([SdParameter] -> f [SdParameter])- -> StructuredDataElement- -> f StructuredDataElement---- | A lens for the key or ID of a group of RFC 5424 key-value pairs.-sdElementId- :: Functor f- => (T.Text -> f T.Text)- -> StructuredDataElement- -> f StructuredDataElement--makeLensesWith (lensRules & generateSignatures .~ False) ''LogMessage---- | A lens for the UTC time of a 'LogMessage'--- The function 'setLogMessageTimestamp' can be used to set the field.-lmTimestamp- :: Functor f- => (Maybe UTCTime -> f (Maybe UTCTime))- -> LogMessage- -> f LogMessage---- | A lens for the 'ThreadId' of a 'LogMessage'--- The function 'setLogMessageThreadId' can be used to set the field.-lmThreadId- :: Functor f- => (Maybe ThreadId -> f (Maybe ThreadId))- -> LogMessage- -> f LogMessage---- | A lens for the 'StructuredDataElement' of a 'LogMessage'-lmStructuredData- :: Functor f- => ([StructuredDataElement] -> f [StructuredDataElement])- -> LogMessage- -> f LogMessage---- | A lens for the 'SrcLoc' of a 'LogMessage'-lmSrcLoc- :: Functor f- => (Maybe SrcLoc -> f (Maybe SrcLoc))- -> LogMessage- -> f LogMessage---- | A lens for the 'Severity' of a 'LogMessage'-lmSeverity- :: Functor f => (Severity -> f Severity) -> LogMessage -> f LogMessage---- | A lens for a user defined of /process/ id of a 'LogMessage'-lmProcessId- :: Functor f- => (Maybe T.Text -> f (Maybe T.Text))- -> LogMessage- -> f LogMessage---- | A lens for a user defined /message id/ of a 'LogMessage'-lmMessageId- :: Functor f- => (Maybe T.Text -> f (Maybe T.Text))- -> LogMessage- -> f LogMessage---- | A lens for the user defined textual message of a 'LogMessage'-lmMessage :: Functor f => (T.Text -> f T.Text) -> LogMessage -> f LogMessage---- | A lens for the hostname of a 'LogMessage'--- The function 'setLogMessageHostname' can be used to set the field.-lmHostname- :: Functor f- => (Maybe T.Text -> f (Maybe T.Text))- -> LogMessage- -> f LogMessage---- | A lens for the 'Facility' of a 'LogMessage'-lmFacility- :: Functor f => (Facility -> f Facility) -> LogMessage -> f LogMessage---- | A lens for the RFC 5424 /application/ name of a 'LogMessage'------ One useful pattern for using this field, is to implement log filters that allow--- info and debug message from the application itself while only allowing warning and error--- messages from third party libraries:------ > debugLogsForAppName myAppName lm =--- > view lmAppName lm == Just myAppName || lmSeverityIsAtLeast warningSeverity lm------ This concept is also implemented in 'discriminateByAppName'.-lmAppName- :: Functor f- => (Maybe T.Text -> f (Maybe T.Text))- -> LogMessage- -> f LogMessage--instance Show LogMessage where- show = T.unpack . T.unlines . renderLogMessageBodyFixWidth---type LogRenderer a = LogMessage -> a--withRenderer :: LogRenderer a -> Eff (Reader (LogRenderer a) ': e) b -> Eff e b-withRenderer = runReader--newtype SeverityText = MkSeverityText { fromSeverityText :: T.Text }- deriving (Semigroup)--mkSyslogSeverityText :: LogRenderer SeverityText-mkSyslogSeverityText (MkLogMessage !f !s _ _ _ _ _ _ _ _ _)- = MkSeverityText $ "<" <> T.pack (show (fromSeverity s + fromFacility f * 8)) <> ">"--newtype FacilityText = MkFacilityText { fromFacilityText :: T.Text }- deriving (Semigroup)--mkSyslogFacilityText :: LogRenderer FacilityText-mkSyslogFacilityText _ = MkFacilityText ""--newtype TimestampText = MkTimestampText { fromTimestampText :: T.Text }- deriving (Semigroup)--mkFormattedTimestampText :: LogTimestampFormat -> LogRenderer (Maybe TimestampText)-mkFormattedTimestampText f (MkLogMessage _ _ ts _ _ _ _ _ _ _ _) =- MkTimestampText . formatLogTimestamp f <$> ts--newtype MessageText = MkMessageText { fromMessageText :: T.Text }- deriving (Semigroup)--mkMessageText :: LogRenderer MessageText-mkMessageText = MkMessageText . renderLogMessageBody--renderDevLogMessage :: LogRenderer T.Text-renderDevLogMessage =- run- $ withRenderer mkSyslogSeverityText- $ withRenderer mkSyslogFacilityText- $ withRenderer mkMessageText- $ withRenderer (fromMaybe (MkTimestampText "-") <$> mkFormattedTimestampText rfc5424NoZTimestamp)- $ mkDevLogMessage--mkDevLogMessage ::- ( '[ Reader (LogRenderer SeverityText)- , Reader (LogRenderer FacilityText)- , Reader (LogRenderer TimestampText)- , Reader (LogRenderer MessageText)- ]- <:: e- )- => Eff e (LogRenderer T.Text)-mkDevLogMessage =- (\s ts m -> s <> pure " " <> ts <> pure " " <> m)- <$> (fmap fromSeverityText <$> ask)- <*> (fmap fromTimestampText <$> ask)- <*> (fmap fromMessageText <$> ask)----- | A time stamp formatting function-newtype LogTimestampFormat =- MkLogTimestampFormat { formatLogTimestamp :: UTCTime -> T.Text }---- | Make a 'LogTimestampFormat' using 'formatTime' in the 'defaultLocale'.-mkLogTimestampFormat- :: String -- ^ The format string that is passed to 'formatTime'- -> LogTimestampFormat-mkLogTimestampFormat s = MkLogTimestampFormat (T.pack . formatTime defaultTimeLocale s)---- | Don't render the time stamp-suppressTimestamp :: LogTimestampFormat-suppressTimestamp = MkLogTimestampFormat (const "")---- | Render the time stamp using @"%h %d %H:%M:%S"@-rfc3164Timestamp :: LogTimestampFormat-rfc3164Timestamp = mkLogTimestampFormat "%h %d %H:%M:%S"---- | Render the time stamp to @'iso8601DateFormat' (Just "%H:%M:%S%6QZ")@-rfc5424Timestamp :: LogTimestampFormat-rfc5424Timestamp = mkLogTimestampFormat (iso8601DateFormat (Just "%H:%M:%S%6QZ"))---- | Render the time stamp like 'rfc5424Timestamp' does, but omit the terminal @Z@ character.-rfc5424NoZTimestamp :: LogTimestampFormat-rfc5424NoZTimestamp = mkLogTimestampFormat (iso8601DateFormat (Just "%H:%M:%S%6Q"))------ | Print the /body/ of a 'LogMessage'-renderLogMessageBodyFixWidth :: LogMessage -> [T.Text]-renderLogMessageBodyFixWidth (MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =- if T.null msg- then []- else- maybe "" ((<> " -") . T.pack . show) ti- : (msg <> T.replicate (max 0 (60 - T.length msg)) " ")- : maybe- []- (\sl -> pure- (T.pack $ printf "% 30s line %i"- (takeFileName (srcLocFile sl))- (srcLocStartLine sl)- )- )- loc---- | Print the /body/ of a 'LogMessage' without any /tab-stops/-renderLogMessageBody :: LogMessage -> T.Text-renderLogMessageBody (MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =- maybe "" (\tis -> T.pack (show tis) <> " ") ti- <> msg- <> maybe- ""- (\sl ->- T.pack $ printf " at %s:%i"- (takeFileName (srcLocFile sl))- (srcLocStartLine sl)- )- loc
test/LoggingTests.hs view
@@ -1,130 +1,168 @@ module LoggingTests where -import Control.Eff-import qualified Control.Eff.LogWriter.UDP as UDP+import Common import qualified Control.Eff.LogWriter.Async as Async-import Control.Eff.Concurrent-import Test.Tasty-import Test.Tasty.HUnit-import Common-import Control.Lens-import Control.Monad.Trans.Control (liftBaseOp)-+import qualified Control.Eff.LogWriter.UDP as UDP+import Control.Lens+import Control.Monad.Trans.Control (liftBaseOp)+import qualified Data.Text as T test_Logging :: TestTree-test_Logging = setTravisTestOptions $ testGroup "logging"- [ cencoredLogging- , strictness- , testGroup "IO"- [ liftedIoLogging- , udpLogging- , udpNestedLogging- , asyncLogging- , asyncNestedLogging- ]- ]+test_Logging =+ setTravisTestOptions $+ testGroup+ "logging"+ [ cencoredLogging,+ strictness,+ testGroup+ "IO"+ [ liftedIoLogging,+ udpLogging,+ udpNestedLogging,+ asyncLogging,+ asyncNestedLogging+ ]+ ] cencoredLogging :: HasCallStack => TestTree cencoredLogging = testCase "log cencorship works" $ do- res <- fmap (view lmMessage) <$> censoredLoggingTestImpl demo- res @?=- view lmMessage <$>- [ infoMessage "1"- , debugMessage "2"- , infoMessage "x 1"- , debugMessage "x 2"- , infoMessage "x y 1"- , debugMessage "x y 2"- , infoMessage "x 1"- , debugMessage "x 2"- , infoMessage "1"- , debugMessage "2"- ]- where-+ res <- fmap (view logEventMessage) <$> censoredLoggingTestImpl demo+ (renderLogMsgToString <$> res)+ @?= renderLogMsgToString . view logEventMessage+ <$> [ infoMessage $ MSG "1",+ debugMessage $ MSG "2",+ infoMessage $ MSG "x 1",+ debugMessage $ MSG "x 2",+ infoMessage $ MSG "x y 1",+ debugMessage $ MSG "x y 2",+ infoMessage $ MSG "x 1",+ debugMessage $ MSG "x 2",+ infoMessage $ MSG "1",+ debugMessage $ MSG "2"+ ]+ where+ renderLogMsgToString :: LogMsg -> String+ renderLogMsgToString (MkLogMsg txt) = T.unpack txt demo :: ('[Logs] <:: e) => Eff e () demo = do- logDebug "2"- logInfo "1"-- censoredLoggingTestImpl :: Eff '[Logs, LogWriterReader, Lift IO] () -> IO [LogMessage]+ logDebug (MSG "2")+ logInfo (MSG "1")+ censoredLoggingTestImpl :: Eff '[Logs, LogWriterReader, Lift IO] () -> IO [LogEvent] censoredLoggingTestImpl e = do logs <- newMVar []- runLift- $ withLogging (MkLogWriter (\lm -> modifyMVar_ logs (\lms -> return (lm : lms))))- $ do- e- censorLogs (lmMessage %~ ("x " <>)) $ do+ runLift $+ withLogging (MkLogWriter (\lm -> modifyMVar_ logs (\lms -> return (lm : lms)))) $+ do+ e+ censorLogs (logEventMessage %~ ("x " <>)) $ do e- censorLogs (lmMessage %~ ("y " <>)) e+ censorLogs (logEventMessage %~ ("y " <>)) e e- e+ e takeMVar logs strictness :: HasCallStack => TestTree strictness =- testCase "messages failing the predicate are not deeply evaluated"- $ runLift- $ withConsoleLogging "test-app" local0 allLogMessages- $ excludeLogMessages (lmSeverityIs errorSeverity)- $ do logDebug "test"- logError' ("test" <> error "TEST FAILED: this log statement should not have been evaluated deeply")-+ testCase "messages failing the predicate are not deeply evaluated" $+ runLift $+ withConsoleLogging "test-app" local0 allLogEvents $+ blacklistLogEvents (logEventSeverityIs errorSeverity) $+ do+ logDebug (MSG "test")+ logError (error "TEST FAILED: this log statement should not have been evaluated deeply" :: String) liftedIoLogging :: HasCallStack => TestTree liftedIoLogging =- testCase "logging vs. MonadBaseControl"- $ do outVar <- newEmptyMVar- runLift- $ withConsoleLogging "test-app" local0 allLogMessages- $ (\ e -> liftBaseOp- (testWriter outVar)- (\doWrite ->- addLogWriter (MkLogWriter doWrite) e))- $ logDebug "test"- actual <- takeMVar outVar- assertEqual "wrong log message" "test" actual- where- testWriter :: MVar String -> ((LogMessage -> IO ()) -> IO ()) -> IO ()- testWriter outVar withWriter =- withWriter (putMVar outVar . show)+ testCase "logging vs. MonadBaseControl" $+ do+ outVar <- newEmptyMVar+ runLift $+ withConsoleLogging "test-app" local0 allLogEvents $+ ( \e ->+ liftBaseOp+ (testWriter outVar)+ ( \doWrite ->+ addLogWriter (MkLogWriter doWrite) e+ )+ )+ $ logDebug (MSG "test")+ actual <- takeMVar outVar+ assertEqual "wrong log message" "test" actual+ where+ testWriter :: MVar String -> ((LogEvent -> IO ()) -> IO ()) -> IO ()+ testWriter outVar withWriter =+ withWriter (putMVar outVar . show) test1234 :: Member Logs e => Eff e () test1234 = do- logNotice "~~~~~~~~~~~~~~~~~~~~~~~~~~test 1~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"- logNotice "~~~~~~~~~~~~~~~~~~~~~~~~~~test 2~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"- logNotice "~~~~~~~~~~~~~~~~~~~~~~~~~~test 3~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"- logNotice "~~~~~~~~~~~~~~~~~~~~~~~~~~test 4~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"+ logNotice $ MSG "~~~~~~~~~~~~~~~~~~~~~~~~~~test 1~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"+ logNotice $ MSG "~~~~~~~~~~~~~~~~~~~~~~~~~~test 2~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"+ logNotice $ MSG "~~~~~~~~~~~~~~~~~~~~~~~~~~test 3~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"+ logNotice $ MSG "~~~~~~~~~~~~~~~~~~~~~~~~~~test 4~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"+ let yumi = Yumi 123+ bubu = Bubu+ this = True+ that = 0.4 :: Double+ t :: Text+ t = "test"+ logNotice t+ logNotice yumi+ logNotice bubu+ logNotice this+ logNotice that -udpLogging :: HasCallStack => TestTree+data Bubu = Bubu++instance ToLogMsg Bubu where toLogMsg _ = "bubu"++newtype Yumi = Yumi Double deriving (ToLogMsg)++udpLogging :: TestTree udpLogging =- testCase "udp logging"- $ runLift- $ UDP.withUDPLogging renderRFC5424NoLocation "localhost" "9999" "test-app" local0 allLogMessages- test1234+ testCase "udp logging" $+ runLift $+ UDP.withUDPLogging+ renderRFC5424NoLocation+ "localhost"+ "9999"+ "test-app"+ local0+ allLogEvents+ test1234 -udpNestedLogging :: HasCallStack => TestTree+udpNestedLogging :: TestTree udpNestedLogging =- testCase "udp nested filteredlogging"- $ runLift- $ withConsoleLogging "test-app" local0 allLogMessages- $ UDP.withUDPLogWriter renderRFC5424 "localhost" "9999"+ testCase "udp nested filteredlogging" $+ runLift $+ withConsoleLogging "test-app" local0 allLogEvents $+ UDP.withUDPLogWriter+ renderRFC5424+ "localhost"+ "9999" test1234 -asyncLogging :: HasCallStack => TestTree+asyncLogging :: TestTree asyncLogging =- testCase "async filteredlogging"- $ do lw <- consoleLogWriter- runLift- $ Async.withAsyncLogging lw (1000::Int) "app-name" local0 allLogMessages- test1234+ testCase "async filteredlogging" $+ do+ lw <- consoleLogWriter+ runLift $+ Async.withAsyncLogging+ lw+ (1000 :: Int)+ "app-name"+ local0+ allLogEvents+ test1234 -asyncNestedLogging :: HasCallStack => TestTree+asyncNestedLogging :: TestTree asyncNestedLogging =- testCase "async nested filteredlogging"- $ do lw <- consoleLogWriter- runLift- $ withLogging lw- $ Async.withAsyncLogWriter (1000::Int)+ testCase "async nested filteredlogging" $+ do+ lw <- consoleLogWriter+ runLift $+ withLogging lw $+ Async.withAsyncLogWriter+ (1000 :: Int) test1234
test/LoopTests.hs view
@@ -1,90 +1,87 @@ module LoopTests- ( test_loopTests- , test_loopWithLeaksTests- )+ ( test_loopTests,+ test_loopWithLeaksTests,+ ) where -import Control.Eff.State.Strict-import Common-import Control.Eff.Concurrent.Process.SingleThreadedScheduler- as Scheduler-import Data.Text.IO as T+import Common+import Control.Eff.Concurrent.Process.SingleThreadedScheduler as Scheduler+import Control.Eff.State.Strict+import Data.Text.IO as T test_loopTests :: TestTree test_loopTests =- let soMany = 1000000- in- setTravisTestOptions $ testGroup- "Loops without space leaks"- [ testCase- "scheduleMonadIOEff with many yields from replicateCheapM_"- $ do lw <- consoleLogWriter- res <-- Scheduler.scheduleIOWithLogging lw- $ replicateCheapM_ soMany yieldProcess- res @=? Right ()- , testCase- "replicateCheapM_ of strict Int increments via the state effect"- $ do- let- res = run- (execState- (0 :: Int)- ( replicateCheapM_ soMany- $ modify (force . (+ 1))- )- )- res @=? soMany- , testCase- "'foreverCheap' inside a child process and 'replicateCheapM_' in the main process"- $ do- res <- Scheduler.scheduleIOWithLogging (MkLogWriter (T.putStrLn . (">>> " <>) . renderLogMessageConsoleLog))- $ do- me <- self- spawn_ "test" (foreverCheap $ sendMessage me ())- replicateCheapM_- soMany- (void (receiveMessage @()))-- res @=? Right ()- ]-+ let soMany = 1000000+ in setTravisTestOptions $+ testGroup+ "Loops without space leaks"+ [ testCase+ "scheduleMonadIOEff with many yields from replicateCheapM_"+ $ do+ lw <- consoleLogWriter+ res <-+ Scheduler.scheduleIOWithLogging lw $+ replicateCheapM_ soMany yieldProcess+ res @=? Right (),+ testCase+ "replicateCheapM_ of strict Int increments via the state effect"+ $ do+ let res =+ run+ ( execState+ (0 :: Int)+ ( replicateCheapM_ soMany $+ modify (force . (+ 1))+ )+ )+ res @=? soMany,+ testCase+ "'foreverCheap' inside a child process and 'replicateCheapM_' in the main process"+ $ do+ res <- Scheduler.scheduleIOWithLogging (MkLogWriter (T.putStrLn . (">>> " <>) . renderLogEventConsoleLog)) $+ do+ me <- self+ spawn_ "test" (foreverCheap $ sendMessage me ())+ replicateCheapM_+ soMany+ (void (receiveMessage @()))+ res @=? Right ()+ ] test_loopWithLeaksTests :: TestTree test_loopWithLeaksTests =- let soMany = 1000000- in- setTravisTestOptions $ testGroup- "Loops WITH space leaks"- [ testCase "scheduleMonadIOEff with many yields from replicateM_"- $ do- res <-- Scheduler.scheduleIOWithLogging (MkLogWriter (T.putStrLn . (">>> " <>) . renderLogMessageConsoleLog))- $ replicateM_ soMany yieldProcess- res @=? Right ()- , testCase- "replicateM_ of strict Int increments via the state effect"- $ do- let- res =- run- (execState- (0 :: Int)- ( replicateM_ soMany- $ modify (force . (+ 1))- )- )- res @=? soMany- , testCase- "'forever' inside a child process and 'replicateM_' in the main process"- $ do- res <-- Scheduler.scheduleIOWithLogging (MkLogWriter (T.putStrLn . (">>> " <>) . renderLogMessageConsoleLog))- $ do- me <- self- spawn_ "test" (forever $ sendMessage me ())- replicateM_ soMany- (void (receiveMessage @()))-- res @=? Right ()- ]+ let soMany = 1000000+ in setTravisTestOptions $+ testGroup+ "Loops WITH space leaks"+ [ testCase "scheduleMonadIOEff with many yields from replicateM_" $+ do+ res <-+ Scheduler.scheduleIOWithLogging (MkLogWriter (T.putStrLn . (">>> " <>) . renderLogEventConsoleLog)) $+ replicateM_ soMany yieldProcess+ res @=? Right (),+ testCase+ "replicateM_ of strict Int increments via the state effect"+ $ do+ let res =+ run+ ( execState+ (0 :: Int)+ ( replicateM_ soMany $+ modify (force . (+ 1))+ )+ )+ res @=? soMany,+ testCase+ "'forever' inside a child process and 'replicateM_' in the main process"+ $ do+ res <-+ Scheduler.scheduleIOWithLogging (MkLogWriter (T.putStrLn . (">>> " <>) . renderLogEventConsoleLog)) $+ do+ me <- self+ spawn_ "test" (forever $ sendMessage me ())+ replicateM_+ soMany+ (void (receiveMessage @()))+ res @=? Right ()+ ]
test/ObserverTests.hs view
@@ -1,304 +1,299 @@ {-# LANGUAGE UndecidableInstances #-}+ module ObserverTests- ( test_observer- ) where+ ( test_observer,+ )+where import Common import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as S import qualified Control.Eff.Concurrent.Protocol.Observer.Queue as OQ import qualified Control.Eff.Concurrent.Protocol.StatefulServer as M import Control.Lens-import Data.Typeable (Typeable) - test_observer :: HasCallStack => TestTree test_observer = testGroup "observer" (basicTests ++ [observerQueueTests]) - basicTests :: HasCallStack => [TestTree] basicTests =- [runTestCase "when no observer is present, nothing crashes"- $ do- testObservable <- S.startLink TestObservableServerInit- call testObservable (SendTestEvent "1")- cast testObservable StopTestObservable-- void $ awaitProcessDown (testObservable ^. fromEndpoint)-- , runTestCase "observers receive only messages sent after registration"- $ do- testObservable <- S.startLink TestObservableServerInit- call testObservable (SendTestEvent "1")- call testObservable (SendTestEvent "2")- call testObservable (SendTestEvent "3")- testObserver <- M.startLink MkTestObserver- registerObserver @String testObservable testObserver- call testObservable (SendTestEvent "4")- call testObservable (SendTestEvent "5")- es <- call testObserver GetCapturedEvents- lift (["4", "5"] @=? es)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "observers receive only messages sent before de-registration"- $ do- testObservable <- S.startLink TestObservableServerInit- call testObservable (SendTestEvent "1")- call testObservable (SendTestEvent "2")- call testObservable (SendTestEvent "3")- testObserver <- M.startLink MkTestObserver- registerObserver @String testObservable testObserver- call testObservable (SendTestEvent "4")- call testObservable (SendTestEvent "5")- forgetObserver @String testObservable testObserver- call testObservable (SendTestEvent "6")- call testObservable (SendTestEvent "7")- es <- call testObserver GetCapturedEvents- lift (["4", "5"] @=? es)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "observers receive only messages sent between registration and deregistration"- $ do- testObservable <- S.startLink TestObservableServerInit- call testObservable (SendTestEvent "1")- call testObservable (SendTestEvent "2")- call testObservable (SendTestEvent "3")- testObserver <- M.startLink MkTestObserver- registerObserver @String testObservable testObserver- call testObservable (SendTestEvent "4")- call testObservable (SendTestEvent "5")- forgetObserver @String testObservable testObserver- call testObservable (SendTestEvent "6")- registerObserver @String testObservable testObserver- call testObservable (SendTestEvent "7")- es <- call testObserver GetCapturedEvents- lift (["4", "5", "7"] @=? es)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "all observers receive all messages sent between registration and deregistration"- $ do- testObservable <- S.startLink TestObservableServerInit- call testObservable (SendTestEvent "1")- call testObservable (SendTestEvent "2")- call testObservable (SendTestEvent "3")- testObserver1 <- M.startLink MkTestObserver- testObserver2 <- M.startLink MkTestObserver- testObserver3 <- M.startLink MkTestObserver- registerObserver @String testObservable testObserver1- call testObservable (SendTestEvent "4")- registerObserver @String testObservable testObserver2- call testObservable (SendTestEvent "5")- registerObserver @String testObservable testObserver3- call testObservable (SendTestEvent "6")- forgetObserver @String testObservable testObserver1- call testObservable (SendTestEvent "7")- forgetObserver @String testObservable testObserver2- call testObservable (SendTestEvent "8")- forgetObserver @String testObservable testObserver3- call testObservable (SendTestEvent "9")- es1 <- call testObserver1 GetCapturedEvents- lift (["4", "5", "6"] @=? es1)- es2 <- call testObserver2 GetCapturedEvents- lift (["5", "6", "7"] @=? es2)- es3 <- call testObserver3 GetCapturedEvents- lift (["6", "7", "8"] @=? es3)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "when an observer exits, the messages are still deliviered to the others"- $ do- testObservable <- S.startLink TestObservableServerInit- call testObservable (SendTestEvent "1")- call testObservable (SendTestEvent "2")- call testObservable (SendTestEvent "3")- testObserver1 <- M.startLink MkTestObserver- testObserver2 <- M.startLink MkTestObserver- registerObserver @String testObservable testObserver1- registerObserver @String testObservable testObserver2- call testObservable (SendTestEvent "4")- call testObservable (SendTestEvent "5")- sendShutdown (testObserver2^.fromEndpoint) ExitNormally- void $ awaitProcessDown (testObserver2^.fromEndpoint)- call testObservable (SendTestEvent "6")- es1 <- call testObserver1 GetCapturedEvents- lift (["4", "5", "6"] @=? es1)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "evil observer monitoring"- $ do- testObservable <- S.startLink TestObservableServerInit- call testObservable (SendTestEvent "1")- call testObservable (SendTestEvent "2")- call testObservable (SendTestEvent "3")- testObserver1 <- M.startLink MkTestObserver- testObserver2 <- M.startLink MkTestObserver- registerObserver @String testObservable testObserver1- sendShutdown (testObserver2^.fromEndpoint) ExitNormally- void $ monitor (testObserver2^.fromEndpoint)- void $ awaitProcessDownAny- call testObservable (SendTestEvent "6")- es1 <- call testObserver1 GetCapturedEvents- lift (["6"] @=? es1)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "when an observer registers multiple times, it still gets the messages only once"- $ do- testObservable <- S.startLink TestObservableServerInit- call testObservable (SendTestEvent "1")- call testObservable (SendTestEvent "2")- call testObservable (SendTestEvent "3")- testObserver1 <- M.startLink MkTestObserver- registerObserver @String testObservable testObserver1- registerObserver @String testObservable testObserver1- call testObservable (SendTestEvent "4")- call testObservable (SendTestEvent "5")- call testObservable (SendTestEvent "6")- es1 <- call testObserver1 GetCapturedEvents- lift (["4", "5", "6"] @=? es1)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "when an observer is forgotton multiple times, nothing bad happens"- $ do- testObservable <- S.startLink TestObservableServerInit- call testObservable (SendTestEvent "1")- call testObservable (SendTestEvent "2")- call testObservable (SendTestEvent "3")- testObserver1 <- M.startLink MkTestObserver- registerObserver @String testObservable testObserver1- call testObservable (SendTestEvent "4")- call testObservable (SendTestEvent "5")- forgetObserver @String testObservable testObserver1- forgetObserver @String testObservable testObserver1- forgetObserver @String testObservable testObserver1- call testObservable (SendTestEvent "6")- es1 <- call testObserver1 GetCapturedEvents- lift (["4", "5"] @=? es1)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)+ [ runTestCase "when no observer is present, nothing crashes" $+ do+ testObservable <- S.startLink TestObservableServerInit+ call testObservable (SendTestEvent "1")+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "observers receive only messages sent after registration" $+ do+ testObservable <- S.startLink TestObservableServerInit+ call testObservable (SendTestEvent "1")+ call testObservable (SendTestEvent "2")+ call testObservable (SendTestEvent "3")+ testObserver <- M.startLink MkTestObserver+ registerObserver @String testObservable testObserver+ call testObservable (SendTestEvent "4")+ call testObservable (SendTestEvent "5")+ es <- call testObserver GetCapturedEvents+ lift (["4", "5"] @=? es)+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "observers receive only messages sent before de-registration" $+ do+ testObservable <- S.startLink TestObservableServerInit+ call testObservable (SendTestEvent "1")+ call testObservable (SendTestEvent "2")+ call testObservable (SendTestEvent "3")+ testObserver <- M.startLink MkTestObserver+ registerObserver @String testObservable testObserver+ call testObservable (SendTestEvent "4")+ call testObservable (SendTestEvent "5")+ forgetObserver @String testObservable testObserver+ call testObservable (SendTestEvent "6")+ call testObservable (SendTestEvent "7")+ es <- call testObserver GetCapturedEvents+ lift (["4", "5"] @=? es)+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "observers receive only messages sent between registration and deregistration" $+ do+ testObservable <- S.startLink TestObservableServerInit+ call testObservable (SendTestEvent "1")+ call testObservable (SendTestEvent "2")+ call testObservable (SendTestEvent "3")+ testObserver <- M.startLink MkTestObserver+ registerObserver @String testObservable testObserver+ call testObservable (SendTestEvent "4")+ call testObservable (SendTestEvent "5")+ forgetObserver @String testObservable testObserver+ call testObservable (SendTestEvent "6")+ registerObserver @String testObservable testObserver+ call testObservable (SendTestEvent "7")+ es <- call testObserver GetCapturedEvents+ lift (["4", "5", "7"] @=? es)+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "all observers receive all messages sent between registration and deregistration" $+ do+ testObservable <- S.startLink TestObservableServerInit+ call testObservable (SendTestEvent "1")+ call testObservable (SendTestEvent "2")+ call testObservable (SendTestEvent "3")+ testObserver1 <- M.startLink MkTestObserver+ testObserver2 <- M.startLink MkTestObserver+ testObserver3 <- M.startLink MkTestObserver+ registerObserver @String testObservable testObserver1+ call testObservable (SendTestEvent "4")+ registerObserver @String testObservable testObserver2+ call testObservable (SendTestEvent "5")+ registerObserver @String testObservable testObserver3+ call testObservable (SendTestEvent "6")+ forgetObserver @String testObservable testObserver1+ call testObservable (SendTestEvent "7")+ forgetObserver @String testObservable testObserver2+ call testObservable (SendTestEvent "8")+ forgetObserver @String testObservable testObserver3+ call testObservable (SendTestEvent "9")+ es1 <- call testObserver1 GetCapturedEvents+ lift (["4", "5", "6"] @=? es1)+ es2 <- call testObserver2 GetCapturedEvents+ lift (["5", "6", "7"] @=? es2)+ es3 <- call testObserver3 GetCapturedEvents+ lift (["6", "7", "8"] @=? es3)+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "when an observer exits, the messages are still deliviered to the others" $+ do+ testObservable <- S.startLink TestObservableServerInit+ call testObservable (SendTestEvent "1")+ call testObservable (SendTestEvent "2")+ call testObservable (SendTestEvent "3")+ testObserver1 <- M.startLink MkTestObserver+ testObserver2 <- M.startLink MkTestObserver+ registerObserver @String testObservable testObserver1+ registerObserver @String testObservable testObserver2+ call testObservable (SendTestEvent "4")+ call testObservable (SendTestEvent "5")+ sendShutdown (testObserver2 ^. fromEndpoint) ExitNormally+ void $ awaitProcessDown (testObserver2 ^. fromEndpoint)+ call testObservable (SendTestEvent "6")+ es1 <- call testObserver1 GetCapturedEvents+ lift (["4", "5", "6"] @=? es1)+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "evil observer monitoring" $+ do+ testObservable <- S.startLink TestObservableServerInit+ call testObservable (SendTestEvent "1")+ call testObservable (SendTestEvent "2")+ call testObservable (SendTestEvent "3")+ testObserver1 <- M.startLink MkTestObserver+ testObserver2 <- M.startLink MkTestObserver+ registerObserver @String testObservable testObserver1+ sendShutdown (testObserver2 ^. fromEndpoint) ExitNormally+ void $ monitor (testObserver2 ^. fromEndpoint)+ void $ awaitProcessDownAny+ call testObservable (SendTestEvent "6")+ es1 <- call testObserver1 GetCapturedEvents+ lift (["6"] @=? es1)+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "when an observer registers multiple times, it still gets the messages only once" $+ do+ testObservable <- S.startLink TestObservableServerInit+ call testObservable (SendTestEvent "1")+ call testObservable (SendTestEvent "2")+ call testObservable (SendTestEvent "3")+ testObserver1 <- M.startLink MkTestObserver+ registerObserver @String testObservable testObserver1+ registerObserver @String testObservable testObserver1+ call testObservable (SendTestEvent "4")+ call testObservable (SendTestEvent "5")+ call testObservable (SendTestEvent "6")+ es1 <- call testObserver1 GetCapturedEvents+ lift (["4", "5", "6"] @=? es1)+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "when an observer is forgotton multiple times, nothing bad happens" $+ do+ testObservable <- S.startLink TestObservableServerInit+ call testObservable (SendTestEvent "1")+ call testObservable (SendTestEvent "2")+ call testObservable (SendTestEvent "3")+ testObserver1 <- M.startLink MkTestObserver+ registerObserver @String testObservable testObserver1+ call testObservable (SendTestEvent "4")+ call testObservable (SendTestEvent "5")+ forgetObserver @String testObservable testObserver1+ forgetObserver @String testObservable testObserver1+ forgetObserver @String testObservable testObserver1+ call testObservable (SendTestEvent "6")+ es1 <- call testObserver1 GetCapturedEvents+ lift (["4", "5"] @=? es1)+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint) ] observerQueueTests :: TestTree observerQueueTests =- testGroup "observer-queue"- [ runTestCase "tryRead"- $ do+ testGroup+ "observer-queue"+ [ runTestCase "tryRead" $+ do testObservable <- S.startLink TestObservableServerInit let len :: Int len = 1- OQ.observe @String len testObservable $ do+ OQ.observe @String len testObservable $ do OQ.tryRead @String >>= lift . (Nothing @=?) call testObservable (SendTestEvent "1") OQ.tryRead @String >>= lift . (Just "1" @=?)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "observe then read"- $ do+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "observe then read" $+ do testObservable <- S.startLink TestObservableServerInit let len :: Int len = 1- OQ.observe @String len testObservable $ do+ OQ.observe @String len testObservable $ do call testObservable (SendTestEvent "1") OQ.await @String >>= lift . ("1" @=?) call testObservable (SendTestEvent "2") OQ.await @String >>= lift . ("2" @=?) call testObservable (SendTestEvent "3") OQ.await @String >>= lift . ("3" @=?)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "FIFO"- $ do+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "FIFO" $+ do testObservable <- S.startLink TestObservableServerInit let len :: Int len = 3- OQ.observe @String len testObservable $ do+ OQ.observe @String len testObservable $ do call testObservable (SendTestEvent "1") call testObservable (SendTestEvent "2") call testObservable (SendTestEvent "3") OQ.await @String >>= lift . ("1" @=?) OQ.await @String >>= lift . ("2" @=?) OQ.await @String >>= lift . ("3" @=?)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "flush"- $ do+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "flush" $+ do testObservable <- S.startLink TestObservableServerInit let len :: Int len = 3- OQ.observe @String len testObservable $ do+ OQ.observe @String len testObservable $ do call testObservable (SendTestEvent "1") call testObservable (SendTestEvent "2") call testObservable (SendTestEvent "3") OQ.flush @String >>= lift . (["1", "2", "3"] @=?) OQ.tryRead @String >>= lift . (Nothing @=?)- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "when the queue is full, new observations are dropped"- $ do- testObservable <- S.startLink TestObservableServerInit- let len :: Int- len = 2- OQ.observe @String len testObservable $ do- call testObservable (SendTestEvent "1")- call testObservable (SendTestEvent "2")- call testObservable (SendTestEvent "3")- call testObservable (SendTestEvent "4")- OQ.await @String >>= lift . ("1" @=?)- OQ.await @String >>= lift . ("2" @=?)- OQ.tryRead @String >>= lift . (Nothing @=?)-- cast testObservable StopTestObservable- void $ awaitProcessDown (testObservable ^. fromEndpoint)- , runTestCase "flush after queue full"- $ do+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "when the queue is full, new observations are dropped" $+ do testObservable <- S.startLink TestObservableServerInit let len :: Int+ len = 2+ OQ.observe @String len testObservable $ do+ call testObservable (SendTestEvent "1")+ call testObservable (SendTestEvent "2")+ call testObservable (SendTestEvent "3")+ call testObservable (SendTestEvent "4")+ OQ.await @String >>= lift . ("1" @=?)+ OQ.await @String >>= lift . ("2" @=?)+ OQ.tryRead @String >>= lift . (Nothing @=?)+ cast testObservable StopTestObservable+ void $ awaitProcessDown (testObservable ^. fromEndpoint),+ runTestCase "flush after queue full" $+ do+ testObservable <- S.startLink TestObservableServerInit+ let len :: Int len = 3- OQ.observe @String len testObservable $ do+ OQ.observe @String len testObservable $ do call testObservable (SendTestEvent "1") call testObservable (SendTestEvent "2") call testObservable (SendTestEvent "3") call testObservable (SendTestEvent "4") call testObservable (SendTestEvent "5")+ delay (TimeoutMicros 100_000) OQ.flush @String >>= lift . (["1", "2", "3"] @=?)+ delay (TimeoutMicros 100_000) OQ.flush @String >>= lift . ([] @=?)+ delay (TimeoutMicros 100_000) OQ.tryRead @String >>= lift . (Nothing @=?)+ delay (TimeoutMicros 100_000) call testObservable (SendTestEvent "6") OQ.await @String >>= lift . ("6" @=?)- cast testObservable StopTestObservable void $ awaitProcessDown (testObservable ^. fromEndpoint)- ]-+ ] -data TestObservable deriving Typeable+data TestObservable deriving (Typeable) instance HasPdu TestObservable where- type instance EmbeddedPduList TestObservable = '[ObserverRegistry String]- data Pdu TestObservable r where- SendTestEvent :: String -> Pdu TestObservable ('Synchronous ())- StopTestObservable :: Pdu TestObservable 'Asynchronous- TestObsReg :: Pdu (ObserverRegistry String) r -> Pdu TestObservable r- deriving (Typeable)+ type EmbeddedPduList TestObservable = '[ObserverRegistry String]+ data Pdu TestObservable r where+ SendTestEvent :: String -> Pdu TestObservable ('Synchronous ())+ StopTestObservable :: Pdu TestObservable 'Asynchronous+ TestObsReg :: Pdu (ObserverRegistry String) r -> Pdu TestObservable r+ deriving (Typeable) instance HasPduPrism TestObservable (ObserverRegistry String) where embedPdu = TestObsReg fromPdu (TestObsReg x) = Just x fromPdu _ = Nothing -instance Typeable r => NFData (Pdu TestObservable r) where+instance NFData (Pdu TestObservable r) where rnf (SendTestEvent s) = rnf s rnf StopTestObservable = () rnf (TestObsReg x) = rnf x -instance Typeable r => Show (Pdu TestObservable r) where- show (SendTestEvent x) = "SendTestEvent " ++ show x- show StopTestObservable = "StopTestObservable"- show (TestObsReg x) = "TestObsReg " ++ show x+instance ToLogMsg (Pdu TestObservable r) where+ toLogMsg (SendTestEvent x) = "SendTestEvent " <> toLogMsg x+ toLogMsg StopTestObservable = "StopTestObservable"+ toLogMsg (TestObsReg x) = "TestObsReg " <> toLogMsg x instance (IoLogging r, HasProcesses r q) => S.Server TestObservable r where- data Init TestObservable = TestObservableServerInit+ data Init TestObservable = TestObservableServerInit deriving (Show) type ServerEffects TestObservable r = ObserverRegistryState String ': r runEffects _ _ = evalObserverRegistryState onEvent _ _ =@@ -306,49 +301,57 @@ S.OnCall rt e -> case e of SendTestEvent x -> observerRegistryNotify x >> sendReply rt ()- TestObsReg x -> logError ("unexpected: " <> pack (show x))+ TestObsReg x -> logError (LABEL "unexpected" x) S.OnCast (TestObsReg x) -> observerRegistryHandlePdu x S.OnCast StopTestObservable -> exitNormally S.OnDown pd -> do- logDebug ("inspecting: " <> pack (show pd))+ logDebug (LABEL "inspecting" pd) wasHandled <- observerRegistryRemoveProcess @String (downProcess pd) unless wasHandled $- logError ("the process down message was not handled: " <> pack (show pd))+ logError (LABEL "the process down message was not handled" pd) other ->- logError ("unexpected: " <> pack (show other))+ logError (LABEL "unexpected" other) +instance ToLogMsg (S.Init TestObservable) -data TestObserver deriving Typeable+instance ToTypeLogMsg TestObservable where+ toTypeLogMsg _ = "TestObservable" +data TestObserver deriving (Typeable)+ instance HasPdu TestObserver where type EmbeddedPduList TestObserver = '[Observer String] data Pdu TestObserver r where GetCapturedEvents :: Pdu TestObserver ('Synchronous [String]) OnTestEvent :: Pdu (Observer String) r -> Pdu TestObserver r- deriving Typeable+ deriving (Typeable) instance NFData (Pdu TestObserver r) where rnf GetCapturedEvents = ()- rnf (OnTestEvent e) = rnf e+ rnf (OnTestEvent e) = rnf e -instance Show (Pdu TestObserver r) where- showsPrec _ GetCapturedEvents = showString "GetCapturedEvents"- showsPrec d (OnTestEvent e) = showParen (d>=10) (showString "OnTestEvent " . shows e)+instance ToLogMsg (Pdu TestObserver r) where+ toLogMsg GetCapturedEvents = "GetCapturedEvents"+ toLogMsg (OnTestEvent e) = "OnTestEvent " <> toLogMsg e instance HasPduPrism TestObserver (Observer String) where embedPdu = OnTestEvent fromPdu (OnTestEvent e) = Just e fromPdu _ = Nothing - instance (IoLogging r, HasProcesses r q) => M.Server TestObserver r where- data StartArgument TestObserver = MkTestObserver- newtype instance Model TestObserver = TestObserverModel {fromTestObserverModel :: [String]} deriving Default+ data StartArgument TestObserver = MkTestObserver deriving (Show)+ newtype Model TestObserver = TestObserverModel {fromTestObserverModel :: [String]} deriving (Default) update _ MkTestObserver e = case e of M.OnCall rt GetCapturedEvents -> M.getAndPutModel (TestObserverModel []) >>= sendReply rt . fromTestObserverModel M.OnCast (OnTestEvent (Observed x)) ->- M.modifyModel (\ (TestObserverModel o) -> TestObserverModel (o ++ [x]))+ M.modifyModel (\(TestObserverModel o) -> TestObserverModel (o ++ [x])) _ ->- logError ("unexpected: " <> pack (show e))+ logError (MSG "unexpected: ") e++instance ToLogMsg (M.StartArgument TestObserver)++instance ToTypeLogMsg TestObserver where+ toTypeLogMsg _ = "TestObserver"
test/ProcessBehaviourTestCases.hs view
@@ -1,1261 +1,1316 @@ module ProcessBehaviourTestCases where -import Common-import Control.Exception-import qualified Control.Eff.Concurrent.Protocol.CallbackServer- as Callback-import Control.Eff.Concurrent.Protocol.EffectfulServer-import qualified Control.Eff.Concurrent.Process.ForkIOScheduler- as ForkIO-import qualified Control.Eff.Concurrent.Process.SingleThreadedScheduler- as SingleThreaded-import Control.Applicative-import Data.List ( sort )-import Data.Foldable ( traverse_ )-import Data.Maybe-import Data.Void-import GHC.Generics ( Generic )-import Data.String ( fromString )---testInterruptReason :: Interrupt 'Recoverable-testInterruptReason = ErrorInterrupt "test interrupt"--test_forkIo :: TestTree-test_forkIo = setTravisTestOptions $ withTestLogC- (\c -> do- lw <- stdoutLogWriter renderConsoleMinimalisticWide- runLift- $ withLogging- (filteringLogWriter (lmSeverityIsAtLeast errorSeverity)- lw- )- $ withAsyncLogWriter (100 :: Int)- $ ForkIO.schedule c- )- (\factory -> testGroup "ForkIOScheduler" [allTests factory])---test_singleThreaded :: TestTree-test_singleThreaded = setTravisTestOptions $ withTestLogC- (\e ->- let runEff :: Eff LoggingAndIo a -> IO a- runEff e' = do- lw <- stdoutLogWriter renderConsoleMinimalisticWide- runLift- $ withLogging- (filteringLogWriter (lmSeverityIsAtLeast errorSeverity) lw)- e'- in void $ SingleThreaded.scheduleM runEff yield e- )- (\factory -> testGroup "SingleThreadedScheduler" [allTests factory])--allTests- :: forall r- . (IoLogging r, Typeable r)- => IO (Eff (Processes r) () -> IO ())- -> TestTree-allTests schedulerFactory = localOption- (timeoutSeconds 300)- (testGroup- "Process"- [ errorTests schedulerFactory- , sendShutdownTests schedulerFactory- , concurrencyTests schedulerFactory- , exitTests schedulerFactory- , pingPongTests schedulerFactory- , yieldLoopTests schedulerFactory- , delayTests schedulerFactory- , selectiveReceiveTests schedulerFactory- , linkingTests schedulerFactory- , monitoringTests schedulerFactory- , timerTests schedulerFactory- , processDetailsTests schedulerFactory- ]- )--data ReturnToSender- deriving Typeable--type instance ToPretty ReturnToSender = PutStr "ReturnToSender"--instance HasPdu ReturnToSender where- data instance Pdu ReturnToSender r where- ReturnToSender :: ProcessId -> String -> Pdu ReturnToSender ('Synchronous Bool)- StopReturnToSender :: Pdu ReturnToSender ('Synchronous ())--instance NFData (Pdu ReturnToSender r) where- rnf (ReturnToSender p s) = rnf p `seq` rnf s- rnf StopReturnToSender = ()--deriving instance Show (Pdu ReturnToSender x)--deriving instance Typeable (Pdu ReturnToSender x)--returnToSender- :: forall q r- . (HasCallStack, HasProcesses r q)- => Endpoint ReturnToSender- -> String- -> Eff r Bool-returnToSender toP msg = do- me <- self- _ <- call toP (ReturnToSender me msg)- msgEcho <- receiveMessage @String- return (msgEcho == msg)--stopReturnToSender- :: forall q r- . (HasCallStack, HasProcesses r q)- => Endpoint ReturnToSender- -> Eff r ()-stopReturnToSender toP = call toP StopReturnToSender--returnToSenderServer- :: forall q- . (HasCallStack, IoLogging q, Typeable q)- => Eff (Processes q) (Endpoint ReturnToSender)-returnToSenderServer = Callback.startLink @ReturnToSender $ Callback.onEvent- (\evt -> case evt of- OnCall rt msg -> case msg of- StopReturnToSender -> interrupt testInterruptReason- ReturnToSender fromP echoMsg -> do- sendMessage fromP echoMsg- yieldProcess- sendReply rt True- OnInterrupt i -> interrupt i- other -> interrupt (ErrorInterrupt (show other))- )- "return-to-sender"--selectiveReceiveTests- :: forall r- . (IoLogging r, Typeable r)- => IO (Eff (Processes r) () -> IO ())- -> TestTree-selectiveReceiveTests schedulerFactory = setTravisTestOptions- (testGroup- "selective receive tests"- [ testCase "send 10 messages (from 1..10) and receive messages from 10 to 1"- $ applySchedulerFactory schedulerFactory- $ do- let- nMax = 10- receiverLoop donePid = go nMax- where- go :: Int -> Eff (Processes r) ()- go 0 = sendMessage donePid True- go n = do- void $ receiveSelectedMessage (filterMessage (== n))- go (n - 1)-- senderLoop destination =- traverse_ (sendMessage destination) [1 .. nMax]-- me <- self- receiverPid2 <- spawn "reciever loop" (receiverLoop me)- spawn_ "sender loop" (senderLoop receiverPid2)- ok <- receiveMessage @Bool- lift (ok @? "selective receive failed")- , testCase "receive a message while waiting for a call reply"- $ applySchedulerFactory schedulerFactory- $ do- srv <- returnToSenderServer- ok <- returnToSender srv "test"- () <- stopReturnToSender srv- lift (ok @? "selective receive failed")- , testCase "when sending multiple messages, it is possible to receive them selectively in any order"- $ applySchedulerFactory schedulerFactory- $ do- me <- self- let messages :: [Int]- messages = [1 .. 100]- mRefs <- traverse- (\i ->- spawn (fromString ("sender-" ++ show i))- (yieldProcess >> sendMessage me i >> logInfo ("sent: " <> pack (show i)))- >>= monitor)- messages- traverse_- (\i ->- receiveSelectedMessage (filterMessage (== i))- >>= logInfo . ("received: " <> ) . pack . show)- messages- traverse_- (\(mref, i) ->- logInfo ("waiting for " <> pack (show mref) <> " of " <> pack (show i))- >> receiveSelectedMessage (selectProcessDown mref)- >>= logInfo . (("down: " <> pack (show i) <> " ") <> ) . pack . show)- (mRefs `zip` messages)-- , testCase "flush messages" $ applySchedulerFactory schedulerFactory $ do- me <- self- spawn_ "sender-bool"- $ replicateM_ 10 (sendMessage me True)- >> sendMessage me ()- spawn_ "sender-float"- $ replicateM_ 10 (sendMessage me (123.23411 :: Float))- >> sendMessage me ()- spawn_ "sender-string"- $ replicateM_ 10 (sendMessage me ("123" :: String))- >> sendMessage me ()- () <- receiveMessage- () <- receiveMessage- () <- receiveMessage- -- replicateCheapM_ 40 yieldProcess- messages <- flushMessages- lift (length messages @?= 30)- ]- )---delayTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-delayTests schedulerFactory =- let maxN = 100000- in setTravisTestOptions- (testGroup- "delay tests"- [ testCase- "delay many times (forM_)"- (applySchedulerFactory- schedulerFactory- (forM_ [1 :: Int .. maxN] (\_ -> delay (TimeoutMicros 1)))- )- , testCase- "process can be interrupted during a delay"- (applySchedulerFactory- schedulerFactory- (do- me <- self- sleeper <- spawn "sleeper"- (tryUninterrupted (delay (TimeoutMicros 10_000_000)) >>= sendMessage me)- delay (TimeoutMicros 1_000)- let expected = TimeoutInterrupt "test timeout interrupt"- sendInterrupt sleeper expected- receiveMessage @(Either (Interrupt 'Recoverable) ()) >>= lift . assertEqual "wrong message" (Left expected)- )- )- , testCase- "messages are enqueued for a process that is currently delaying"- (applySchedulerFactory- schedulerFactory- (do- me <- self- sleeper <- spawn "sleeper"- (do sendMessage me True- delay (TimeoutMicros 500_000)- receiveMessage @Int >>= sendMessage me- receiveMessage @Int >>= sendMessage me- receiveMessage @Int >>= sendMessage me- )- let x1, x2, x3 :: Int- [x1,x2,x3] = [1..3]- receiveMessage >>= lift . assertBool "sleeper not started"- sendMessage sleeper x1- sendMessage sleeper x2- sendMessage sleeper x3- receiveMessage @Int >>= lift . assertEqual "wrong message 1" x1- receiveMessage @Int >>= lift . assertEqual "wrong message 2" x2- receiveMessage @Int >>= lift . assertEqual "wrong message 3" x3- )- )- ]- )--yieldLoopTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-yieldLoopTests schedulerFactory =- let maxN = 100000- in setTravisTestOptions- (testGroup- "yield tests"- [ testCase- "yield many times (replicateM_)"- (applySchedulerFactory schedulerFactory- (replicateM_ maxN yieldProcess)- )- , testCase- "yield many times (forM_)"- (applySchedulerFactory- schedulerFactory- (forM_ [1 :: Int .. maxN] (\_ -> yieldProcess))- )- , testCase- "construct an effect with an exit first, followed by many yields"- (applySchedulerFactory- schedulerFactory- (do- void exitNormally- replicateM_ 1000000000000 yieldProcess- )- )- ]- )---newtype Ping = Ping ProcessId- deriving (Eq, Show, Typeable, NFData)--data Pong = Pong- deriving (Eq, Show, Generic)--instance NFData Pong--pingPongTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-pingPongTests schedulerFactory = testGroup- "Yield Tests"- [ testCase "ping pong a message between two processes, both don't yield"- $ applySchedulerFactory schedulerFactory- $ do- let pongProc = foreverCheap $ do- Ping pinger <- receiveMessage- sendMessage pinger Pong- pingProc ponger parent = do- me <- self- sendMessage ponger (Ping me)- Pong <- receiveMessage- sendMessage parent True- pongPid <- spawn "pong" pongProc- me <- self- spawn_ "ping" (pingProc pongPid me)- ok <- receiveMessage @Bool- lift (ok @? "ping pong failed")- , testCase "ping pong a message between two processes, with massive yielding"- $ applySchedulerFactory schedulerFactory- $ do- yieldProcess- let pongProc = foreverCheap $ do- yieldProcess- Ping pinger <- receiveMessage- yieldProcess- sendMessage pinger Pong- yieldProcess- pingProc ponger parent = do- yieldProcess- me <- self- yieldProcess- sendMessage ponger (Ping me)- yieldProcess- Pong <- receiveMessage- yieldProcess- sendMessage parent True- yieldProcess- yieldProcess- pongPid <- spawn "pong" pongProc- yieldProcess- me <- self- yieldProcess- spawn_ "ping" (pingProc pongPid me)- yieldProcess- ok <- receiveMessage @Bool- yieldProcess- lift (ok @? "ping pong failed")- yieldProcess- , testCase- "the first message is not delayed, not even in cooperative scheduling (because of yield)"- $ applySchedulerFactory schedulerFactory- $ do- pongVar <- lift newEmptyMVar- let pongProc = foreverCheap $ do- Pong <- receiveMessage- lift (putMVar pongVar Pong)- ponger <- spawn "pong" pongProc- sendMessage ponger Pong- let waitLoop = do- p <- lift (tryTakeMVar pongVar)- case p of- Nothing -> do- yieldProcess- waitLoop- Just r -> return r- p <- waitLoop- lift (p == Pong @? "ping pong failed")- ]--errorTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-errorTests schedulerFactory = testGroup- "causing and handling errors"- [ testGroup- "exitWithError"- [ testCase "unhandled exitWithError"- $ applySchedulerFactory schedulerFactory- $ do- void $ exitWithError "test error"- error "This should not happen"- , testCase "cannot catch exitWithError"- $ applySchedulerFactory schedulerFactory- $ do- void $ exitWithError "test error 4"- error "This should not happen"- , testCase "multi process exitWithError"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- let n = 15- traverse_- (\(i :: Int) -> spawn "test" $ foreverCheap- (void- ( sendMessage (888888 + fromIntegral i)- ("test message" :: String)- >> yieldProcess- )- )- )- [0 .. n]- traverse_- (\(i :: Int) -> spawn "test" $ do- void $ sendMessage me i- void (exitWithError (show i ++ " died"))- error "this should not be reached"- )- [0 .. n]- oks <- replicateM (length [0 .. n]) receiveMessage- assertEff "" (sort oks == [0 .. n])- ]- ]--concurrencyTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-concurrencyTests schedulerFactory =- let n = 100- in- testGroup- "concurrency tests"- [ testCase- "when main process exits the scheduler kills/cleans and returns"- $ applySchedulerFactory schedulerFactory- $ do- me <- self- traverse_- (const- (spawn- "reciever"- (do- m <- receiveAnyMessage- void (sendAnyMessage me m)- )- )- )- [1 .. n]- lift (threadDelay 1000)- , testCase "new processes are executed before the parent process"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do -- start massive amount of children that exit as soon as they are- -- executed, this will only work smoothly when scheduler schedules- -- the new child before the parent- traverse_ (const (spawn "lemming" exitNormally)) [1 .. n]- assertEff "" True- , testCase "two concurrent processes"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- child1 <- spawn- "reciever"- (do- m <- receiveAnyMessage- void (sendAnyMessage me m)- )- child2 <- spawn- "sender"- (foreverCheap (void (sendMessage 888888 ("" :: String))))- sendMessage child1 ("test" :: String)- i <- receiveMessage- sendInterrupt child2 testInterruptReason- assertEff "" (i == ("test" :: String))- , testCase "most processes send foreverCheap"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- traverse_- (\(i :: Int) -> spawn "sender" $ do- when (i `rem` 5 == 0) $ void $ sendMessage me i- foreverCheap- $ void (sendMessage 888 ("test message to 888" :: String))- )- [0 .. n]- oks <- replicateM (length [0, 5 .. n]) receiveMessage- assertEff "" (sort oks == [0, 5 .. n])- , testCase "most processes self foreverCheap"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- traverse_- (\(i :: Int) -> spawn "sender" $ do- when (i `rem` 5 == 0) $ void $ sendMessage me i- foreverCheap $ void self- )- [0 .. n]- oks <- replicateM (length [0, 5 .. n]) receiveMessage- assertEff "" (sort oks == [0, 5 .. n])- , testCase "most processes sendShutdown foreverCheap"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- traverse_- (\(i :: Int) -> spawn "killer" $ do- when (i `rem` 5 == 0) $ void $ sendMessage me i- foreverCheap $ void (sendShutdown 999 ExitNormally)- )- [0 .. n]- oks <- replicateM (length [0, 5 .. n]) receiveMessage- assertEff "" (sort oks == [0, 5 .. n])- , testCase "most processes spawn foreverCheap"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- traverse_- (\(i :: Int) -> spawn "sender 0" $ do- when (i `rem` 5 == 0) $ void $ sendMessage me i- parent <- self- foreverCheap $ void- (spawn- "sender"- (void (sendMessage parent ("test msg from child" :: String))- )- )- )- [0 .. n]- oks <- replicateM (length [0, 5 .. n]) receiveMessage- assertEff "" (sort oks == [0, 5 .. n])- , testCase "most processes receive foreverCheap"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- traverse_- (\(i :: Int) -> spawn "sender" $ do- when (i `rem` 5 == 0) $ void $ sendMessage me i- foreverCheap $ void receiveAnyMessage- )- [0 .. n]- oks <- replicateM (length [0, 5 .. n]) receiveMessage- assertEff "" (sort oks == [0, 5 .. n])- ]--exitTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-exitTests schedulerFactory =- testGroup "process exit tests"- $ [ testGroup- "async exceptions"- [ testCase- ( "a process dies immediately if a "- ++ show e- ++ " is thrown, while "- ++ busyWith- )- $ do- tidVar <- newEmptyTMVarIO- schedulerDoneVar <- newEmptyTMVarIO- void $ forkIO $ do- void- $ try @SomeException- $ void- $ applySchedulerFactory schedulerFactory- $ do- tid <- lift $ myThreadId- lift $ atomically $ putTMVar tidVar tid- foreverCheap busyEffect- atomically $ putTMVar schedulerDoneVar ()- tid <- atomically $ takeTMVar tidVar- threadDelay 1000- throwTo tid e- void $ atomically $ takeTMVar schedulerDoneVar- | e <- [ThreadKilled, UserInterrupt, HeapOverflow, StackOverflow]- , (busyWith, busyEffect) <-- [ ( "receiving"- , void- (send- (ReceiveSelectedMessage @r- (filterMessage (== ("test message" :: String)))- )- )- )- , ( "sending"- , void- (send- (SendMessage @r 44444- (toStrictDynamic ("test message" :: String))- )- )- )- , ( "sending shutdown"- , void (send (SendShutdown @r 44444 ExitNormally))- )- , ("selfpid-ing", void (send (SelfPid @r)))- , ( "spawn-ing"- , void- (send- (Spawn @r- "reciever"- (void (send (ReceiveSelectedMessage @r selectAnyMessage)))- )- )- )- , ("sleeping", lift (threadDelay 100000))- ]- ]- , testGroup- "main thread exit not blocked by"- [ testCase ("a child process, busy with " ++ busyWith)- $ applySchedulerFactory schedulerFactory- $ do- void $ spawn "busyloop" $ foreverCheap busyEffect- lift (threadDelay 10000)- | (busyWith, busyEffect) <-- [ ( "receiving"- , void- (send- (ReceiveSelectedMessage @r- (filterMessage (== ("test message" :: String)))- )- )- )- , ( "sending"- , void- (send- (SendMessage @r 44444- (toStrictDynamic ("test message" :: String))- )- )- )- , ( "sending shutdown"- , void (send (SendShutdown @r 44444 ExitNormally))- )- , ("selfpid-ing", void (send (SelfPid @r)))- , ( "spawn-ing"- , void- (send- (Spawn @r- "reciever"- (void (send (ReceiveSelectedMessage @r selectAnyMessage)))- )- )- )- ]- ]- , testGroup- "one process exits, the other continues unimpaired"- [ testCase- ( "process 2 exits with: "- ++ howToExit- ++ " - while process 1 is busy with: "- ++ busyWith- )- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- p1 <- spawn "busyloop" $ foreverCheap busyEffect- lift (threadDelay 1000)- void $ spawn "sleep loop" $ do- lift (threadDelay 1000)- doExit- lift (threadDelay 100000)- wasRunningP1 <- isProcessAlive p1- sendShutdown p1 ExitNormally- lift (threadDelay 100000)- stillRunningP1 <- isProcessAlive p1- assertEff "the other process did not die still running"- (not stillRunningP1 && wasRunningP1)- | (busyWith , busyEffect) <-- [ ( "receiving"- , void- (send- (ReceiveSelectedMessage @r- (filterMessage (== ("test message" :: String)))- )- )- )- , ( "sending"- , void- (send- (SendMessage @r 44444- (toStrictDynamic ("test message" :: String))- )- )- )- , ( "sending shutdown"- , void (send (SendShutdown @r 44444 ExitNormally))- )- , ("selfpid-ing", void (send (SelfPid @r)))- , ( "spawn-ing"- , void- (send- (Spawn @r- "receiver"- (void (send (ReceiveSelectedMessage @r selectAnyMessage)))- )- )- )- ]- , (howToExit, doExit ) <-- [ ("normally" , void exitNormally)- , ("simply returning", return ())- , ( "raiseError"- , void (interrupt (ErrorInterrupt "test error raised"))- )- , ("exitWithError", void (exitWithError "test error exit"))- , ( "sendShutdown to self"- , do- me <- self- void (sendShutdown me ExitNormally)- )- ]- ]- ]---sendShutdownTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-sendShutdownTests schedulerFactory = testGroup- "sendShutdown"- [ testCase "... self" $ applySchedulerFactory schedulerFactory $ do- me <- self- void $ send (SendShutdown @r me ExitNormally)- interrupt (ErrorInterrupt "sendShutdown must not return")- , testCase "sendInterrupt to self"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- r <- send (SendInterrupt @r me (ErrorInterrupt "123"))- assertEff- "Interrupted must be returned"- (case r of- Interrupted (ErrorInterrupt "123") -> True- _ -> False- )- , testGroup- "... other process"- [ testCase "while it is sending"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- other <- spawn- "interrupted"- (do- untilInterrupted- (SendMessage @r 666666 (toStrictDynamic ("test" :: String)))- void (sendMessage me ("OK" :: String))- )- void (sendInterrupt other testInterruptReason)- a <- receiveMessage- assertEff "" (a == ("OK" :: String))- , testCase "while it is receiving"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- other <- spawn- "interrupted"- (do- untilInterrupted (ReceiveSelectedMessage @r selectAnyMessage)- void (sendMessage me ("OK" :: String))- )- void (sendInterrupt other testInterruptReason)- a <- receiveMessage- assertEff "" (a == ("OK" :: String))- , testCase "while it is self'ing"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- other <- spawn- "interrupted"- (do- untilInterrupted (SelfPid @r)- void (sendMessage me ("OK" :: String))- )- void (sendInterrupt other (ErrorInterrupt "testError"))- (a :: String) <- receiveMessage- assertEff "" (a == "OK")- , testCase "while it is spawning"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- other <- spawn- "interrupted"- (do- untilInterrupted (Spawn @r "returner" (return ()))- void (sendMessage me ("OK" :: String))- )- void (sendInterrupt other testInterruptReason)- a <- receiveMessage- assertEff "" (a == ("OK" :: String))- , testCase "while it is sending shutdown messages"- $ scheduleAndAssert schedulerFactory- $ \assertEff -> do- me <- self- other <- spawn- "interrupted"- (do- untilInterrupted (SendShutdown @r 777 ExitNormally)- void (sendMessage me ("OK" :: String))- )- void (sendInterrupt other testInterruptReason)- a <- receiveMessage- assertEff "" (a == ("OK" :: String))- , testCase "handleInterrupt handles my own interrupts"- $ scheduleAndAssert schedulerFactory- $ \assertEff ->- handleInterrupts (\e -> return (ErrorInterrupt "test" == e))- (interrupt (ErrorInterrupt "test") >> return False)- >>= assertEff "exception handler not invoked"- ]- ]--linkingTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-linkingTests schedulerFactory = setTravisTestOptions- (testGroup- "process linking tests"- [ testCase "link process with it self"- $ applySchedulerFactory schedulerFactory- $ do- me <- self- handleInterrupts- (\er -> lift (False @? ("unexpected interrupt: " ++ show er)))- (do- linkProcess me- lift (threadDelay 10000)- )- , testCase "link with not running process"- $ applySchedulerFactory schedulerFactory- $ do- let testPid = 234234234- handleInterrupts- (lift . (@?= LinkedProcessCrashed testPid))- (do- linkProcess testPid- void (receiveMessage @Void)- )- , testCase "linked process exit message is NormalExit"- $ applySchedulerFactory schedulerFactory- $ do- foo <- spawn "reciever" (void (receiveMessage @Void))- handleInterrupts- (lift . (\e -> e /= LinkedProcessCrashed foo @? show e))- (do- linkProcess foo- sendShutdown foo ExitNormally- lift (threadDelay 1000)- )- , testCase "linked process exit message is Crash"- $ applySchedulerFactory schedulerFactory- $ do- foo <- spawn "reciever" (void (receiveMessage @Void))- handleInterrupts- (lift . (@?= LinkedProcessCrashed foo))- (do- linkProcess foo- self >>= sendShutdown foo . ExitProcessCancelled . Just- void (receiveMessage @Void)- )- , testCase "link multiple times"- $ applySchedulerFactory schedulerFactory- $ do- foo <- spawn "reciever" (void (receiveMessage @Void))- handleInterrupts- (lift . (@?= LinkedProcessCrashed foo))- (do- linkProcess foo- linkProcess foo- linkProcess foo- linkProcess foo- linkProcess foo- linkProcess foo- linkProcess foo- self >>= sendShutdown foo . ExitProcessCancelled . Just- void (receiveMessage @Void)- )- , testCase "unlink multiple times"- $ applySchedulerFactory schedulerFactory- $ do- foo <- spawn "reciever" (void (receiveMessage @Void))- handleInterrupts- (lift . (False @?) . show)- (do- spawn_ "reciever" (void receiveAnyMessage)- linkProcess foo- linkProcess foo- linkProcess foo- unlinkProcess foo- unlinkProcess foo- unlinkProcess foo- unlinkProcess foo- withMonitor foo $ \ref -> do- self >>= sendShutdown foo . ExitProcessCancelled . Just- void (receiveSelectedMessage (selectProcessDown ref))- )- , testCase "spawnLink" $ applySchedulerFactory schedulerFactory $ do- let foo = void (receiveMessage @Void)- handleInterrupts- (\er -> lift (isProcessDownInterrupt Nothing er @? show er))- $ do- x <- spawnLink "foo" foo- self >>= sendShutdown x . ExitProcessCancelled . Just- void (receiveMessage @Void)- , testCase "spawnLink and child exits by returning from spawn"- $ applySchedulerFactory schedulerFactory- $ do- me <- self- u <- spawn "unlinker" $ do- logCritical "unlinked child started"- l <- spawnLink "linked" $ do- logCritical "linked child started"- () <- receiveMessage- logCritical "linked child done"- sendMessage me l- x <- receiveAnyMessage- logCritical' ("got: " <> show x)- l <- receiveMessage- _ <- monitor l- sendMessage l ()- pL@(ProcessDown _ _ _) <- receiveMessage- logCritical' ("linked process down: " <> show pL)- _ <- monitor u- mpU <- receiveAfter (TimeoutMicros 1000)- case mpU of- Just (pU@(ProcessDown _ _ _)) ->- error ("unlinked process down: " <> show pU)- Nothing -> logInfo "passed"- , testCase "spawnLink and child exits via exitWithError"- $ applySchedulerFactory schedulerFactory- $ do- me <- self- u <- spawn "unlinker" $ do- logCritical "unlinked child started"- l <- spawnLink "linker" $ do- logCritical "linked child started"- () <- receiveMessage- logCritical "linked child done"- exitWithError "linked process test error"- sendMessage me l- x <- receiveAnyMessage- logCritical' ("got: " <> show x)- l <- receiveMessage- _ <- monitor l- sendMessage l ()- pL@(ProcessDown _ _ _) <- receiveMessage- logCritical' ("linked process down: " <> show pL)- _ <- monitor u- mpU <- receiveAfter (TimeoutMicros 1000)- case mpU of- Just (pU@(ProcessDown _ _ _)) ->- logInfo' ("unlinked process down: " <> show pU)- Nothing -> error "linked process not exited!"- , testCase "ignore normal exit"- $ applySchedulerFactory schedulerFactory- $ do- mainProc <- self- let linkingServer = void $ exitOnInterrupt $ do- logNotice "linker"- foreverCheap $ do- x <- receiveMessage- case x of- Right p -> do- linkProcess p- sendMessage mainProc True- Left e ->- exitBecause e- linker <- spawnLink "link-server" linkingServer- logNotice "mainProc"- do- x <- spawnLink "x1" (logNotice "x 1" >> void (receiveMessage @Void))- withMonitor x $ \xRef -> do- sendMessage linker (Right x :: Either (Interrupt 'NoRecovery) ProcessId)- void $ receiveSelectedMessage (filterMessage id)- sendShutdown x ExitNormally- void (receiveSelectedMessage (selectProcessDown xRef))- do- x <- spawnLink "x2" (logNotice "x 2" >> void (receiveMessage @Void))- withMonitor x $ \xRef -> do- sendMessage linker (Right x :: Either (Interrupt 'NoRecovery) ProcessId)- void $ receiveSelectedMessage (filterMessage id)- sendShutdown x ExitNormally- void (receiveSelectedMessage (selectProcessDown xRef))- handleInterrupts (lift . (LinkedProcessCrashed linker @=?)) $ do- me <- self- sendMessage linker (Left (ExitProcessCancelled (Just me)) :: Either (Interrupt 'NoRecovery) ProcessId)- void (receiveMessage @Void)- , testCase "unlink" $ applySchedulerFactory schedulerFactory $ do- let- foo1 = void receiveAnyMessage- foo2 foo1Pid = do- linkProcess foo1Pid- (r1, barPid) <- receiveMessage- lift (("unlink foo1" :: String) @=? r1)- unlinkProcess foo1Pid- sendMessage barPid ("unlinked foo1" :: String, foo1Pid)- receiveMessage >>= lift . (@?= ("the end" :: String))- exitWithError "foo two"- bar foo2Pid parentPid = do- linkProcess foo2Pid- me <- self- sendMessage foo2Pid ("unlink foo1" :: String, me)- (r1, foo1Pid) <- receiveMessage- lift (("unlinked foo1" :: String) @=? r1)- handleInterrupts- (const (return ()))- (do- linkProcess foo1Pid- self >>= sendShutdown foo1Pid . ExitProcessCancelled . Just- void (receiveMessage @Void)- )- handleInterrupts- (\er -> void- (sendMessage parentPid (LinkedProcessCrashed foo2Pid == er))- )- (do- sendMessage foo2Pid ("the end" :: String)- void receiveAnyMessage- )- foo1Pid <- spawn "foo1" foo1- foo2Pid <- spawn "foo2" (foo2 foo1Pid)- me <- self- barPid <- spawn "bar" (bar foo2Pid me)- handleInterrupts- (\er -> lift (LinkedProcessCrashed barPid @?= er))- (do- res <- receiveMessage @Bool- lift (threadDelay 100000)- lift (res @?= True)- )- ]- )--monitoringTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-monitoringTests schedulerFactory = setTravisTestOptions- (testGroup- "process monitoring tests"- [ testCase "monitored process not running"- $ applySchedulerFactory schedulerFactory- $ do- let badPid = 132123- ref <- monitor badPid- pd <- receiveSelectedMessage (selectProcessDown ref)- lift (downReason pd @?= ExitOtherProcessNotRunning badPid)- lift (threadDelay 10000)- , testCase- "monitor twice, once when it is running and one, when the monitored process is not running (variant 1)"- $ applySchedulerFactory schedulerFactory- $ do- target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)- me <- self- spawn_ "monitor 1" $ do- ref1 <- monitor target- receiveSelectedMessage (selectProcessDown ref1)- >>= sendMessage me- . Just- lift (threadDelay 10000)- sendMessage target ExitNormally- pd1 <- receiveMessage- lift (downReason <$> pd1 @?= Just ExitNormally)- ref <- monitor target- pd2 <- receiveSelectedMessage (selectProcessDown ref)- lift (downReason pd2 @?= ExitOtherProcessNotRunning target)- lift (threadDelay 10000)- , testCase- "spawn, shutdown and monitor many times in a tight loop"- $ applySchedulerFactory schedulerFactory- $ do- tests <- replicateM 60 $ spawn "spawn, shutdown and monitor test" $ do- target <- spawn "target" (receiveMessage >>= exitBecause)- replicateM_ 102 $ spawn_ "monitor" $ do- ref <- monitor target- logInfo ("monitoring now" <> pack (show ref))- void $ receiveSelectedMessage (selectProcessDown ref)- sendMessage target ExitNormally- ref <- monitor target- logInfo ("monitoring now" <> pack (show ref))- void (receiveSelectedMessage (selectProcessDown ref))- traverse_ awaitProcessDown tests- , testCase "monitored process exit normally"- $ applySchedulerFactory schedulerFactory- $ do- target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)- ref <- monitor target- sendMessage target ExitNormally- pd <- receiveSelectedMessage (selectProcessDown ref)- lift (downReason pd @?= ExitNormally)- lift (threadDelay 10000)- , testCase "multiple monitors some demonitored"- $ applySchedulerFactory schedulerFactory- $ do- target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)- ref1 <- monitor target- ref2 <- monitor target- ref3 <- monitor target- ref4 <- monitor target- ref5 <- monitor target- demonitor ref3- demonitor ref5- sendMessage target ExitNormally- pd1 <- receiveSelectedMessage (selectProcessDown ref1)- lift (downReason pd1 @?= ExitNormally)- pd2 <- receiveSelectedMessage (selectProcessDown ref2)- lift (downReason pd2 @?= ExitNormally)- pd4 <- receiveSelectedMessage (selectProcessDown ref4)- lift (downReason pd4 @?= ExitNormally)- lift (threadDelay 10000)- , testCase "monitored process killed"- $ applySchedulerFactory schedulerFactory- $ do- target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)- ref <- monitor target- self >>= sendMessage target . ExitProcessCancelled . Just- pd <- receiveSelectedMessage (selectProcessDown ref)- me <- self- lift (downReason pd @?= ExitProcessCancelled (Just me))- lift (threadDelay 10000)- , testCase "demonitored process killed"- $ applySchedulerFactory schedulerFactory- $ do- target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)- ref <- monitor target- demonitor ref- self >>= sendMessage target . ExitProcessCancelled . Just- me <- self- spawn_ "wait-and-send" (lift (threadDelay 10000) >> sendMessage me ())- pd <- receiveSelectedMessage-- (Right <$> selectProcessDown ref <|> Left <$> selectMessage @())- lift (pd @?= Left ())- lift (threadDelay 10000)- ]- )--timerTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-timerTests schedulerFactory = setTravisTestOptions- (testGroup- "process timer tests"- [ testCase "receiveAfter into timeout"- $ applySchedulerFactory schedulerFactory- $ do- pd <- receiveAfter @Void 1000- lift (pd @?= Nothing)- lift (threadDelay 10000)- , testCase "receiveAfter no timeout"- $ applySchedulerFactory schedulerFactory- $ do- me <- self- other <- spawn- "reciever"- (do- r <- receiveMessage @()- lift (r @?= ())- sendMessage me (123 :: Int)- )- pd1 <- receiveAfter @() 10000- lift (pd1 @?= Nothing)- sendMessage other ()- pd2 <- receiveAfter @Int 10000- lift (pd2 @?= Just 123)- lift (threadDelay 10000)- , testCase "many receiveAfters"- $ applySchedulerFactory schedulerFactory- $ do- let n = 5- testMsg :: Float- testMsg = 123- me <- self- other <- spawn- "test"- (do- replicateM_ n $ sendMessage me ("bad message" :: String)- r <- receiveMessage @()- lift (r @?= ())- replicateM_ n $ sendMessage me testMsg- )- receiveAfter @Float 100 >>= lift . (@?= Nothing)- sendMessage other ()- replicateM_- n- (do- res <- receiveAfter @Float 10000- lift (res @?= Just testMsg)- )-- lift (threadDelay 100)- ]- )--processDetailsTests- :: forall r . (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree-processDetailsTests schedulerFactory = setTravisTestOptions- (testGroup- "process info tests"- [ testCase- "no infos for a non-existant process"- (applySchedulerFactory- schedulerFactory- (do- let nonExistentPid = ProcessId 123- me <- self- pInfo <- getProcessState nonExistentPid- lift (assertEqual "" (nonExistentPid /= me) (isNothing pInfo))- )- )- , testCase- "no infos for a dead process"- (applySchedulerFactory- schedulerFactory- (do- deadProc <- spawn "dead" (return ())- mr <- monitor deadProc- void $ receiveSelectedMessage (selectProcessDown mr)- pInfo <- getProcessState deadProc- lift- (assertBool "no process state of a dead process expected"- (isNothing pInfo)- )- )- )- , testGroup- "process title tests"- [ testCase- "getProcessState returns the title passed to spawn"- (applySchedulerFactory- schedulerFactory- (do- let expectedTitle = "expected title"- p <- spawn expectedTitle (void receiveAnyMessage)- (actualTitle, _, _) <- fromJust <$> getProcessState p- lift- (assertEqual "unexpected process title"- expectedTitle- actualTitle- )- )- )- ]- , testGroup- "process details tests"- [ testCase- "update"- (applySchedulerFactory- schedulerFactory- (do- let expected1 = "test details 1"- expected2 = "test details 2"- parent <- self- testPid <- spawnLink "test" $ do- updateProcessDetails expected1- sendMessage parent ()- () <- receiveMessage- updateProcessDetails expected2- sendMessage parent ()- receiveMessage- () <- receiveMessage- (_, actual1, _) <- fromJust <$> (getProcessState testPid)- lift (assertEqual "1" expected1 actual1)- sendMessage testPid ()- () <- receiveMessage- (_, actual2, _) <- fromJust <$> (getProcessState testPid)- lift (assertEqual "2" expected2 actual2)- sendMessage testPid ()- )- )- ]- ]- )+import Common+import Control.Applicative+import qualified Control.Eff.Concurrent.Process.ForkIOScheduler as ForkIO+import qualified Control.Eff.Concurrent.Process.SingleThreadedScheduler as SingleThreaded+import qualified Control.Eff.Concurrent.Protocol.CallbackServer as Callback+import Control.Eff.Concurrent.Protocol.EffectfulServer+import Control.Exception+import Data.List (sort)+import Data.Maybe+import Data.String (fromString)+import Data.Void+import GHC.Generics (Generic)++testInterruptReason :: InterruptReason+testInterruptReason = ErrorInterrupt "test interrupt"++test_forkIo :: TestTree+test_forkIo =+ setTravisTestOptions $+ withTestLogC+ ( \c -> do+ lw <- stdoutLogWriter renderConsoleMinimalisticWide+ runLift $+ withLogging+ ( filteringLogWriter+ (logEventSeverityIsAtLeast errorSeverity)+ lw+ )+ $ withAsyncLogWriter (100 :: Int) $+ ForkIO.schedule c+ )+ (\factory -> testGroup "ForkIOScheduler" [allTests factory])++test_singleThreaded :: TestTree+test_singleThreaded =+ setTravisTestOptions $+ withTestLogC+ ( \e ->+ let runEff :: Eff LoggingAndIo a -> IO a+ runEff e' = do+ lw <- stdoutLogWriter renderConsoleMinimalisticWide+ runLift $+ withLogging+ (filteringLogWriter (logEventSeverityIsAtLeast errorSeverity) lw)+ e'+ in void $ SingleThreaded.scheduleM runEff yield e+ )+ (\factory -> testGroup "SingleThreadedScheduler" [allTests factory])++allTests ::+ forall r.+ (IoLogging r, Typeable r) =>+ IO (Eff (Processes r) () -> IO ()) ->+ TestTree+allTests schedulerFactory =+ localOption+ (timeoutSeconds 300)+ ( testGroup+ "Process"+ [ errorTests schedulerFactory,+ sendShutdownTests schedulerFactory,+ concurrencyTests schedulerFactory,+ exitTests schedulerFactory,+ pingPongTests schedulerFactory,+ yieldLoopTests schedulerFactory,+ delayTests schedulerFactory,+ selectiveReceiveTests schedulerFactory,+ linkingTests schedulerFactory,+ monitoringTests schedulerFactory,+ timerTests schedulerFactory,+ processDetailsTests schedulerFactory+ ]+ )++data ReturnToSender+ deriving (Typeable)++instance ToTypeLogMsg ReturnToSender where+ toTypeLogMsg _ = "ReturnToSender"++instance HasPdu ReturnToSender where+ data Pdu ReturnToSender r where+ ReturnToSender :: ProcessId -> String -> Pdu ReturnToSender ('Synchronous Bool)+ StopReturnToSender :: Pdu ReturnToSender ('Synchronous ())++instance NFData (Pdu ReturnToSender r) where+ rnf (ReturnToSender p s) = rnf p `seq` rnf s+ rnf StopReturnToSender = ()++instance ToLogMsg (Pdu ReturnToSender x)++deriving instance Show (Pdu ReturnToSender x)++deriving instance Typeable (Pdu ReturnToSender x)++returnToSender ::+ forall q r.+ HasProcesses r q =>+ Endpoint ReturnToSender ->+ String ->+ Eff r Bool+returnToSender toP msg = do+ me <- self+ _ <- call toP (ReturnToSender me msg)+ msgEcho <- receiveMessage @String+ return (msgEcho == msg)++stopReturnToSender ::+ forall q r.+ HasProcesses r q =>+ Endpoint ReturnToSender ->+ Eff r ()+stopReturnToSender toP = call toP StopReturnToSender++returnToSenderServer ::+ forall q.+ (IoLogging q, Typeable q) =>+ Eff (Processes q) (Endpoint ReturnToSender)+returnToSenderServer =+ Callback.startLink @ReturnToSender $+ Callback.onEvent+ ( \evt -> case evt of+ OnCall rt msg -> case msg of+ StopReturnToSender -> interrupt testInterruptReason+ ReturnToSender fromP echoMsg -> do+ sendMessage fromP echoMsg+ yieldProcess+ sendReply rt True+ OnInterrupt i -> interrupt i+ other -> interrupt (ErrorInterrupt (toLogMsg other))+ )+ "return-to-sender"++selectiveReceiveTests ::+ forall r.+ (IoLogging r, Typeable r) =>+ IO (Eff (Processes r) () -> IO ()) ->+ TestTree+selectiveReceiveTests schedulerFactory =+ setTravisTestOptions+ ( testGroup+ "selective receive tests"+ [ testCase "send 10 messages (from 1..10) and receive messages from 10 to 1" $+ applySchedulerFactory schedulerFactory $+ do+ let nMax = 10+ receiverLoop donePid = go nMax+ where+ go :: Int -> Eff (Processes r) ()+ go 0 = sendMessage donePid True+ go n = do+ void $ receiveSelectedMessage (filterMessage (== n))+ go (n - 1)+ senderLoop destination =+ traverse_ (sendMessage destination) [1 .. nMax]+ me <- self+ receiverPid2 <- spawn "reciever loop" (receiverLoop me)+ spawn_ "sender loop" (senderLoop receiverPid2)+ ok <- receiveMessage @Bool+ lift (ok @? "selective receive failed"),+ testCase "receive a message while waiting for a call reply" $+ applySchedulerFactory schedulerFactory $+ do+ srv <- returnToSenderServer+ ok <- returnToSender srv "test"+ () <- stopReturnToSender srv+ lift (ok @? "selective receive failed"),+ testCase "when sending multiple messages, it is possible to receive them selectively in any order" $+ applySchedulerFactory schedulerFactory $+ do+ me <- self+ let messages :: [Int]+ messages = [1 .. 100]+ mRefs <-+ traverse+ ( \i ->+ spawn+ (fromString ("sender-" ++ show i))+ (yieldProcess >> sendMessage me i >> logInfo (LABEL "sent" i))+ >>= monitor+ )+ messages+ traverse_+ ( \i ->+ receiveSelectedMessage (filterMessage (== i))+ >>= logInfo . LABEL "received" . toLogMsg+ )+ messages+ traverse_+ ( \(mref, i) ->+ logInfo (LABEL "waiting for" mref) (LABEL "of" i)+ >> receiveSelectedMessage (selectProcessDown mref)+ >>= logInfo (LABEL "down" i)+ )+ (mRefs `zip` messages),+ testCase "flush messages" $+ applySchedulerFactory schedulerFactory $ do+ me <- self+ spawn_ "sender-bool" $+ replicateM_ 10 (sendMessage me True)+ >> sendMessage me ()+ spawn_ "sender-float" $+ replicateM_ 10 (sendMessage me (123.23411 :: Float))+ >> sendMessage me ()+ spawn_ "sender-string" $+ replicateM_ 10 (sendMessage me ("123" :: String))+ >> sendMessage me ()+ () <- receiveMessage+ () <- receiveMessage+ () <- receiveMessage+ -- replicateCheapM_ 40 yieldProcess+ messages <- flushMessages+ lift (length messages @?= 30)+ ]+ )++delayTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+delayTests schedulerFactory =+ let maxN = 100000+ in setTravisTestOptions+ ( testGroup+ "delay tests"+ [ testCase+ "delay many times (forM_)"+ ( applySchedulerFactory+ schedulerFactory+ (forM_ [1 :: Int .. maxN] (\_ -> delay (TimeoutMicros 1)))+ ),+ testCase+ "process can be interrupted during a delay"+ ( applySchedulerFactory+ schedulerFactory+ ( do+ me <- self+ sleeper <-+ spawn+ "sleeper"+ (tryUninterrupted (delay (TimeoutMicros 10_000_000)) >>= sendMessage me)+ delay (TimeoutMicros 1_000)+ let expected = TimeoutInterrupt "test timeout interrupt"+ sendInterrupt sleeper expected+ actual <- receiveMessage @(Either InterruptReason ())+ lift (toLogMsg actual @?= toLogMsg expected)+ )+ ),+ testCase+ "messages are enqueued for a process that is currently delaying"+ ( applySchedulerFactory+ schedulerFactory+ ( do+ me <- self+ sleeper <-+ spawn+ "sleeper"+ ( do+ sendMessage me True+ delay (TimeoutMicros 500_000)+ receiveMessage @Int >>= sendMessage me+ receiveMessage @Int >>= sendMessage me+ receiveMessage @Int >>= sendMessage me+ )+ let x1, x2, x3 :: Int+ x1 = 1+ x2 = 2+ x3 = 3+ receiveMessage >>= lift . assertBool "sleeper not started"+ sendMessage sleeper x1+ sendMessage sleeper x2+ sendMessage sleeper x3+ receiveMessage @Int >>= lift . assertEqual "wrong message 1" x1+ receiveMessage @Int >>= lift . assertEqual "wrong message 2" x2+ receiveMessage @Int >>= lift . assertEqual "wrong message 3" x3+ )+ )+ ]+ )++yieldLoopTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+yieldLoopTests schedulerFactory =+ let maxN = 100000+ in setTravisTestOptions+ ( testGroup+ "yield tests"+ [ testCase+ "yield many times (replicateM_)"+ ( applySchedulerFactory+ schedulerFactory+ (replicateM_ maxN yieldProcess)+ ),+ testCase+ "yield many times (forM_)"+ ( applySchedulerFactory+ schedulerFactory+ (forM_ [1 :: Int .. maxN] (\_ -> yieldProcess))+ ),+ testCase+ "construct an effect with an exit first, followed by many yields"+ ( applySchedulerFactory+ schedulerFactory+ ( do+ void exitNormally+ replicateM_ 1000000000000 yieldProcess+ )+ )+ ]+ )++newtype Ping = Ping ProcessId+ deriving (Eq, Show, Typeable, NFData)++data Pong = Pong+ deriving (Eq, Show, Generic)++instance NFData Pong++pingPongTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+pingPongTests schedulerFactory =+ testGroup+ "Yield Tests"+ [ testCase "ping pong a message between two processes, both don't yield" $+ applySchedulerFactory schedulerFactory $+ do+ let pongProc = foreverCheap $ do+ Ping pinger <- receiveMessage+ sendMessage pinger Pong+ pingProc ponger parent = do+ me <- self+ sendMessage ponger (Ping me)+ Pong <- receiveMessage+ sendMessage parent True+ pongPid <- spawn "pong" pongProc+ me <- self+ spawn_ "ping" (pingProc pongPid me)+ ok <- receiveMessage @Bool+ lift (ok @? "ping pong failed"),+ testCase "ping pong a message between two processes, with massive yielding" $+ applySchedulerFactory schedulerFactory $+ do+ yieldProcess+ let pongProc = foreverCheap $ do+ yieldProcess+ Ping pinger <- receiveMessage+ yieldProcess+ sendMessage pinger Pong+ yieldProcess+ pingProc ponger parent = do+ yieldProcess+ me <- self+ yieldProcess+ sendMessage ponger (Ping me)+ yieldProcess+ Pong <- receiveMessage+ yieldProcess+ sendMessage parent True+ yieldProcess+ yieldProcess+ pongPid <- spawn "pong" pongProc+ yieldProcess+ me <- self+ yieldProcess+ spawn_ "ping" (pingProc pongPid me)+ yieldProcess+ ok <- receiveMessage @Bool+ yieldProcess+ lift (ok @? "ping pong failed")+ yieldProcess,+ testCase+ "the first message is not delayed, not even in cooperative scheduling (because of yield)"+ $ applySchedulerFactory schedulerFactory $+ do+ pongVar <- lift newEmptyMVar+ let pongProc = foreverCheap $ do+ Pong <- receiveMessage+ lift (putMVar pongVar Pong)+ ponger <- spawn "pong" pongProc+ sendMessage ponger Pong+ let waitLoop = do+ p <- lift (tryTakeMVar pongVar)+ case p of+ Nothing -> do+ yieldProcess+ waitLoop+ Just r -> return r+ p <- waitLoop+ lift (p == Pong @? "ping pong failed")+ ]++errorTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+errorTests schedulerFactory =+ testGroup+ "causing and handling errors"+ [ testGroup+ "exitWithError"+ [ testCase "unhandled exitWithError" $+ applySchedulerFactory schedulerFactory $+ do+ void $ exitWithError "test error"+ error "This should not happen",+ testCase "cannot catch exitWithError" $+ applySchedulerFactory schedulerFactory $+ do+ void $ exitWithError "test error 4"+ error "This should not happen",+ testCase "multi process exitWithError" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ let n = 15+ traverse_+ ( \(i :: Int) ->+ spawn "test" $+ foreverCheap+ ( void+ ( sendMessage+ (888888 + fromIntegral i)+ ("test message" :: String)+ >> yieldProcess+ )+ )+ )+ [0 .. n]+ traverse_+ ( \(i :: Int) -> spawn "test" $ do+ void $ sendMessage me i+ void (exitWithError (show i ++ " died"))+ error "this should not be reached"+ )+ [0 .. n]+ oks <- replicateM (length [0 .. n]) receiveMessage+ assertEff "" (sort oks == [0 .. n])+ ]+ ]++concurrencyTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+concurrencyTests schedulerFactory =+ let n = 100+ in testGroup+ "concurrency tests"+ [ testCase+ "when main process exits the scheduler kills/cleans and returns"+ $ applySchedulerFactory schedulerFactory $+ do+ me <- self+ traverse_+ ( const+ ( spawn+ "reciever"+ ( do+ m <- receiveAnyMessage+ void (sendAnyMessage me m)+ )+ )+ )+ [1 .. n]+ lift (threadDelay 1000),+ testCase "new processes are executed before the parent process" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ -- start massive amount of children that exit as soon as they are+ -- executed, this will only work smoothly when scheduler schedules+ -- the new child before the parent+ traverse_ (const (spawn "lemming" exitNormally)) [1 .. n]+ assertEff "" True,+ testCase "two concurrent processes" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ child1 <-+ spawn+ "reciever"+ ( do+ m <- receiveAnyMessage+ void (sendAnyMessage me m)+ )+ child2 <-+ spawn+ "sender"+ (foreverCheap (void (sendMessage 888888 ("" :: String))))+ sendMessage child1 ("test" :: String)+ i <- receiveMessage+ sendInterrupt child2 testInterruptReason+ assertEff "" (i == ("test" :: String)),+ testCase "most processes send foreverCheap" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ traverse_+ ( \(i :: Int) -> spawn "sender" $ do+ when (i `rem` 5 == 0) $ void $ sendMessage me i+ foreverCheap $+ void (sendMessage 888 ("test message to 888" :: String))+ )+ [0 .. n]+ oks <- replicateM (length [0, 5 .. n]) receiveMessage+ assertEff "" (sort oks == [0, 5 .. n]),+ testCase "most processes self foreverCheap" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ traverse_+ ( \(i :: Int) -> spawn "sender" $ do+ when (i `rem` 5 == 0) $ void $ sendMessage me i+ foreverCheap $ void self+ )+ [0 .. n]+ oks <- replicateM (length [0, 5 .. n]) receiveMessage+ assertEff "" (sort oks == [0, 5 .. n]),+ testCase "most processes sendShutdown foreverCheap" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ traverse_+ ( \(i :: Int) -> spawn "killer" $ do+ when (i `rem` 5 == 0) $ sendMessage me i+ foreverCheap $ sendShutdown 999 ExitNormally+ )+ [0 .. n]+ oks <- replicateM (length [0, 5 .. n]) receiveMessage+ assertEff "" (sort oks == [0, 5 .. n]),+ testCase "most processes spawn foreverCheap" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ traverse_+ ( \(i :: Int) -> spawn "sender 0" $ do+ when (i `rem` 5 == 0) $ void $ sendMessage me i+ parent <- self+ foreverCheap $+ void+ ( spawn+ "sender"+ ( void (sendMessage parent ("test msg from child" :: String))+ )+ )+ )+ [0 .. n]+ oks <- replicateM (length [0, 5 .. n]) receiveMessage+ assertEff "" (sort oks == [0, 5 .. n]),+ testCase "most processes receive foreverCheap" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ traverse_+ ( \(i :: Int) -> spawn "sender" $ do+ when (i `rem` 5 == 0) $ void $ sendMessage me i+ foreverCheap $ void receiveAnyMessage+ )+ [0 .. n]+ oks <- replicateM (length [0, 5 .. n]) receiveMessage+ assertEff "" (sort oks == [0, 5 .. n])+ ]++exitTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+exitTests schedulerFactory =+ testGroup "process exit tests" $+ [ testGroup+ "async exceptions"+ [ testCase+ ( "a process dies immediately if a "+ ++ show e+ ++ " is thrown, while "+ ++ busyWith+ )+ $ do+ tidVar <- newEmptyTMVarIO+ schedulerDoneVar <- newEmptyTMVarIO+ void $+ forkIO $ do+ void $+ try @SomeException $+ void $+ applySchedulerFactory schedulerFactory $+ do+ tid <- lift $ myThreadId+ lift $ atomically $ putTMVar tidVar tid+ foreverCheap busyEffect+ atomically $ putTMVar schedulerDoneVar ()+ tid <- atomically $ takeTMVar tidVar+ threadDelay 1000+ throwTo tid e+ void $ atomically $ takeTMVar schedulerDoneVar+ | e <- [ThreadKilled, UserInterrupt, HeapOverflow, StackOverflow],+ (busyWith, busyEffect) <-+ [ ( "receiving",+ void+ ( send+ ( ReceiveSelectedMessage @r+ (filterMessage (== ("test message" :: String)))+ )+ )+ ),+ ( "sending",+ void+ ( send+ ( SendMessage @r+ 44444+ (toMessage ("test message" :: String))+ )+ )+ ),+ ( "sending shutdown",+ void (send (SendShutdown @r 44444 ExitNormally))+ ),+ ("selfpid-ing", void (send (SelfPid @r))),+ ( "spawn-ing",+ void+ ( send+ ( Spawn @r+ "reciever"+ (void (send (ReceiveSelectedMessage @r selectAnyMessage)))+ )+ )+ ),+ ("sleeping", lift (threadDelay 100000))+ ]+ ],+ testGroup+ "main thread exit not blocked by"+ [ testCase ("a child process, busy with " ++ busyWith) $+ applySchedulerFactory schedulerFactory $+ do+ void $ spawn "busyloop" $ foreverCheap busyEffect+ lift (threadDelay 10000)+ | (busyWith, busyEffect) <-+ [ ( "receiving",+ void+ ( send+ ( ReceiveSelectedMessage @r+ (filterMessage (== ("test message" :: String)))+ )+ )+ ),+ ( "sending",+ void+ ( send+ ( SendMessage @r+ 44444+ (toMessage ("test message" :: String))+ )+ )+ ),+ ( "sending shutdown",+ void (send (SendShutdown @r 44444 ExitNormally))+ ),+ ("selfpid-ing", void (send (SelfPid @r))),+ ( "spawn-ing",+ void+ ( send+ ( Spawn @r+ "reciever"+ (void (send (ReceiveSelectedMessage @r selectAnyMessage)))+ )+ )+ )+ ]+ ],+ testGroup+ "one process exits, the other continues unimpaired"+ [ testCase+ ( "process 2 exits with: "+ ++ howToExit+ ++ " - while process 1 is busy with: "+ ++ busyWith+ )+ $ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ p1 <- spawn "busyloop" $ foreverCheap busyEffect+ lift (threadDelay 1000)+ void $+ spawn "sleep loop" $ do+ lift (threadDelay 1000)+ doExit+ lift (threadDelay 100000)+ wasRunningP1 <- isProcessAlive p1+ sendShutdown p1 ExitNormally+ lift (threadDelay 100000)+ stillRunningP1 <- isProcessAlive p1+ assertEff+ "the other process did not die still running"+ (not stillRunningP1 && wasRunningP1)+ | (busyWith, busyEffect) <-+ [ ( "receiving",+ void+ ( send+ ( ReceiveSelectedMessage @r+ (filterMessage (== ("test message" :: String)))+ )+ )+ ),+ ( "sending",+ void+ ( send+ ( SendMessage @r+ 44444+ (toMessage ("test message" :: String))+ )+ )+ ),+ ( "sending shutdown",+ void (send (SendShutdown @r 44444 ExitNormally))+ ),+ ("selfpid-ing", void (send (SelfPid @r))),+ ( "spawn-ing",+ void+ ( send+ ( Spawn @r+ "receiver"+ (void (send (ReceiveSelectedMessage @r selectAnyMessage)))+ )+ )+ )+ ],+ (howToExit, doExit) <-+ [ ("normally", void exitNormally),+ ("simply returning", return ()),+ ( "raiseError",+ void (interrupt (ErrorInterrupt "test error raised"))+ ),+ ("exitWithError", void (exitWithError "test error exit")),+ ( "sendShutdown to self",+ do+ me <- self+ void (sendShutdown me ExitNormally)+ )+ ]+ ]+ ]++sendShutdownTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+sendShutdownTests schedulerFactory =+ testGroup+ "sendShutdown"+ [ testCase "... self" $+ applySchedulerFactory schedulerFactory $ do+ me <- self+ void $ send (SendShutdown @r me ExitNormally)+ interrupt (ErrorInterrupt "sendShutdown must not return"),+ testCase "sendInterrupt to self" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ r <- send (SendInterrupt @r me (ErrorInterrupt "123"))+ assertEff+ "Interrupted must be returned"+ ( case r of+ Interrupted (ErrorInterrupt "123") -> True+ _ -> False+ ),+ testGroup+ "... other process"+ [ testCase "while it is sending" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ other <-+ spawn+ "interrupted"+ ( do+ untilInterrupted+ (SendMessage @r 666666 (toMessage ("test" :: String)))+ void (sendMessage me ("OK" :: String))+ )+ void (sendInterrupt other testInterruptReason)+ a <- receiveMessage+ assertEff "" (a == ("OK" :: String)),+ testCase "while it is receiving" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ other <-+ spawn+ "interrupted"+ ( do+ untilInterrupted (ReceiveSelectedMessage @r selectAnyMessage)+ void (sendMessage me ("OK" :: String))+ )+ void (sendInterrupt other testInterruptReason)+ a <- receiveMessage+ assertEff "" (a == ("OK" :: String)),+ testCase "while it is self'ing" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ other <-+ spawn+ "interrupted"+ ( do+ untilInterrupted (SelfPid @r)+ void (sendMessage me ("OK" :: String))+ )+ void (sendInterrupt other (ErrorInterrupt "testError"))+ (a :: String) <- receiveMessage+ assertEff "" (a == "OK"),+ testCase "while it is spawning" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ other <-+ spawn+ "interrupted"+ ( do+ untilInterrupted (Spawn @r "returner" (return ()))+ void (sendMessage me ("OK" :: String))+ )+ void (sendInterrupt other testInterruptReason)+ a <- receiveMessage+ assertEff "" (a == ("OK" :: String)),+ testCase "while it is sending shutdown messages" $+ scheduleAndAssert schedulerFactory $+ \assertEff -> do+ me <- self+ other <-+ spawn+ "interrupted"+ ( do+ untilInterrupted (SendShutdown @r 777 ExitNormally)+ void (sendMessage me ("OK" :: String))+ )+ void (sendInterrupt other testInterruptReason)+ a <- receiveMessage+ assertEff "" (a == ("OK" :: String)),+ testCase "handleInterrupt handles my own interrupts" $+ scheduleAndAssert schedulerFactory $+ \assertEff ->+ handleInterrupts+ ( \e -> case e of+ ErrorInterrupt "test" -> return True+ _ -> return False+ )+ (interrupt (ErrorInterrupt "test") >> return False)+ >>= assertEff "exception handler not invoked"+ ]+ ]++linkingTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+linkingTests schedulerFactory =+ setTravisTestOptions+ ( testGroup+ "process linking tests"+ [ testCase "link process with it self" $+ applySchedulerFactory schedulerFactory $+ do+ me <- self+ handleInterrupts+ (\er -> lift (False @? ("unexpected interrupt: " ++ show er)))+ ( do+ linkProcess me+ lift (threadDelay 10000)+ ),+ testCase "link with not running process" $+ applySchedulerFactory schedulerFactory $+ do+ let testPid = 234234234+ handleInterrupts+ (lift . (@?= toLogMsg (LinkedProcessCrashed testPid)) . toLogMsg)+ ( do+ linkProcess testPid+ void (receiveMessage @Void)+ ),+ testCase "linked process exit message is ExitSuccess" $+ applySchedulerFactory schedulerFactory $+ do+ foo <- spawn "reciever" (void (receiveMessage @Void))+ handleInterrupts+ (lift . (\e -> toLogMsg e /= toLogMsg (LinkedProcessCrashed foo) @? show (toLogMsg e)))+ ( do+ linkProcess foo+ sendShutdown foo ExitNormally+ lift (threadDelay 1000)+ ),+ testCase "linked process exit message is Crash" $+ applySchedulerFactory schedulerFactory $+ do+ foo <- spawn "reciever" (void (receiveMessage @Void))+ handleInterrupts+ (lift . (@?= toLogMsg (LinkedProcessCrashed foo)) . toLogMsg)+ ( do+ linkProcess foo+ self >>= sendShutdown foo . ExitProcessCancelled . Just+ void (receiveMessage @Void)+ ),+ testCase "link multiple times" $+ applySchedulerFactory schedulerFactory $+ do+ foo <- spawn "reciever" (void (receiveMessage @Void))+ handleInterrupts+ (lift . (@?= toLogMsg (LinkedProcessCrashed foo)) . toLogMsg)+ ( do+ linkProcess foo+ linkProcess foo+ linkProcess foo+ linkProcess foo+ linkProcess foo+ linkProcess foo+ linkProcess foo+ self >>= sendShutdown foo . ExitProcessCancelled . Just+ void (receiveMessage @Void)+ ),+ testCase "unlink multiple times" $+ applySchedulerFactory schedulerFactory $+ do+ foo <- spawn "reciever" (void (receiveMessage @Void))+ handleInterrupts+ (lift . (False @?) . show)+ ( do+ spawn_ "reciever" (void receiveAnyMessage)+ linkProcess foo+ linkProcess foo+ linkProcess foo+ unlinkProcess foo+ unlinkProcess foo+ unlinkProcess foo+ unlinkProcess foo+ withMonitor foo $ \ref -> do+ self >>= sendShutdown foo . ExitProcessCancelled . Just+ void (receiveSelectedMessage (selectProcessDown ref))+ ),+ testCase "spawnLink" $+ applySchedulerFactory schedulerFactory $ do+ let foo = void (receiveMessage @Void)+ handleInterrupts+ (\er -> lift (isLinkedProcessCrashed Nothing er @? show er))+ $ do+ x <- spawnLink "foo" foo+ self >>= sendShutdown x . ExitProcessCancelled . Just+ void (receiveMessage @Void),+ testCase "spawnLink and child exits by returning from spawn" $+ applySchedulerFactory schedulerFactory $+ do+ me <- self+ u <- spawn "unlinker" $ do+ logCritical (MSG "unlinked child started")+ l <- spawnLink "linked" $ do+ logCritical (MSG "linked child started")+ () <- receiveMessage+ logCritical (MSG "linked child done")+ sendMessage me l+ x <- receiveAnyMessage+ logCritical (LABEL "got" x)+ l <- receiveMessage+ _ <- monitor l+ sendMessage l ()+ pL@(ProcessDown _ _ _) <- receiveMessage+ logCritical (LABEL "linked process down" pL)+ _ <- monitor u+ mpU <- receiveAfter (TimeoutMicros 1000)+ case mpU of+ Just (pU@(ProcessDown _ _ _)) ->+ error ("unlinked process down: " <> show pU)+ Nothing -> logInfo (MSG "passed"),+ testCase "spawnLink and child exits via exitWithError" $+ applySchedulerFactory schedulerFactory $+ do+ me <- self+ u <- spawn "unlinker" $ do+ logCritical (MSG "unlinked child started")+ l <- spawnLink "linker" $ do+ logCritical (MSG "linked child started")+ () <- receiveMessage+ logCritical (MSG "linked child done")+ exitWithError "linked process test error"+ sendMessage me l+ x <- receiveAnyMessage+ logCritical (LABEL "got" x)+ l <- receiveMessage+ _ <- monitor l+ sendMessage l ()+ pL@(ProcessDown _ _ _) <- receiveMessage+ logCritical (LABEL "linked process down" pL)+ _ <- monitor u+ mpU <- receiveAfter (TimeoutMicros 1000)+ case mpU of+ Just (pU@(ProcessDown _ _ _)) ->+ logInfo (LABEL "unlinked process down" pU)+ Nothing -> error "linked process not exited!",+ testCase "ignore normal exit" $+ applySchedulerFactory schedulerFactory $+ do+ mainProc <- self+ let linkingServer = void $+ exitOnInterrupt $ do+ logNotice (MSG "linker")+ foreverCheap $ do+ x <- receiveMessage+ case x of+ Right p -> do+ linkProcess p+ sendMessage mainProc True+ Left e ->+ exitBecause e+ linker <- spawnLink "link-server" linkingServer+ logNotice (MSG "mainProc")+ do+ x <- spawnLink "x1" (logNotice (MSG "x 1") >> void (receiveMessage @Void))+ withMonitor x $ \xRef -> do+ sendMessage linker (Right x :: Either ShutdownReason ProcessId)+ void $ receiveSelectedMessage (filterMessage id)+ sendShutdown x ExitNormally+ void (receiveSelectedMessage (selectProcessDown xRef))+ do+ x <- spawnLink "x2" (logNotice (MSG "x 2") >> void (receiveMessage @Void))+ withMonitor x $ \xRef -> do+ sendMessage linker (Right x :: Either ShutdownReason ProcessId)+ void $ receiveSelectedMessage (filterMessage id)+ sendShutdown x ExitNormally+ void (receiveSelectedMessage (selectProcessDown xRef))+ handleInterrupts (lift . (@?= toLogMsg (LinkedProcessCrashed linker)) . toLogMsg) $ do+ me <- self+ sendMessage linker (Left (ExitProcessCancelled (Just me)) :: Either ShutdownReason ProcessId)+ void (receiveMessage @Void),+ testCase "unlink" $+ applySchedulerFactory schedulerFactory $ do+ let foo1 = void receiveAnyMessage+ foo2 foo1Pid = do+ linkProcess foo1Pid+ (r1, barPid) <- receiveMessage+ lift (r1 @=? ("unlink foo1" :: String))+ unlinkProcess foo1Pid+ sendMessage barPid ("unlinked foo1" :: String, foo1Pid)+ receiveMessage >>= lift . (@?= ("the end" :: String))+ exitWithError "foo two"+ bar foo2Pid parentPid = do+ linkProcess foo2Pid+ me <- self+ sendMessage foo2Pid ("unlink foo1" :: String, me)+ (r1, foo1Pid) <- receiveMessage+ lift (r1 @=? ("unlinked foo1" :: String))+ handleInterrupts+ (const (return ()))+ ( do+ linkProcess foo1Pid+ self >>= sendShutdown foo1Pid . ExitProcessCancelled . Just+ void (receiveMessage @Void)+ )+ handleInterrupts+ ( \er ->+ void+ ( sendMessage parentPid $+ case er of+ LinkedProcessCrashed foo2Pid' -> foo2Pid' == foo2Pid+ _ -> False+ )+ )+ ( do+ sendMessage foo2Pid ("the end" :: String)+ void receiveAnyMessage+ )+ foo1Pid <- spawn "foo1" foo1+ foo2Pid <- spawn "foo2" (foo2 foo1Pid)+ me <- self+ barPid <- spawn "bar" (bar foo2Pid me)+ handleInterrupts+ (\er -> lift (toLogMsg er @?= toLogMsg (LinkedProcessCrashed barPid)))+ ( do+ res <- receiveMessage @Bool+ lift (threadDelay 100000)+ lift (res @?= True)+ )+ ]+ )++monitoringTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+monitoringTests schedulerFactory =+ setTravisTestOptions+ ( testGroup+ "process monitoring tests"+ [ testCase "monitored process not running" $+ applySchedulerFactory schedulerFactory $+ do+ let badPid = 132123+ ref <- monitor badPid+ pd <- receiveSelectedMessage (selectProcessDown ref)+ lift (toLogMsg (downReason pd) @?= toLogMsg (ExitOtherProcessNotRunning badPid))+ lift (threadDelay 10000),+ testCase+ "monitor twice, once when it is running and one, when the monitored process is not running (variant 1)"+ $ applySchedulerFactory schedulerFactory $+ do+ target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)+ me <- self+ spawn_ "monitor 1" $ do+ ref1 <- monitor target+ receiveSelectedMessage (selectProcessDown ref1)+ >>= sendMessage me+ . Just+ lift (threadDelay 10000)+ sendMessage target ExitNormally+ pd1 <- receiveMessage+ lift (toLogMsg . downReason <$> pd1 @?= Just (toLogMsg ExitNormally))+ ref <- monitor target+ pd2 <- receiveSelectedMessage (selectProcessDown ref)+ lift (toLogMsg (downReason pd2) @?= toLogMsg (ExitOtherProcessNotRunning target))+ lift (threadDelay 10000),+ testCase+ "spawn, shutdown and monitor many times in a tight loop"+ $ applySchedulerFactory schedulerFactory $+ do+ tests <- replicateM 60 $+ spawn "spawn, shutdown and monitor test" $ do+ target <- spawn "target" (receiveMessage >>= exitBecause)+ replicateM_ 102 $+ spawn_ "monitor" $ do+ ref <- monitor target+ logInfo (LABEL "monitoring now" ref)+ void $ receiveSelectedMessage (selectProcessDown ref)+ sendMessage target ExitNormally+ ref <- monitor target+ logInfo (LABEL "monitoring now" ref)+ void (receiveSelectedMessage (selectProcessDown ref))+ traverse_ awaitProcessDown tests,+ testCase "monitored process exit normally" $+ applySchedulerFactory schedulerFactory $+ do+ target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)+ ref <- monitor target+ sendMessage target ExitNormally+ pd <- receiveSelectedMessage (selectProcessDown ref)+ lift (downReason pd @?= ExitNormally)+ lift (threadDelay 10000),+ testCase "multiple monitors some demonitored" $+ applySchedulerFactory schedulerFactory $+ do+ target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)+ ref1 <- monitor target+ ref2 <- monitor target+ ref3 <- monitor target+ ref4 <- monitor target+ ref5 <- monitor target+ demonitor ref3+ demonitor ref5+ sendMessage target ExitNormally+ pd1 <- receiveSelectedMessage (selectProcessDown ref1)+ lift (toLogMsg (downReason pd1) @?= toLogMsg ExitNormally)+ pd2 <- receiveSelectedMessage (selectProcessDown ref2)+ lift (toLogMsg (downReason pd2) @?= toLogMsg ExitNormally)+ pd4 <- receiveSelectedMessage (selectProcessDown ref4)+ lift (toLogMsg (downReason pd4) @?= toLogMsg ExitNormally)+ lift (threadDelay 10000),+ testCase "monitored process killed" $+ applySchedulerFactory schedulerFactory $+ do+ target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)+ ref <- monitor target+ self >>= sendMessage target . ExitProcessCancelled . Just+ pd <- receiveSelectedMessage (selectProcessDown ref)+ me <- self+ lift (toLogMsg (downReason pd) @?= toLogMsg (ExitProcessCancelled (Just me)))+ lift (threadDelay 10000),+ testCase "demonitored process killed" $+ applySchedulerFactory schedulerFactory $+ do+ target <- spawn "reciever-exit-value" (receiveMessage >>= exitBecause)+ ref <- monitor target+ demonitor ref+ self >>= sendMessage target . ExitProcessCancelled . Just+ me <- self+ spawn_ "wait-and-send" (lift (threadDelay 10000) >> sendMessage me ())+ pd <-+ receiveSelectedMessage+ (Right <$> selectProcessDown ref <|> Left <$> selectMessage @())+ lift (pd @?= Left ())+ lift (threadDelay 10000)+ ]+ )++timerTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+timerTests schedulerFactory =+ setTravisTestOptions+ ( testGroup+ "process timer tests"+ [ testCase "receiveAfter into timeout" $+ applySchedulerFactory schedulerFactory $+ do+ pd <- receiveAfter @Void 1000+ lift (pd @?= Nothing)+ lift (threadDelay 10000),+ testCase "receiveAfter no timeout" $+ applySchedulerFactory schedulerFactory $+ do+ me <- self+ other <-+ spawn+ "reciever"+ ( do+ r <- receiveMessage @()+ lift (r @?= ())+ sendMessage me (123 :: Int)+ )+ pd1 <- receiveAfter @() 10000+ lift (pd1 @?= Nothing)+ sendMessage other ()+ pd2 <- receiveAfter @Int 10000+ lift (pd2 @?= Just 123)+ lift (threadDelay 10000),+ testCase "many receiveAfters" $+ applySchedulerFactory schedulerFactory $+ do+ let n = 5+ testMsg :: Float+ testMsg = 123+ me <- self+ other <-+ spawn+ "test"+ ( do+ replicateM_ n $ sendMessage me ("bad message" :: String)+ r <- receiveMessage @()+ lift (r @?= ())+ replicateM_ n $ sendMessage me testMsg+ )+ receiveAfter @Float 100 >>= lift . (@?= Nothing)+ sendMessage other ()+ replicateM_+ n+ ( do+ res <- receiveAfter @Float 10000+ lift (res @?= Just testMsg)+ )+ lift (threadDelay 100)+ ]+ )++processDetailsTests ::+ forall r. (IoLogging r) => IO (Eff (Processes r) () -> IO ()) -> TestTree+processDetailsTests schedulerFactory =+ setTravisTestOptions+ ( testGroup+ "process info tests"+ [ testCase+ "no infos for a non-existant process"+ ( applySchedulerFactory+ schedulerFactory+ ( do+ let nonExistentPid = ProcessId 123+ me <- self+ pInfo <- getProcessState nonExistentPid+ lift (assertEqual "" (nonExistentPid /= me) (isNothing pInfo))+ )+ ),+ testCase+ "no infos for a dead process"+ ( applySchedulerFactory+ schedulerFactory+ ( do+ deadProc <- spawn "dead" (return ())+ mr <- monitor deadProc+ void $ receiveSelectedMessage (selectProcessDown mr)+ pInfo <- getProcessState deadProc+ lift+ ( assertBool+ "no process state of a dead process expected"+ (isNothing pInfo)+ )+ )+ ),+ testGroup+ "process title tests"+ [ testCase+ "getProcessState returns the title passed to spawn"+ ( applySchedulerFactory+ schedulerFactory+ ( do+ let expectedTitle = "expected title"+ p <- spawn expectedTitle (void receiveAnyMessage)+ (actualTitle, _, _) <- fromJust <$> getProcessState p+ lift+ ( assertEqual+ "unexpected process title"+ expectedTitle+ actualTitle+ )+ )+ )+ ],+ testGroup+ "process details tests"+ [ testCase+ "update"+ ( applySchedulerFactory+ schedulerFactory+ ( do+ let expected1 = "test details 1"+ expected2 = "test details 2"+ parent <- self+ testPid <- spawnLink "test" $ do+ updateProcessDetails expected1+ sendMessage parent ()+ () <- receiveMessage+ updateProcessDetails expected2+ sendMessage parent ()+ receiveMessage+ () <- receiveMessage+ (_, actual1, _) <- fromJust <$> (getProcessState testPid)+ lift (assertEqual "1" expected1 actual1)+ sendMessage testPid ()+ () <- receiveMessage+ (_, actual2, _) <- fromJust <$> (getProcessState testPid)+ lift (assertEqual "2" expected2 actual2)+ sendMessage testPid ()+ )+ )+ ]+ ]+ )
test/SingleThreadedScheduler.hs view
@@ -1,61 +1,57 @@ module SingleThreadedScheduler where -import Control.Eff.Loop-import Control.Eff.Concurrent.Process-import Control.Eff.Concurrent.Process.SingleThreadedScheduler- as Scheduler-import Control.Monad-import Test.Tasty-import Test.Tasty.HUnit-import Common+import Common+import Control.Eff.Concurrent.Process.SingleThreadedScheduler as Scheduler test_pureScheduler :: TestTree-test_pureScheduler = setTravisTestOptions $ testGroup- "Pure Scheduler"- [ testCase "two processes, each calculate and report back to main process"- $ Right (42 :: Int)- @=? Scheduler.schedulePure- (do+test_pureScheduler =+ setTravisTestOptions $+ testGroup+ "Pure Scheduler"+ [ testCase "two processes, each calculate and report back to main process" $+ Right (42 :: Int)+ @=? Scheduler.schedulePure+ ( do adderChild <- spawn "test" $ do- (from, arg1, arg2) <- receiveMessage- sendMessage from ((arg1 + arg2) :: Int)- foreverCheap $ void $ receiveAnyMessage-+ (from, arg1, arg2) <- receiveMessage+ sendMessage from ((arg1 + arg2) :: Int)+ foreverCheap $ void $ receiveAnyMessage multiplierChild <- spawn "test" $ do- (from, arg1, arg2) <- receiveMessage- sendMessage from ((arg1 * arg2) :: Int)-+ (from, arg1, arg2) <- receiveMessage+ sendMessage from ((arg1 * arg2) :: Int) me <- self sendMessage adderChild (me, 3 :: Int, 4 :: Int) x <- receiveMessage @Int sendMessage multiplierChild (me, x, 6 :: Int) receiveMessage @Int )- ]-+ ] test_mainProcessSpawnsAChildAndExitsNormally :: TestTree-test_mainProcessSpawnsAChildAndExitsNormally = setTravisTestOptions- (testCase+test_mainProcessSpawnsAChildAndExitsNormally =+ setTravisTestOptions+ ( testCase "spawn a child and exit normally"- (Scheduler.defaultMain- (do+ ( Scheduler.defaultMain+ ( do void (spawn "test" (void receiveAnyMessage)) void exitNormally- fail "This should not happen!!"+ error "This should not happen!!" ) ) ) - test_mainProcessSpawnsAChildBothExitNormally :: TestTree-test_mainProcessSpawnsAChildBothExitNormally = setTravisTestOptions- (testCase+test_mainProcessSpawnsAChildBothExitNormally =+ setTravisTestOptions+ ( testCase "spawn a child and let it exit and exit"- (Scheduler.defaultMain- (do- child <- spawn "test"- (do+ ( Scheduler.defaultMain+ ( do+ child <-+ spawn+ "test"+ ( do void (receiveMessage @String) void exitNormally error "This should not happen (child)!!"
test/WatchdogTests.hs view
@@ -1,737 +1,695 @@ {-# LANGUAGE UndecidableInstances #-}-module WatchdogTests(test_watchdogTests) where--import Common hiding (runTestCase)-import qualified Common-import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful-import Control.Eff.Concurrent.Protocol.StatefulServer (Stateful)-import qualified Control.Eff.Concurrent.Protocol.Broker as Broker-import Control.Eff.Concurrent.Protocol.Broker (Broker)-import qualified Control.Eff.Concurrent.Protocol.Observer.Queue as OQ-import qualified Control.Eff.Concurrent.Protocol.Watchdog as Watchdog-import Control.Lens-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Maybe (isNothing, fromJust)---runTestCase :: TestName -> Eff Effects () -> TestTree-runTestCase = Common.runTestCase---test_watchdogTests :: HasCallStack => TestTree-test_watchdogTests =- testGroup "watchdog"- [ runTestCase "demonstrate Bookshelf" bookshelfDemo-- , testGroup "watchdog broker interaction"- [-- runTestCase "test 1: when the broker exits, the watchdog does not care, it can be re-attached to a new broker" $ do- wd <- Watchdog.startLink def- unlinkProcess (wd ^. fromEndpoint)- do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (broker ^. fromEndpoint)- logNotice "started broker"- Watchdog.attachTemporary wd broker- logNotice "attached watchdog"- assertShutdown (broker ^. fromEndpoint) ExitNormally- logNotice "stopped broker"-- do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (broker ^. fromEndpoint)- logNotice "started new broker"- Watchdog.attachTemporary wd broker- logNotice "attached broker"- let expected = ExitUnhandledError "test-broker-kill"- logNotice "crashing broker"- assertShutdown (broker ^. fromEndpoint) expected- logNotice "crashed broker"-- logNotice "shutting down watchdog"- assertShutdown (wd^.fromEndpoint) ExitNormally- logNotice "watchdog down"--- , runTestCase "test 2: when the broker exits, and the watchdog is linked to it, it will exit" $ do- wd <- Watchdog.startLink def- unlinkProcess (wd ^. fromEndpoint)- logNotice "started watchdog"- do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (broker ^. fromEndpoint)- logNotice "started broker"- Watchdog.attachPermanent wd broker- logNotice "attached and linked broker"- logNotice "crashing broker"- let expected = ExitUnhandledError "test-broker-kill"- sendShutdown (broker ^. fromEndpoint) expected- logNotice "crashed broker"- logNotice "waiting for watchdog to crash"- awaitProcessDown (wd^.fromEndpoint)- >>= lift- . assertEqual "bad exit reason" (ExitOtherProcessNotRunning (broker^.fromEndpoint))- . downReason- logNotice "watchdog crashed"-- , runTestCase "test 3: when the same broker is attached twice, the second attachment is ignored" $ do- wd <- Watchdog.startLink def- unlinkProcess (wd ^. fromEndpoint)- logNotice "started watchdog"- do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (broker ^. fromEndpoint)- logNotice "started broker"- Watchdog.attachTemporary wd broker- logNotice "attached broker"- Watchdog.attachTemporary wd broker- logNotice "attached broker"- logNotice "restart child test begin"- restartChildTest broker- logNotice "restart child test finished"-- , runTestCase "test 4: when the same broker is attached twice, the\- \ first linked then not linked, the watchdog is not linked anymore" $ do- wd <- Watchdog.startLink def- unlinkProcess (wd ^. fromEndpoint)- logNotice "started watchdog"- do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (broker ^. fromEndpoint)- logNotice "started broker"- Watchdog.attachPermanent wd broker- logNotice "attached and linked broker"- Watchdog.attachTemporary wd broker- logNotice "attached broker"- logNotice "run restart child test"- restartChildTest broker- logNotice "restart child test finished"- logNotice "crashing broker"- let expected = ExitUnhandledError "test-broker-kill"- assertShutdown (broker ^. fromEndpoint) expected- logNotice "crashed broker"- do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (broker ^. fromEndpoint)- logNotice "started new broker"- Watchdog.attachTemporary wd broker- logNotice "attached new broker"- logNotice "run restart child test again to show everything is ok"- restartChildTest broker- logNotice "restart child test finished"--- , runTestCase "test 5: when the same broker is attached twice,\- \ the first time not linked but then linked, the watchdog is linked \- \ to that broker" $ do- wd <- Watchdog.startLink def- unlinkProcess (wd ^. fromEndpoint)- mwd <- monitor (wd ^. fromEndpoint)- logNotice "started watchdog"- do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (broker ^. fromEndpoint)- logNotice "started broker"- Watchdog.attachTemporary wd broker- logNotice "attached broker"- Watchdog.attachPermanent wd broker- logNotice "attached and linked broker"- logNotice "run restart child test"- restartChildTest broker- logNotice "restart child test finished"- logNotice "crashing broker"- let expected = ExitUnhandledError "test-broker-kill"- assertShutdown (broker ^. fromEndpoint) expected- logNotice "crashed broker"- logNotice "waiting for watchdog to crash"- receiveSelectedMessage (selectProcessDown mwd)- >>= lift- . assertEqual "bad exit reason" (ExitOtherProcessNotRunning (broker^.fromEndpoint))- . downReason- logNotice "watchdog down"--- , runTestCase "test 6: when multiple brokers are attached to a watchdog,\- \ and a linked broker exits, the watchdog should exit" $ do- wd <- Watchdog.startLink def- unlinkProcess (wd ^. fromEndpoint)- wdMon <- monitor (wd ^. fromEndpoint)- logNotice "started watchdog"- do- broker1 <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (broker1^.fromEndpoint)- logNotice "started broker 1"- Watchdog.attachPermanent wd broker1- logNotice "attached + linked broker 1"-- broker2 <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started broker 2"- Watchdog.attachTemporary wd broker2- logNotice "attached broker 2"-- broker3 <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started broker 3"- Watchdog.attachTemporary wd broker3- logNotice "attached broker 3"- unlinkProcess (broker3 ^. fromEndpoint)-- let expected = ExitUnhandledError "test-broker-kill 1"- logNotice "crashing broker 1"- assertShutdown (broker1 ^. fromEndpoint) expected- logNotice "crashed broker 1"-- isProcessAlive (broker2 ^. fromEndpoint)- >>= lift . assertBool "broker2 should be running"- isProcessAlive (broker3 ^. fromEndpoint)- >>= lift . assertBool "broker3 should be running"- logNotice "other brokers are alive"-- logNotice "waiting for watchdog to crash"- receiveSelectedMessage (selectProcessDown wdMon)- >>= lift- . assertEqual "bad exit reason" (ExitOtherProcessNotRunning (broker1^.fromEndpoint))- . downReason- logNotice "watchdog crashed"-- ]- , testGroup "restarting children"- [ runTestCase "test 7: when a child exits it is restarted" $ do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started broker"- wd <- Watchdog.startLink def- logNotice "started watchdog"- Watchdog.attachTemporary wd broker- logNotice "attached broker"- logNotice "running child tests"- restartChildTest broker- logNotice "finished child tests"-- , runTestCase "test 8: when the broker emits the shutting down\- \ event the watchdog does not restart children" $ do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (broker ^. fromEndpoint)- logNotice "started broker"- wd <- Watchdog.startLink def- unlinkProcess (wd ^. fromEndpoint)- logNotice "started watchdog"- Watchdog.attachTemporary wd broker- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do- let c0 = BookShelfId 0- do- void $ Broker.spawnOrLookup broker c0- awaitChildStartedEvent c0- logNotice "bookshelf started"-- Broker.stopBroker broker- awaitBrokershuttingDownEvent broker- lift (threadDelay 10_000)- logNotice "checking state"- Watchdog.getCrashReports wd >>= lift . assertBool "no crash reports expected" . null-- assertShutdown (wd ^. fromEndpoint) ExitNormally- logNotice "watchdog stopped"-- , runTestCase "test 9: a child is only restarted if it crashes" $ do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started broker"- wd <- Watchdog.startLink def- logNotice "started watchdog"- Watchdog.attachTemporary wd broker- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do- let shelfId = BookShelfId 0- do- shelf <- Broker.spawnOrLookup broker shelfId- awaitChildStartedEvent shelfId- logNotice "bookshelf started"-- cast shelf StopShelf- awaitChildDownEvent shelfId- void $ awaitProcessDown (shelf ^. fromEndpoint)- logNotice "shelf stopped"- lift (threadDelay 10_000)- Broker.lookupChild broker shelfId >>= lift . assertBool "child must not be restarted" . isNothing-- assertShutdown (wd ^. fromEndpoint) ExitNormally- logNotice "watchdog stopped"-- , testGroup "child restart"- $ let threeTimesASecond = 3 `Watchdog.crashesPerSeconds` 1- in [ runTestCase "test 10: if a child crashes 3 times in 300ms, waits 1.1 seconds\- \ and crashes again 3 times, and is restarted three times" $ do-- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started broker"- wd <- Watchdog.startLink threeTimesASecond- logNotice "started watchdog"- Watchdog.attachTemporary wd broker-- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do- let crash3Times = do- logNotice "crashing 3 times"- replicateM_ 3 $ do- spawnAndCrashBookShelf broker shelfId- logNotice "waiting for last restart"- awaitChildStartedEvent shelfId- lift (threadDelay 100_000)- shelfId = BookShelfId 0-- crash3Times- logNotice "sleeping"- lift (threadDelay 1_100_000)- logNotice "crashing again"- crash3Times-- assertShutdown (wd ^. fromEndpoint) ExitNormally- logNotice "watchdog stopped"-- , runTestCase "test 11: if a child crashes 4 times within 1s it is not restarted\- \ and the watchdog exits with an error" $ do- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started broker"- wd <- Watchdog.startLink threeTimesASecond- logNotice "started watchdog"- unlinkProcess (wd ^. fromEndpoint)- Watchdog.attachTemporary wd broker-- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do- let shelfId = BookShelfId 0- crash3Times = do- logNotice "crashing 3 times"- replicateM_ 3 $ do- spawnAndCrashBookShelf broker shelfId- logNotice "waiting for restart"- awaitChildStartedEvent shelfId- cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd- logNotice (pack (show cr))- lift (threadDelay 100_000)-- crash3Times-- logNotice "crashing 4. time"- spawnAndCrashBookShelf broker shelfId- lift (threadDelay 10_000)- Broker.lookupChild broker shelfId- >>= lift . assertBool "child must not be reststarted" . isNothing-- assertShutdown (wd ^. fromEndpoint) ExitNormally- logNotice "watchdog stopped"-- , runTestCase "test 12: if a child of a linked broker crashes too often,\- \ the watchdog exits with an error and interrupts the broker" $ do-- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started broker"- unlinkProcess (broker ^. fromEndpoint)- mBroker <- monitor (broker ^. fromEndpoint)- wd <- Watchdog.startLink threeTimesASecond- logNotice "started watchdog"- mwd <- monitor (wd ^. fromEndpoint)- unlinkProcess (wd ^. fromEndpoint)- Watchdog.attachPermanent wd broker-- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do- let shelfId = BookShelfId 0- crash3Times = do- logNotice "crashing 3 times"- replicateM_ 3 $ do- spawnAndCrashBookShelf broker shelfId- logNotice "waiting for restart"- awaitChildStartedEvent shelfId- lift (threadDelay 100_000)-- crash3Times-- logNotice "crashing 4. time"- spawnAndCrashBookShelf broker shelfId-- logNotice "await broker down"- receiveSelectedMessage (selectProcessDown mBroker)- >>= lift- . assertEqual- "wrong exit reason"- (ExitUnhandledError "restart frequency exceeded")- . downReason- logNotice "broker down"-- logNotice "await watchdog down"- receiveSelectedMessage (selectProcessDown mwd)- >>= lift- . assertEqual- "wrong exit reason"- (ExitUnhandledError "restart frequency exceeded")- . downReason- logNotice "watchdog down"-- , runTestCase "test 13: if the watchdog is killed, all watched children of all\- \ brokers are still alive" $ do- wd <- Watchdog.startLink (1 `Watchdog.crashesPerSeconds` 1)- unlinkProcess (wd ^. fromEndpoint)- logNotice "started watchdog"-- brokerT <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (brokerT^.fromEndpoint)- logNotice "started temporary broker"-- brokerP <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- unlinkProcess (brokerP^.fromEndpoint)- logNotice "started permanent broker"-- Watchdog.attachTemporary wd brokerT- logNotice "attached temporary broker"-- Watchdog.attachPermanent wd brokerP- logNotice "attached permanent broker"-- let b0 = BookShelfId 0- b1 = BookShelfId 1- b2 = BookShelfId 2- b3 = BookShelfId 3-- (e0, e1) <- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerT $- (,) <$> spawnBookShelf brokerT b0 <*> spawnBookShelf brokerT b1- m0 <- monitor (e0^.fromEndpoint)- m1 <- monitor (e1^.fromEndpoint)- logNotice ("started bookshelfs of temporary broker: " <> pack (show (m0, m1)))-- (e2, e3) <- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerP $- (,) <$> spawnBookShelf brokerP b2 <*> spawnBookShelf brokerP b3- m2 <- monitor (e2^.fromEndpoint)- m3 <- monitor (e3^.fromEndpoint)- logNotice ("started bookshelfs of permanent broker: " <> pack (show (m2, m3)))-- logNotice "crashing the watchdog"- assertShutdown (wd ^. fromEndpoint) (ExitUnhandledError "watchdog test crash")- logNotice "watchdog stopped"-- call e0 (AddBook "Solaris")- logNotice "e0 still alive"- call e1 (AddBook "Solaris")- logNotice "e1 still alive"- call e2 (AddBook "Solaris")- logNotice "e2 still alive"- call e3 (AddBook "Solaris")- logNotice "e3 still alive"- assertShutdown (e0 ^. fromEndpoint) ExitNormally- assertShutdown (e1 ^. fromEndpoint) ExitNormally- assertShutdown (e2 ^. fromEndpoint) ExitNormally- assertShutdown (e3 ^. fromEndpoint) ExitNormally- assertShutdown (brokerT ^. fromEndpoint) ExitNormally- assertShutdown (brokerP ^. fromEndpoint) ExitNormally-- , runTestCase "test 14: if the watchdog receives OnChildDown\- \ for a known broker it behaves as if there\- \ was an OnChildSpawned for that child" $ do- wd <- Watchdog.startLink (1 `Watchdog.crashesPerSeconds` 1)- logNotice "started watchdog"-- brokerT <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started temporary broker"-- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerT $ do- let b0 = BookShelfId 0- e0 <- spawnBookShelf brokerT b0- logNotice ("started bookshelf of temporary broker: " <> pack (show e0))- Watchdog.attachTemporary wd brokerT- logNotice "attached temporary broker"- logNotice "crash the bookshelf"- assertShutdown (e0 ^. fromEndpoint) (ExitUnhandledError "bookshelf test crash")- awaitChildDownEvent b0- logNotice "bookshelf down"- awaitChildStartedEvent b0- logNotice "bookshelf restarted"- assertShutdown (wd ^. fromEndpoint) ExitNormally- assertShutdown (brokerT ^. fromEndpoint) ExitNormally-- , runTestCase "test 15: when a child exits normally,\- \ and a new child with the same ChildId\- \ crashes, the watchdog behaves as if\- \ the first child never existed" $ do- wd <- Watchdog.startLink (1 `Watchdog.crashesPerSeconds` 10)- logNotice "started watchdog"-- brokerT <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started temporary broker"-- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerT $ do- let b0 = BookShelfId 0-- e0 <- spawnBookShelf brokerT b0- logNotice ("started bookshelf of temporary broker: " <> pack (show e0))-- Watchdog.attachTemporary wd brokerT- logNotice "attached temporary broker"- logNotice "crash the bookshelf"- assertShutdown (e0 ^. fromEndpoint) (ExitUnhandledError "bookshelf test crash")- awaitChildDownEvent b0- logNotice "bookshelf down"- awaitChildStartedEvent b0- e1 <- fromJust <$> Broker.lookupChild brokerT b0- logNotice "bookshelf restarted"-- logNotice "exit the bookshelf normally"- assertShutdown (e1 ^. fromEndpoint) ExitNormally- awaitChildDownEvent b0- logNotice "bookshelf stopped, starting a new one"- e2 <- spawnBookShelf brokerT b0- logNotice "bookshelf restarted"-- assertShutdown (e2 ^. fromEndpoint) (ExitUnhandledError "bookshelf test crash")- awaitChildDownEvent b0- logNotice "bookshelf down"- awaitChildStartedEvent b0- logNotice "bookshelf restarted"-- assertShutdown (wd ^. fromEndpoint) ExitNormally- assertShutdown (brokerT ^. fromEndpoint) ExitNormally-- , testGroup "test 16: the amount of state is kept to a minimum" $- let- setup k = do- wd <- Watchdog.startLink (4 `Watchdog.crashesPerSeconds` 30)- logNotice "started watchdog"- brokerT <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started temporary broker"- Watchdog.attachTemporary wd brokerT- logNotice "attached temporary broker"- brokerP <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- logNotice "started permanent broker"- Watchdog.attachTemporary wd brokerP- logNotice "attached permanent broker"- do- p <- self- t <- spawn "test-proc" $ do- void $ k wd brokerT brokerP- sendMessage p ()- res <- receiveSelectedWithMonitorAfter t selectMessage (TimeoutMicros 10_000_000)- logNotice ("test-proc finish message: " <> pack (show res))- case res of- Left x ->- do logError ("test-proc crashed: " <> pack (show x))- lift (assertFailure ("test-proc crashed: " <> show x))- Right () ->- logNotice "test-proc succeeded"-- setupThenShutdown k =- setup $ \wd brokerT brokerP -> do- void $ k wd brokerT brokerP- assertShutdown (wd ^. fromEndpoint) ExitNormally- assertShutdown (brokerT ^. fromEndpoint) ExitNormally- assertShutdown (brokerP ^. fromEndpoint) ExitNormally- in- [- runTestCase "test 17: child events of unknown broker don't add state" $- setupThenShutdown $ \wd _brokerT _brokerP -> do- someBroker <- asEndpoint @(Broker (Stateful BookShelf)) <$> spawn "someBroker" (pure ())- someChild <- asEndpoint @BookShelf <$> spawn "someChild" (pure ())- let someChildId = BookShelfId 2321- cast wd (Observed (Broker.OnChildDown someBroker someChildId someChild (ExitUnhandledError "test error")))- lift (threadDelay 1_000)- cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd- logNotice (pack (show cr))- lift (assertBool "no crash reports expected" (Map.null cr))-- , runTestCase "test 18: when a broker exits, the children of that broker are forgotten and ignored" $ do- setup $ \wd brokerT brokerP -> do- let- someChildId1 = BookShelfId 2321- someChildId2 = BookShelfId 2322- someChildId3 = BookShelfId 2323-- (someChild1, someChild2)- <- OQ.observe @(Broker.ChildEvent (Stateful BookShelf))- (100 :: Int)- brokerT- ((,) <$> spawnBookShelf brokerT someChildId1 <*> spawnBookShelf brokerT someChildId2)-- someChild3- <- OQ.observe @(Broker.ChildEvent (Stateful BookShelf))- (100 :: Int) brokerP (spawnBookShelf brokerP someChildId3)- do- cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd- logNotice ("crash-reports: " <> pack (show cr))- lift (assertBool "no crash reports expected" (Map.null cr))-- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerT $ do- crashBookShelf someChild1 someChildId1- awaitChildStartedEvent someChildId1- crashBookShelf someChild2 someChildId2- awaitChildStartedEvent someChildId2-- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerP $ do- crashBookShelf someChild3 someChildId3- awaitChildStartedEvent someChildId3-- do- cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd- logNotice ("crash-reports: " <> pack (show cr))- lift (assertEqual "wrong number of crash reports" 3 (Map.size cr))-- assertShutdown (brokerT ^. fromEndpoint) ExitNormally- do- cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd- logNotice ("crash-reports: " <> pack (show cr))- lift (assertEqual "wrong number of crash reports" 1 (Map.size cr))-- assertShutdown (wd ^. fromEndpoint) ExitNormally- assertShutdown (brokerP ^. fromEndpoint) ExitNormally- ]- ]- ]- ]---bookshelfDemo :: HasCallStack => Eff Effects ()-bookshelfDemo = do- logNotice "Bookshelf Demo Begin"- broker <- Broker.startLink (Broker.statefulChild @BookShelf @Effects (TimeoutMicros 1_000_000) id)- shelf1 <- Broker.spawnOrLookup broker (BookShelfId 1)- call shelf1 (AddBook "Solaris")- call shelf1 GetBookList >>= logDebug . pack . show- cast shelf1 (TakeBook "Solaris")- call shelf1 GetBookList >>= logDebug . pack . show- logNotice "Bookshelf Demo End"--restartChildTest :: HasCallStack => Endpoint (Broker (Stateful BookShelf)) -> Eff Effects ()-restartChildTest broker =- OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do- let c0 = BookShelfId 123- spawnAndCrashBookShelf broker c0- c01m <- Broker.lookupChild broker c0- case c01m of- Nothing ->- lift (assertFailure "failed to lookup child, seems it wasn't restarted!")- Just c01 -> do- call c01 (AddBook "Solaris")- logNotice "part 3 passed"--spawnBookShelf- :: HasCallStack- => Endpoint (Broker (Stateful BookShelf))- -> Broker.ChildId (Stateful BookShelf)- -> Eff (OQ.Reader (Broker.ChildEvent (Stateful BookShelf)) : Effects) (Endpoint BookShelf)-spawnBookShelf broker c0 = do- logNotice "spawn or lookup book shelf"- res <- Broker.spawnChild broker c0- c00 <- case res of- Left (Broker.AlreadyStarted _ ep) -> pure ep- Right ep -> awaitChildStartedEvent c0 >> pure ep- logNotice ("got book shelf: " <> pack (show c00))- pure c00--spawnAndCrashBookShelf- :: HasCallStack- => Endpoint (Broker (Stateful BookShelf))- -> Broker.ChildId (Stateful BookShelf)- -> Eff (OQ.Reader (Broker.ChildEvent (Stateful BookShelf)) : Effects) ()-spawnAndCrashBookShelf broker c0 = do- c00 <- spawnBookShelf broker c0- crashBookShelf c00 c0--crashBookShelf- :: HasCallStack- => Endpoint BookShelf- -> Broker.ChildId (Stateful BookShelf)- -> Eff (OQ.Reader (Broker.ChildEvent (Stateful BookShelf)) : Effects) ()-crashBookShelf c00 c0 = do- logNotice "adding Solaris"- call c00 (AddBook "Solaris")- logNotice "added Solaris"- logNotice "adding Solaris again to crash the book shelf"- handleInterrupts (const (pure ())) (call c00 (AddBook "Solaris")) -- adding twice the same book causes a crash- logNotice "added Solaris again waiting for crash"- void $ awaitProcessDown (c00 ^. fromEndpoint)- logNotice "shelf crashed"- awaitChildDownEvent c0--awaitBrokershuttingDownEvent broker = do- logNotice ("waiting for broker shutting down event of " <> pack (show broker))- evt <- OQ.await @(Broker.ChildEvent (Stateful BookShelf))- case evt of- (Broker.OnBrokerShuttingDown broker') | broker == broker' ->- logNotice ("broker shutting down: " <> pack (show broker))- otherEvent ->- lift (assertFailure ("wrong event received: " <> show otherEvent))--awaitChildDownEvent c0 = do- logNotice ("waiting for down event of " <> pack (show c0))- evt <- OQ.await @(Broker.ChildEvent (Stateful BookShelf))- case evt of- (Broker.OnChildDown _ c' _ _) | c0 == c' ->- logNotice ("child down: " <> pack (show c0))- otherEvent ->- lift (assertFailure ("wrong broker down event received: " <> show otherEvent))--awaitChildStartedEvent c0 = do- logNotice ("waiting for start event of " <> pack (show c0))- evt <- OQ.await @(Broker.ChildEvent (Stateful BookShelf))- case evt of- (Broker.OnChildSpawned _ c' _) | c0 == c' ->- logNotice ("child started: " <> pack (show c0))- otherEvent ->- lift (assertFailure ("wrong broker start event received: " <> show otherEvent))---data BookShelf deriving Typeable--type Book = String--instance HasPdu BookShelf where- data Pdu BookShelf r where- GetBookList :: Pdu BookShelf ('Synchronous [Book])- AddBook :: Book -> Pdu BookShelf ('Synchronous ())- TakeBook :: Book -> Pdu BookShelf 'Asynchronous- StopShelf :: Pdu BookShelf 'Asynchronous- deriving Typeable--instance Stateful.Server BookShelf Effects where- newtype StartArgument BookShelf = BookShelfId Int- deriving (Show, Eq, Ord, Num, NFData, Typeable)-- newtype instance Model BookShelf = BookShelfModel (Set String) deriving (Eq, Show, Default)-- update _ shelfId event = do- logDebug (pack (show shelfId ++ " " ++ show event))- case event of-- Stateful.OnCast StopShelf -> do- logNotice "stop shelf"- exitNormally-- Stateful.OnCast (TakeBook book) -> do- booksBefore <- Stateful.getModel @BookShelf- booksAfter <- Stateful.modifyAndGetModel (over bookShelfModel (Set.delete book))- when (booksBefore == booksAfter) (exitWithError "book not taken")-- Stateful.OnCall rt callEvent ->- case callEvent of- GetBookList -> do- books <- Stateful.useModel bookShelfModel- sendReply rt (toList books)-- AddBook book -> do- booksBefore <- Stateful.getModel @BookShelf- booksAfter <- Stateful.modifyAndGetModel (over bookShelfModel (Set.insert book))- when (booksBefore == booksAfter) (exitWithError "book not added")- sendReply rt ()-- other -> logWarning (pack (show other))--bookShelfModel :: Iso' (Stateful.Model BookShelf) (Set String)-bookShelfModel = iso (\(BookShelfModel s) -> s) BookShelfModel--type instance Broker.ChildId BookShelf = Stateful.StartArgument BookShelf--instance NFData (Pdu BookShelf r) where- rnf GetBookList = ()- rnf StopShelf = ()- rnf (AddBook b) = rnf b- rnf (TakeBook b) = rnf b--instance Show (Pdu BookShelf r) where- show GetBookList = "get-book-list"- show StopShelf = "stop-shelf"- show (AddBook b) = "add-book: " ++ b- show (TakeBook b) = "take-book: " ++ b+{-# LANGUAGE NoOverloadedStrings #-}++module WatchdogTests+ ( test_watchdogTests,+ )+where++import Common hiding (runTestCase)+import qualified Common+import Control.Eff.Concurrent.Protocol.Broker (Broker)+import qualified Control.Eff.Concurrent.Protocol.Broker as Broker+import qualified Control.Eff.Concurrent.Protocol.Observer.Queue as OQ+import Control.Eff.Concurrent.Protocol.StatefulServer (Stateful)+import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful+import qualified Control.Eff.Concurrent.Protocol.Watchdog as Watchdog+import Control.Lens+import qualified Data.Map as Map+import Data.Maybe (fromJust, isNothing)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String++runTestCase :: TestName -> Eff Effects () -> TestTree+runTestCase = Common.runTestCase++test_watchdogTests :: HasCallStack => TestTree+test_watchdogTests =+ testGroup+ "watchdog"+ [ runTestCase "demonstrate Bookshelf" bookshelfDemo,+ testGroup+ "watchdog broker interaction"+ [ runTestCase "test 1: when the broker exits, the watchdog does not care, it can be re-attached to a new broker" $ do+ wd <- Watchdog.startLink def+ unlinkProcess (wd ^. fromEndpoint)+ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (broker ^. fromEndpoint)+ logNotice "started broker"+ Watchdog.attachTemporary wd broker+ logNotice "attached watchdog"+ assertShutdown (broker ^. fromEndpoint) ExitNormally+ logNotice "stopped broker"+ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (broker ^. fromEndpoint)+ logNotice "started new broker"+ Watchdog.attachTemporary wd broker+ logNotice "attached broker"+ let expected = ExitUnhandledError (fromString "test-broker-kill")+ logNotice "crashing broker"+ assertShutdown (broker ^. fromEndpoint) expected+ logNotice "crashed broker"+ logNotice "shutting down watchdog"+ assertShutdown (wd ^. fromEndpoint) ExitNormally+ logNotice "watchdog down",+ runTestCase "test 2: when the broker exits, and the watchdog is linked to it, it will exit" $ do+ wd <- Watchdog.startLink def+ unlinkProcess (wd ^. fromEndpoint)+ logNotice "started watchdog"+ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (broker ^. fromEndpoint)+ logNotice "started broker"+ Watchdog.attachPermanent wd broker+ logNotice "attached and linked broker"+ logNotice "crashing broker"+ let expected = ExitUnhandledError (fromString "test-broker-kill")+ sendShutdown (broker ^. fromEndpoint) expected+ logNotice "crashed broker"+ logNotice "waiting for watchdog to crash"+ awaitProcessDown (wd ^. fromEndpoint)+ >>= lift+ . assertEqual "bad exit reason" (ExitOtherProcessNotRunning (broker ^. fromEndpoint))+ . downReason+ logNotice "watchdog crashed",+ runTestCase "test 3: when the same broker is attached twice, the second attachment is ignored" $ do+ wd <- Watchdog.startLink def+ unlinkProcess (wd ^. fromEndpoint)+ logNotice "started watchdog"+ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (broker ^. fromEndpoint)+ logNotice "started broker"+ Watchdog.attachTemporary wd broker+ logNotice "attached broker"+ Watchdog.attachTemporary wd broker+ logNotice "attached broker"+ logNotice "restart child test begin"+ restartChildTest broker+ logNotice "restart child test finished",+ runTestCase+ "test 4: when the same broker is attached twice, the\+ \ first linked then not linked, the watchdog is not linked anymore"+ $ do+ wd <- Watchdog.startLink def+ unlinkProcess (wd ^. fromEndpoint)+ logNotice "started watchdog"+ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (broker ^. fromEndpoint)+ logNotice "started broker"+ Watchdog.attachPermanent wd broker+ logNotice "attached and linked broker"+ Watchdog.attachTemporary wd broker+ logNotice "attached broker"+ logNotice "run restart child test"+ restartChildTest broker+ logNotice "restart child test finished"+ logNotice "crashing broker"+ let expected = ExitUnhandledError (fromString "test-broker-kill")+ assertShutdown (broker ^. fromEndpoint) expected+ logNotice "crashed broker"+ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (broker ^. fromEndpoint)+ logNotice "started new broker"+ Watchdog.attachTemporary wd broker+ logNotice "attached new broker"+ logNotice "run restart child test again to show everything is ok"+ restartChildTest broker+ logNotice "restart child test finished",+ runTestCase+ "test 5: when the same broker is attached twice,\+ \ the first time not linked but then linked, the watchdog is linked \+ \ to that broker"+ $ do+ wd <- Watchdog.startLink def+ unlinkProcess (wd ^. fromEndpoint)+ mwd <- monitor (wd ^. fromEndpoint)+ logNotice "started watchdog"+ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (broker ^. fromEndpoint)+ logNotice "started broker"+ Watchdog.attachTemporary wd broker+ logNotice "attached broker"+ Watchdog.attachPermanent wd broker+ logNotice "attached and linked broker"+ logNotice "run restart child test"+ restartChildTest broker+ logNotice "restart child test finished"+ logNotice "crashing broker"+ let expected = ExitUnhandledError (fromString "test-broker-kill")+ assertShutdown (broker ^. fromEndpoint) expected+ logNotice "crashed broker"+ logNotice "waiting for watchdog to crash"+ receiveSelectedMessage (selectProcessDown mwd)+ >>= lift+ . assertEqual "bad exit reason" (ExitOtherProcessNotRunning (broker ^. fromEndpoint))+ . downReason+ logNotice "watchdog down",+ runTestCase+ "test 6: when multiple brokers are attached to a watchdog,\+ \ and a linked broker exits, the watchdog should exit"+ $ do+ wd <- Watchdog.startLink def+ unlinkProcess (wd ^. fromEndpoint)+ wdMon <- monitor (wd ^. fromEndpoint)+ logNotice "started watchdog"+ do+ broker1 <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (broker1 ^. fromEndpoint)+ logNotice "started broker 1"+ Watchdog.attachPermanent wd broker1+ logNotice "attached + linked broker 1"+ broker2 <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started broker 2"+ Watchdog.attachTemporary wd broker2+ logNotice "attached broker 2"+ broker3 <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started broker 3"+ Watchdog.attachTemporary wd broker3+ logNotice "attached broker 3"+ unlinkProcess (broker3 ^. fromEndpoint)+ let expected = ExitUnhandledError (fromString "test-broker-kill 1")+ logNotice "crashing broker 1"+ assertShutdown (broker1 ^. fromEndpoint) expected+ logNotice "crashed broker 1"+ isProcessAlive (broker2 ^. fromEndpoint)+ >>= lift . assertBool "broker2 should be running"+ isProcessAlive (broker3 ^. fromEndpoint)+ >>= lift . assertBool "broker3 should be running"+ logNotice "other brokers are alive"+ logNotice "waiting for watchdog to crash"+ receiveSelectedMessage (selectProcessDown wdMon)+ >>= lift+ . assertEqual "bad exit reason" (ExitOtherProcessNotRunning (broker1 ^. fromEndpoint))+ . downReason+ logNotice "watchdog crashed"+ ],+ testGroup+ "restarting children"+ [ runTestCase "test 7: when a child exits it is restarted" $ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started broker"+ wd <- Watchdog.startLink def+ logNotice "started watchdog"+ Watchdog.attachTemporary wd broker+ logNotice "attached broker"+ logNotice "running child tests"+ restartChildTest broker+ logNotice "finished child tests",+ runTestCase+ "test 8: when the broker emits the shutting down\+ \ event the watchdog does not restart children"+ $ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (broker ^. fromEndpoint)+ logNotice "started broker"+ wd <- Watchdog.startLink def+ unlinkProcess (wd ^. fromEndpoint)+ logNotice "started watchdog"+ Watchdog.attachTemporary wd broker+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do+ let c0 = BookShelfId 0+ do+ void $ Broker.spawnOrLookup broker c0+ awaitChildStartedEvent c0+ logNotice "bookshelf started"+ Broker.stopBroker broker+ awaitBrokershuttingDownEvent broker+ lift (threadDelay 10_000)+ logNotice "checking state"+ Watchdog.getCrashReports wd >>= lift . assertBool "no crash reports expected" . null+ assertShutdown (wd ^. fromEndpoint) ExitNormally+ logNotice "watchdog stopped",+ runTestCase "test 9: a child is only restarted if it crashes" $ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started broker"+ wd <- Watchdog.startLink def+ logNotice "started watchdog"+ Watchdog.attachTemporary wd broker+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do+ let shelfId = BookShelfId 0+ do+ shelf <- Broker.spawnOrLookup broker shelfId+ awaitChildStartedEvent shelfId+ logNotice "bookshelf started"+ cast shelf StopShelf+ awaitChildDownEvent shelfId+ void $ awaitProcessDown (shelf ^. fromEndpoint)+ logNotice "shelf stopped"+ lift (threadDelay 10_000)+ Broker.lookupChild broker shelfId >>= lift . assertBool "child must not be restarted" . isNothing+ assertShutdown (wd ^. fromEndpoint) ExitNormally+ logNotice "watchdog stopped",+ testGroup "child restart" $+ let threeTimesASecond = 3 `Watchdog.crashesPerSeconds` 1+ in [ runTestCase+ "test 10: if a child crashes 3 times in 300ms, waits 1.1 seconds\+ \ and crashes again 3 times, and is restarted three times"+ $ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started broker"+ wd <- Watchdog.startLink threeTimesASecond+ logNotice "started watchdog"+ Watchdog.attachTemporary wd broker+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do+ let crash3Times = do+ logNotice "crashing 3 times"+ replicateM_ 3 $ do+ spawnAndCrashBookShelf broker shelfId+ logNotice "waiting for last restart"+ awaitChildStartedEvent shelfId+ lift (threadDelay 100_000)+ shelfId = BookShelfId 0+ crash3Times+ logNotice "sleeping"+ lift (threadDelay 1_100_000)+ logNotice "crashing again"+ crash3Times+ assertShutdown (wd ^. fromEndpoint) ExitNormally+ logNotice "watchdog stopped",+ runTestCase+ "test 11: if a child crashes 4 times within 1s it is not restarted\+ \ and the watchdog exits with an error"+ $ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started broker"+ wd <- Watchdog.startLink threeTimesASecond+ logNotice "started watchdog"+ unlinkProcess (wd ^. fromEndpoint)+ Watchdog.attachTemporary wd broker+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do+ let shelfId = BookShelfId 0+ crash3Times = do+ logNotice "crashing 3 times"+ replicateM_ 3 $ do+ spawnAndCrashBookShelf broker shelfId+ logNotice "waiting for restart"+ awaitChildStartedEvent shelfId+ cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd+ traverse_ (logNotice . LABEL "crash-reports") cr+ lift (threadDelay 100_000)+ crash3Times+ logNotice "crashing 4. time"+ spawnAndCrashBookShelf broker shelfId+ lift (threadDelay 10_000)+ Broker.lookupChild broker shelfId+ >>= lift . assertBool "child must not be reststarted" . isNothing+ assertShutdown (wd ^. fromEndpoint) ExitNormally+ logNotice "watchdog stopped",+ runTestCase+ "test 12: if a child of a linked broker crashes too often,\+ \ the watchdog exits with an error and interrupts the broker"+ $ do+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started broker"+ unlinkProcess (broker ^. fromEndpoint)+ mBroker <- monitor (broker ^. fromEndpoint)+ wd <- Watchdog.startLink threeTimesASecond+ logNotice "started watchdog"+ mwd <- monitor (wd ^. fromEndpoint)+ unlinkProcess (wd ^. fromEndpoint)+ Watchdog.attachPermanent wd broker+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do+ let shelfId = BookShelfId 0+ crash3Times = do+ logNotice "crashing 3 times"+ replicateM_ 3 $ do+ spawnAndCrashBookShelf broker shelfId+ logNotice "waiting for restart"+ awaitChildStartedEvent shelfId+ lift (threadDelay 100_000)+ crash3Times+ logNotice "crashing 4. time"+ spawnAndCrashBookShelf broker shelfId+ logNotice "await broker down"+ receiveSelectedMessage (selectProcessDown mBroker)+ >>= lift+ . assertEqual+ "wrong exit reason"+ (ExitUnhandledError (fromString "restart frequency exceeded"))+ . downReason+ logNotice "broker down"+ logNotice "await watchdog down"+ receiveSelectedMessage (selectProcessDown mwd)+ >>= lift+ . assertEqual+ "wrong exit reason"+ (ExitUnhandledError (fromString "restart frequency exceeded"))+ . downReason+ logNotice "watchdog down",+ runTestCase+ "test 13: if the watchdog is killed, all watched children of all\+ \ brokers are still alive"+ $ do+ wd <- Watchdog.startLink (1 `Watchdog.crashesPerSeconds` 1)+ unlinkProcess (wd ^. fromEndpoint)+ logNotice "started watchdog"+ brokerT <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (brokerT ^. fromEndpoint)+ logNotice "started temporary broker"+ brokerP <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ unlinkProcess (brokerP ^. fromEndpoint)+ logNotice "started permanent broker"+ Watchdog.attachTemporary wd brokerT+ logNotice "attached temporary broker"+ Watchdog.attachPermanent wd brokerP+ logNotice "attached permanent broker"+ let b0 = BookShelfId 0+ b1 = BookShelfId 1+ b2 = BookShelfId 2+ b3 = BookShelfId 3+ (e0, e1) <-+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerT $+ (,) <$> spawnBookShelf brokerT b0 <*> spawnBookShelf brokerT b1+ m0 <- monitor (e0 ^. fromEndpoint)+ m1 <- monitor (e1 ^. fromEndpoint)+ logNotice (LABEL "started bookshelfs of temporary broker" (m0, m1))+ (e2, e3) <-+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerP $+ (,) <$> spawnBookShelf brokerP b2 <*> spawnBookShelf brokerP b3+ m2 <- monitor (e2 ^. fromEndpoint)+ m3 <- monitor (e3 ^. fromEndpoint)+ logNotice (LABEL "started bookshelfs of permanent broker" (m2, m3))+ logNotice "crashing the watchdog"+ assertShutdown (wd ^. fromEndpoint) (ExitUnhandledError (fromString "watchdog test crash"))+ logNotice "watchdog stopped"+ call e0 (AddBook "Solaris")+ logNotice "e0 still alive"+ call e1 (AddBook "Solaris")+ logNotice "e1 still alive"+ call e2 (AddBook "Solaris")+ logNotice "e2 still alive"+ call e3 (AddBook "Solaris")+ logNotice "e3 still alive"+ assertShutdown (e0 ^. fromEndpoint) ExitNormally+ assertShutdown (e1 ^. fromEndpoint) ExitNormally+ assertShutdown (e2 ^. fromEndpoint) ExitNormally+ assertShutdown (e3 ^. fromEndpoint) ExitNormally+ assertShutdown (brokerT ^. fromEndpoint) ExitNormally+ assertShutdown (brokerP ^. fromEndpoint) ExitNormally,+ runTestCase+ "test 14: if the watchdog receives OnChildDown\+ \ for a known broker it behaves as if there\+ \ was an OnChildSpawned for that child"+ $ do+ wd <- Watchdog.startLink (1 `Watchdog.crashesPerSeconds` 1)+ logNotice "started watchdog"+ brokerT <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started temporary broker"+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerT $ do+ let b0 = BookShelfId 0+ e0 <- spawnBookShelf brokerT b0+ logNotice (LABEL "started bookshelf of temporary broker" e0)+ Watchdog.attachTemporary wd brokerT+ logNotice "attached temporary broker"+ logNotice "crash the bookshelf"+ assertShutdown (e0 ^. fromEndpoint) (ExitUnhandledError (fromString "bookshelf test crash"))+ awaitChildDownEvent b0+ logNotice "bookshelf down"+ awaitChildStartedEvent b0+ logNotice "bookshelf restarted"+ assertShutdown (wd ^. fromEndpoint) ExitNormally+ assertShutdown (brokerT ^. fromEndpoint) ExitNormally,+ runTestCase+ "test 15: when a child exits normally,\+ \ and a new child with the same ChildId\+ \ crashes, the watchdog behaves as if\+ \ the first child never existed"+ $ do+ wd <- Watchdog.startLink (1 `Watchdog.crashesPerSeconds` 10)+ logNotice "started watchdog"+ brokerT <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started temporary broker"+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerT $ do+ let b0 = BookShelfId 0+ e0 <- spawnBookShelf brokerT b0+ logNotice (LABEL "started bookshelf of temporary broker" e0)+ Watchdog.attachTemporary wd brokerT+ logNotice "attached temporary broker"+ logNotice "crash the bookshelf"+ assertShutdown (e0 ^. fromEndpoint) (ExitUnhandledError (fromString "bookshelf test crash"))+ awaitChildDownEvent b0+ logNotice "bookshelf down"+ awaitChildStartedEvent b0+ e1 <- fromJust <$> Broker.lookupChild brokerT b0+ logNotice "bookshelf restarted"+ logNotice "exit the bookshelf normally"+ assertShutdown (e1 ^. fromEndpoint) ExitNormally+ awaitChildDownEvent b0+ logNotice "bookshelf stopped, starting a new one"+ e2 <- spawnBookShelf brokerT b0+ logNotice "bookshelf restarted"+ assertShutdown (e2 ^. fromEndpoint) (ExitUnhandledError (fromString "bookshelf test crash"))+ awaitChildDownEvent b0+ logNotice "bookshelf down"+ awaitChildStartedEvent b0+ logNotice "bookshelf restarted"+ assertShutdown (wd ^. fromEndpoint) ExitNormally+ assertShutdown (brokerT ^. fromEndpoint) ExitNormally,+ testGroup "test 16: the amount of state is kept to a minimum" $+ let setup k = do+ wd <- Watchdog.startLink (4 `Watchdog.crashesPerSeconds` 30)+ logNotice "started watchdog"+ brokerT <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started temporary broker"+ Watchdog.attachTemporary wd brokerT+ logNotice "attached temporary broker"+ brokerP <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ logNotice "started permanent broker"+ Watchdog.attachTemporary wd brokerP+ logNotice "attached permanent broker"+ do+ p <- self+ t <- spawn (fromString "test-proc") $ do+ void $ k wd brokerT brokerP+ sendMessage p ()+ res <- receiveSelectedWithMonitorAfter t selectMessage (TimeoutMicros 10_000_000)+ logNotice (LABEL "test-proc finish message" res)+ case res of+ Left x ->+ do+ logError (LABEL "test-proc crashed" x)+ lift (assertFailure ("test-proc crashed: " <> showAsLogMsg x))+ Right () ->+ logNotice "test-proc succeeded"+ setupThenShutdown k =+ setup $ \wd brokerT brokerP -> do+ void $ k wd brokerT brokerP+ assertShutdown (wd ^. fromEndpoint) ExitNormally+ assertShutdown (brokerT ^. fromEndpoint) ExitNormally+ assertShutdown (brokerP ^. fromEndpoint) ExitNormally+ in [ runTestCase "test 17: child events of unknown broker don't add state" $+ setupThenShutdown $+ \wd _brokerT _brokerP -> do+ someBroker <- asEndpoint @(Broker (Stateful BookShelf)) <$> spawn (fromString "someBroker") (pure ())+ someChild <- asEndpoint @BookShelf <$> spawn (fromString "someChild") (pure ())+ let someChildId = BookShelfId 2321+ cast wd (Observed (Broker.OnChildDown someBroker someChildId someChild (ExitUnhandledError (packLogMsg "test error"))))+ lift (threadDelay 1_000)+ cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd+ traverse_ (logNotice . LABEL "crash-reports") cr+ lift (assertBool "no crash reports expected" (Map.null cr)),+ runTestCase "test 18: when a broker exits, the children of that broker are forgotten and ignored" $ do+ setup $ \wd brokerT brokerP -> do+ let someChildId1 = BookShelfId 2321+ someChildId2 = BookShelfId 2322+ someChildId3 = BookShelfId 2323+ (someChild1, someChild2) <-+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf))+ (100 :: Int)+ brokerT+ ((,) <$> spawnBookShelf brokerT someChildId1 <*> spawnBookShelf brokerT someChildId2)+ someChild3 <-+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf))+ (100 :: Int)+ brokerP+ (spawnBookShelf brokerP someChildId3)+ do+ cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd+ traverse_ (logNotice . LABEL "crash-report") cr+ lift (assertBool "no crash reports expected" (Map.null cr))+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerT $ do+ crashBookShelf someChild1 someChildId1+ awaitChildStartedEvent someChildId1+ crashBookShelf someChild2 someChildId2+ awaitChildStartedEvent someChildId2+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) brokerP $ do+ crashBookShelf someChild3 someChildId3+ awaitChildStartedEvent someChildId3+ do+ cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd+ traverse_ (logNotice . LABEL "crash-report") cr+ lift (assertEqual "wrong number of crash reports" 3 (Map.size cr))+ assertShutdown (brokerT ^. fromEndpoint) ExitNormally+ do+ cr <- Watchdog.getCrashReports @(Stateful BookShelf) wd+ traverse_ (logNotice . LABEL "crash-report") cr+ lift (assertEqual "wrong number of crash reports" 1 (Map.size cr))+ assertShutdown (wd ^. fromEndpoint) ExitNormally+ assertShutdown (brokerP ^. fromEndpoint) ExitNormally+ ]+ ]+ ]+ ]++bookshelfDemo :: HasCallStack => Eff Effects ()+bookshelfDemo = do+ logNotice "Bookshelf Demo Begin"+ broker <- Broker.startLink (Broker.statefulChild @BookShelf (TimeoutMicros 1_000_000) id)+ shelf1 <- Broker.spawnOrLookup broker (BookShelfId 1)+ call shelf1 (AddBook "Solaris")+ call shelf1 GetBookList >>= mapM_ logDebug+ cast shelf1 (TakeBook "Solaris")+ call shelf1 GetBookList >>= mapM_ logDebug+ logNotice "Bookshelf Demo End"++restartChildTest :: HasCallStack => Endpoint (Broker (Stateful BookShelf)) -> Eff Effects ()+restartChildTest broker =+ OQ.observe @(Broker.ChildEvent (Stateful BookShelf)) (100 :: Int) broker $ do+ let c0 = BookShelfId 123+ spawnAndCrashBookShelf broker c0+ c01m <- Broker.lookupChild broker c0+ case c01m of+ Nothing ->+ lift (assertFailure "failed to lookup child, seems it wasn't restarted!")+ Just c01 -> do+ call c01 (AddBook "Solaris")+ logNotice "part 3 passed"++spawnBookShelf ::+ HasCallStack =>+ Endpoint (Broker (Stateful BookShelf)) ->+ Broker.ChildId (Stateful BookShelf) ->+ Eff (OQ.Reader (Broker.ChildEvent (Stateful BookShelf)) : Effects) (Endpoint BookShelf)+spawnBookShelf broker c0 = do+ logNotice "spawn or lookup book shelf"+ res <- Broker.spawnChild broker c0+ c00 <- case res of+ Left (Broker.AlreadyStarted _ ep) -> pure ep+ Right ep -> awaitChildStartedEvent c0 >> pure ep+ logNotice (LABEL "got book shelf" c00)+ pure c00++spawnAndCrashBookShelf ::+ HasCallStack =>+ Endpoint (Broker (Stateful BookShelf)) ->+ Broker.ChildId (Stateful BookShelf) ->+ Eff (OQ.Reader (Broker.ChildEvent (Stateful BookShelf)) : Effects) ()+spawnAndCrashBookShelf broker c0 = do+ c00 <- spawnBookShelf broker c0+ crashBookShelf c00 c0++crashBookShelf ::+ HasCallStack =>+ Endpoint BookShelf ->+ Broker.ChildId (Stateful BookShelf) ->+ Eff (OQ.Reader (Broker.ChildEvent (Stateful BookShelf)) : Effects) ()+crashBookShelf c00 c0 = do+ logNotice "adding Solaris"+ call c00 (AddBook "Solaris")+ logNotice "added Solaris"+ logNotice "adding Solaris again to crash the book shelf"+ handleInterrupts (const (pure ())) (call c00 (AddBook "Solaris")) -- adding twice the same book causes a crash+ logNotice "added Solaris again waiting for crash"+ void $ awaitProcessDown (c00 ^. fromEndpoint)+ logNotice "shelf crashed"+ awaitChildDownEvent c0++awaitBrokershuttingDownEvent broker = do+ logNotice (LABEL "waiting for broker shutting down event of" broker)+ evt <- OQ.await @(Broker.ChildEvent (Stateful BookShelf))+ case evt of+ x@(Broker.OnBrokerShuttingDown broker')+ | broker == broker' ->+ logNotice x+ otherEvent ->+ lift (assertFailure ("wrong event received: " <> showAsLogMsg otherEvent))++awaitChildDownEvent c0 = do+ logNotice (LABEL "waiting for down event of" c0)+ evt <- OQ.await @(Broker.ChildEvent (Stateful BookShelf))+ case evt of+ x@(Broker.OnChildDown _ c' _ _)+ | c0 == c' ->+ logNotice x+ otherEvent ->+ lift (assertFailure ("wrong broker down event received: " <> showAsLogMsg otherEvent))++awaitChildStartedEvent c0 = do+ logNotice (LABEL "waiting for start event of" c0)+ evt <- OQ.await @(Broker.ChildEvent (Stateful BookShelf))+ case evt of+ x@(Broker.OnChildSpawned _ c' _)+ | c0 == c' ->+ logNotice x+ otherEvent ->+ lift (assertFailure ("wrong broker start event received: " <> showAsLogMsg otherEvent))++data BookShelf deriving (Typeable)++type Book = String++instance HasPdu BookShelf where+ data Pdu BookShelf r where+ GetBookList :: Pdu BookShelf ('Synchronous [Book])+ AddBook :: Book -> Pdu BookShelf ('Synchronous ())+ TakeBook :: Book -> Pdu BookShelf 'Asynchronous+ StopShelf :: Pdu BookShelf 'Asynchronous+ deriving (Typeable)++instance Stateful.Server BookShelf Effects where+ newtype StartArgument BookShelf = BookShelfId Int+ deriving (Show, Eq, Ord, Num, NFData, Typeable)++ newtype Model BookShelf = BookShelfModel (Set String) deriving (Eq, Show, Default)++ update _ shelfId event = do+ logDebug shelfId event+ case event of+ Stateful.OnCast StopShelf -> do+ logNotice (MSG "stop shelf")+ exitNormally+ Stateful.OnCast (TakeBook book) -> do+ booksBefore <- Stateful.getModel @BookShelf+ booksAfter <- Stateful.modifyAndGetModel (over bookShelfModel (Set.delete book))+ when (booksBefore == booksAfter) (exitWithError "book not taken")+ Stateful.OnCall rt callEvent ->+ case callEvent of+ GetBookList -> do+ books <- Stateful.useModel bookShelfModel+ sendReply rt (toList books)+ AddBook book -> do+ booksBefore <- Stateful.getModel @BookShelf+ booksAfter <- Stateful.modifyAndGetModel (over bookShelfModel (Set.insert book))+ when (booksBefore == booksAfter) (exitWithError "book not added")+ sendReply rt ()+ other -> logWarning other++bookShelfModel :: Iso' (Stateful.Model BookShelf) (Set String)+bookShelfModel = iso (\(BookShelfModel s) -> s) BookShelfModel++instance ToLogMsg (Stateful.StartArgument BookShelf) where+ toLogMsg (BookShelfId bId) = packLogMsg "BookShelf" <> toLogMsg bId++type instance Broker.ChildId BookShelf = Stateful.StartArgument BookShelf++instance NFData (Pdu BookShelf r) where+ rnf GetBookList = ()+ rnf StopShelf = ()+ rnf (AddBook b) = rnf b+ rnf (TakeBook b) = rnf b++instance ToLogMsg (Pdu BookShelf r) where+ toLogMsg GetBookList = packLogMsg "get-book-list"+ toLogMsg StopShelf = packLogMsg "stop-shelf"+ toLogMsg (AddBook b) = packLogMsg "add-book: " <> toLogMsg b+ toLogMsg (TakeBook b) = packLogMsg "take-book: " <> toLogMsg b++instance ToTypeLogMsg BookShelf where+ toTypeLogMsg _ = fromString "BookShelf"
− with-hoogle.nix
@@ -1,22 +0,0 @@-# Use `ghc.WithHoogle` as `ghc` in `haskellPackages`-{--# Library of functions to use, for composeExtensions.-lib ? (import <nixpkgs> {}).pkgs.lib,--# Input set of all haskell packages. A valid input would be:-# (import <nixpkgs> {}).pkgs.haskellPackages-haskellPackages ? (import <nixpkgs> {}).pkgs.haskellPackages--}:--haskellPackages.override- (old: {- overrides =- lib.composeExtensions- (old.overrides or (_: _: {}))- (self: super: {- ghc = super.ghc // { withPackages = super.ghc.withHoogle; };- ghcWithPackages = self.ghc.withPackages;- });- })