diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -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 diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,18 +1,26 @@ # extensible-effects-concurrent -[![Build Status](https://travis-ci.org/sheyll/extensible-effects-concurrent.svg?branch=master)](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. + [![Hackage](https://img.shields.io/hackage/v/extensible-effects-concurrent.svg?style=flat)](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 diff --git a/benchmark.nix b/benchmark.nix new file mode 100644 --- /dev/null +++ b/benchmark.nix @@ -0,0 +1,4 @@ +{ withProfiling ? false +}: +(import ./default.nix { inherit withProfiling; }).extensible-effects-concurrent.components.benchmarks.extensible-effects-concurrent-bench + diff --git a/brittany.yaml b/brittany.yaml deleted file mode 100644 --- a/brittany.yaml +++ /dev/null @@ -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 diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -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 [ ]); + +} + diff --git a/examples/example-1/Main.hs b/examples/example-1/Main.hs --- a/examples/example-1/Main.hs +++ b/examples/example-1/Main.hs @@ -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) diff --git a/examples/example-2/Main.hs b/examples/example-2/Main.hs --- a/examples/example-2/Main.hs +++ b/examples/example-2/Main.hs @@ -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" diff --git a/examples/example-3/Main.hs b/examples/example-3/Main.hs --- a/examples/example-3/Main.hs +++ b/examples/example-3/Main.hs @@ -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)) diff --git a/examples/example-4/Main.hs b/examples/example-4/Main.hs --- a/examples/example-4/Main.hs +++ b/examples/example-4/Main.hs @@ -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.") diff --git a/examples/example-embedded-protocols/Main.hs b/examples/example-embedded-protocols/Main.hs --- a/examples/example-embedded-protocols/Main.hs +++ b/examples/example-embedded-protocols/Main.hs @@ -1,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) - - diff --git a/examples/loadtest/Main.hs b/examples/loadtest/Main.hs new file mode 100644 --- /dev/null +++ b/examples/loadtest/Main.hs @@ -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 +-- + diff --git a/extensible-effects-concurrent.cabal b/extensible-effects-concurrent.cabal --- a/extensible-effects-concurrent.cabal +++ b/extensible-effects-concurrent.cabal @@ -1,6 +1,6 @@ -cabal-version: 2.0 +cabal-version: 2.4 name: extensible-effects-concurrent -version: 0.32.0 +version: 2.0.0 description: Please see the README on GitHub at 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 diff --git a/extensible-effects-concurrent.nix b/extensible-effects-concurrent.nix deleted file mode 100644 --- a/extensible-effects-concurrent.nix +++ /dev/null @@ -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 {} diff --git a/release.nix b/release.nix deleted file mode 100644 --- a/release.nix +++ /dev/null @@ -1,2 +0,0 @@ -{ pkgs ? (import {}) }: -pkgs.callPackage ./extensible-effects-concurrent.nix {} diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -1,22 +1,26 @@ -let extensible-effects-concurrent = import ./extensible-effects-concurrent.nix; - pkgs = import {}; +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 + ]; +} + diff --git a/src-benchmark/Main.hs b/src-benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/src-benchmark/Main.hs @@ -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 + diff --git a/src/Control/Eff/Concurrent.hs b/src/Control/Eff/Concurrent.hs --- a/src/Control/Eff/Concurrent.hs +++ b/src/Control/Eff/Concurrent.hs @@ -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 diff --git a/src/Control/Eff/Concurrent/Misc.hs b/src/Control/Eff/Concurrent/Misc.hs deleted file mode 100644 --- a/src/Control/Eff/Concurrent/Misc.hs +++ /dev/null @@ -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 diff --git a/src/Control/Eff/Concurrent/Process.hs b/src/Control/Eff/Concurrent/Process.hs --- a/src/Control/Eff/Concurrent/Process.hs +++ b/src/Control/Eff/Concurrent/Process.hs @@ -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 diff --git a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs --- a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +++ b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs @@ -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) diff --git a/src/Control/Eff/Concurrent/Process/Interactive.hs b/src/Control/Eff/Concurrent/Process/Interactive.hs --- a/src/Control/Eff/Concurrent/Process/Interactive.hs +++ b/src/Control/Eff/Concurrent/Process/Interactive.hs @@ -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) diff --git a/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs b/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs --- a/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs +++ b/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs @@ -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. -- diff --git a/src/Control/Eff/Concurrent/Process/Timer.hs b/src/Control/Eff/Concurrent/Process/Timer.hs --- a/src/Control/Eff/Concurrent/Process/Timer.hs +++ b/src/Control/Eff/Concurrent/Process/Timer.hs @@ -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 diff --git a/src/Control/Eff/Concurrent/Protocol.hs b/src/Control/Eff/Concurrent/Protocol.hs --- a/src/Control/Eff/Concurrent/Protocol.hs +++ b/src/Control/Eff/Concurrent/Protocol.hs @@ -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 + diff --git a/src/Control/Eff/Concurrent/Protocol/Broker.hs b/src/Control/Eff/Concurrent/Protocol/Broker.hs --- a/src/Control/Eff/Concurrent/Protocol/Broker.hs +++ b/src/Control/Eff/Concurrent/Protocol/Broker.hs @@ -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) diff --git a/src/Control/Eff/Concurrent/Protocol/Broker/InternalState.hs b/src/Control/Eff/Concurrent/Protocol/Broker/InternalState.hs --- a/src/Control/Eff/Concurrent/Protocol/Broker/InternalState.hs +++ b/src/Control/Eff/Concurrent/Protocol/Broker/InternalState.hs @@ -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) diff --git a/src/Control/Eff/Concurrent/Protocol/CallbackServer.hs b/src/Control/Eff/Concurrent/Protocol/CallbackServer.hs --- a/src/Control/Eff/Concurrent/Protocol/CallbackServer.hs +++ b/src/Control/Eff/Concurrent/Protocol/CallbackServer.hs @@ -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 - diff --git a/src/Control/Eff/Concurrent/Protocol/Client.hs b/src/Control/Eff/Concurrent/Protocol/Client.hs --- a/src/Control/Eff/Concurrent/Protocol/Client.hs +++ b/src/Control/Eff/Concurrent/Protocol/Client.hs @@ -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) diff --git a/src/Control/Eff/Concurrent/Protocol/EffectfulServer.hs b/src/Control/Eff/Concurrent/Protocol/EffectfulServer.hs --- a/src/Control/Eff/Concurrent/Protocol/EffectfulServer.hs +++ b/src/Control/Eff/Concurrent/Protocol/EffectfulServer.hs @@ -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` () diff --git a/src/Control/Eff/Concurrent/Protocol/Observer.hs b/src/Control/Eff/Concurrent/Protocol/Observer.hs --- a/src/Control/Eff/Concurrent/Protocol/Observer.hs +++ b/src/Control/Eff/Concurrent/Protocol/Observer.hs @@ -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)) diff --git a/src/Control/Eff/Concurrent/Protocol/Observer/Queue.hs b/src/Control/Eff/Concurrent/Protocol/Observer/Queue.hs --- a/src/Control/Eff/Concurrent/Protocol/Observer/Queue.hs +++ b/src/Control/Eff/Concurrent/Protocol/Observer/Queue.hs @@ -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 diff --git a/src/Control/Eff/Concurrent/Protocol/StatefulServer.hs b/src/Control/Eff/Concurrent/Protocol/StatefulServer.hs --- a/src/Control/Eff/Concurrent/Protocol/StatefulServer.hs +++ b/src/Control/Eff/Concurrent/Protocol/StatefulServer.hs @@ -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 diff --git a/src/Control/Eff/Concurrent/Protocol/Watchdog.hs b/src/Control/Eff/Concurrent/Protocol/Watchdog.hs --- a/src/Control/Eff/Concurrent/Protocol/Watchdog.hs +++ b/src/Control/Eff/Concurrent/Protocol/Watchdog.hs @@ -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)) diff --git a/src/Control/Eff/Concurrent/Protocol/Wrapper.hs b/src/Control/Eff/Concurrent/Protocol/Wrapper.hs --- a/src/Control/Eff/Concurrent/Protocol/Wrapper.hs +++ b/src/Control/Eff/Concurrent/Protocol/Wrapper.hs @@ -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)) diff --git a/src/Control/Eff/Concurrent/Pure.hs b/src/Control/Eff/Concurrent/Pure.hs --- a/src/Control/Eff/Concurrent/Pure.hs +++ b/src/Control/Eff/Concurrent/Pure.hs @@ -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 - diff --git a/src/Control/Eff/Concurrent/SingleThreaded.hs b/src/Control/Eff/Concurrent/SingleThreaded.hs --- a/src/Control/Eff/Concurrent/SingleThreaded.hs +++ b/src/Control/Eff/Concurrent/SingleThreaded.hs @@ -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 - diff --git a/src/Control/Eff/ExceptionExtra.hs b/src/Control/Eff/ExceptionExtra.hs --- a/src/Control/Eff/ExceptionExtra.hs +++ b/src/Control/Eff/ExceptionExtra.hs @@ -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) diff --git a/src/Control/Eff/Log.hs b/src/Control/Eff/Log.hs --- a/src/Control/Eff/Log.hs +++ b/src/Control/Eff/Log.hs @@ -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'. -- diff --git a/src/Control/Eff/Log/Examples.hs b/src/Control/Eff/Log/Examples.hs --- a/src/Control/Eff/Log/Examples.hs +++ b/src/Control/Eff/Log/Examples.hs @@ -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 ) diff --git a/src/Control/Eff/Log/Handler.hs b/src/Control/Eff/Log/Handler.hs --- a/src/Control/Eff/Log/Handler.hs +++ b/src/Control/Eff/Log/Handler.hs @@ -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)) diff --git a/src/Control/Eff/Log/Message.hs b/src/Control/Eff/Log/Message.hs --- a/src/Control/Eff/Log/Message.hs +++ b/src/Control/Eff/Log/Message.hs @@ -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 diff --git a/src/Control/Eff/Log/MessageRenderer.hs b/src/Control/Eff/Log/MessageRenderer.hs --- a/src/Control/Eff/Log/MessageRenderer.hs +++ b/src/Control/Eff/Log/MessageRenderer.hs @@ -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 diff --git a/src/Control/Eff/Log/Writer.hs b/src/Control/Eff/Log/Writer.hs --- a/src/Control/Eff/Log/Writer.hs +++ b/src/Control/Eff/Log/Writer.hs @@ -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) diff --git a/src/Control/Eff/LogWriter/Async.hs b/src/Control/Eff/LogWriter/Async.hs --- a/src/Control/Eff/LogWriter/Async.hs +++ b/src/Control/Eff/LogWriter/Async.hs @@ -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 () } diff --git a/src/Control/Eff/LogWriter/Console.hs b/src/Control/Eff/LogWriter/Console.hs --- a/src/Control/Eff/LogWriter/Console.hs +++ b/src/Control/Eff/LogWriter/Console.hs @@ -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 diff --git a/src/Control/Eff/LogWriter/DebugTrace.hs b/src/Control/Eff/LogWriter/DebugTrace.hs --- a/src/Control/Eff/LogWriter/DebugTrace.hs +++ b/src/Control/Eff/LogWriter/DebugTrace.hs @@ -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) diff --git a/src/Control/Eff/LogWriter/File.hs b/src/Control/Eff/LogWriter/File.hs --- a/src/Control/Eff/LogWriter/File.hs +++ b/src/Control/Eff/LogWriter/File.hs @@ -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)) diff --git a/src/Control/Eff/LogWriter/Rich.hs b/src/Control/Eff/LogWriter/Rich.hs --- a/src/Control/Eff/LogWriter/Rich.hs +++ b/src/Control/Eff/LogWriter/Rich.hs @@ -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)) + ) diff --git a/src/Control/Eff/LogWriter/UDP.hs b/src/Control/Eff/LogWriter/UDP.hs --- a/src/Control/Eff/LogWriter/UDP.hs +++ b/src/Control/Eff/LogWriter/UDP.hs @@ -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 + ) + ) + ) diff --git a/src/Control/Eff/LogWriter/UnixSocket.hs b/src/Control/Eff/LogWriter/UnixSocket.hs --- a/src/Control/Eff/LogWriter/UnixSocket.hs +++ b/src/Control/Eff/LogWriter/UnixSocket.hs @@ -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 + ) + ) + ) diff --git a/src/Control/Eff/Loop.hs b/src/Control/Eff/Loop.hs --- a/src/Control/Eff/Loop.hs +++ b/src/Control/Eff/Loop.hs @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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} diff --git a/test/BrokerTests.hs b/test/BrokerTests.hs --- a/test/BrokerTests.hs +++ b/test/BrokerTests.hs @@ -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" diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -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 - - diff --git a/test/Debug.hs b/test/Debug.hs --- a/test/Debug.hs +++ b/test/Debug.hs @@ -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 diff --git a/test/Driver.hs b/test/Driver.hs --- a/test/Driver.hs +++ b/test/Driver.hs @@ -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 ] diff --git a/test/ForkIOScheduler.hs b/test/ForkIOScheduler.hs --- a/test/ForkIOScheduler.hs +++ b/test/ForkIOScheduler.hs @@ -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) diff --git a/test/GenServerTests.hs b/test/GenServerTests.hs --- a/test/GenServerTests.hs +++ b/test/GenServerTests.hs @@ -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" + ] diff --git a/test/Interactive.hs b/test/Interactive.hs --- a/test/Interactive.hs +++ b/test/Interactive.hs @@ -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 diff --git a/test/LogMessageIdeaTest.hs b/test/LogMessageIdeaTest.hs deleted file mode 100644 --- a/test/LogMessageIdeaTest.hs +++ /dev/null @@ -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 diff --git a/test/LoggingTests.hs b/test/LoggingTests.hs --- a/test/LoggingTests.hs +++ b/test/LoggingTests.hs @@ -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 diff --git a/test/LoopTests.hs b/test/LoopTests.hs --- a/test/LoopTests.hs +++ b/test/LoopTests.hs @@ -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 () + ] diff --git a/test/ObserverTests.hs b/test/ObserverTests.hs --- a/test/ObserverTests.hs +++ b/test/ObserverTests.hs @@ -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" diff --git a/test/ProcessBehaviourTestCases.hs b/test/ProcessBehaviourTestCases.hs --- a/test/ProcessBehaviourTestCases.hs +++ b/test/ProcessBehaviourTestCases.hs @@ -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 () + ) + ) + ] + ] + ) diff --git a/test/SingleThreadedScheduler.hs b/test/SingleThreadedScheduler.hs --- a/test/SingleThreadedScheduler.hs +++ b/test/SingleThreadedScheduler.hs @@ -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)!!" diff --git a/test/WatchdogTests.hs b/test/WatchdogTests.hs --- a/test/WatchdogTests.hs +++ b/test/WatchdogTests.hs @@ -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" diff --git a/with-hoogle.nix b/with-hoogle.nix deleted file mode 100644 --- a/with-hoogle.nix +++ /dev/null @@ -1,22 +0,0 @@ -# Use `ghc.WithHoogle` as `ghc` in `haskellPackages` -{ - -# Library of functions to use, for composeExtensions. -lib ? (import {}).pkgs.lib, - -# Input set of all haskell packages. A valid input would be: -# (import {}).pkgs.haskellPackages -haskellPackages ? (import {}).pkgs.haskellPackages - -}: - -haskellPackages.override - (old: { - overrides = - lib.composeExtensions - (old.overrides or (_: _: {})) - (self: super: { - ghc = super.ghc // { withPackages = super.ghc.withHoogle; }; - ghcWithPackages = self.ghc.withPackages; - }); - })