├── Setup.hs ├── stack.yaml ├── README.md ├── .gitignore ├── stack.yaml.lock ├── src ├── NQE.hs └── Control │ └── Concurrent │ └── NQE │ ├── Conduit.hs │ ├── Publisher.hs │ ├── Supervisor.hs │ └── Process.hs ├── package.yaml ├── LICENSE ├── CHANGELOG.md ├── nqe.cabal └── test └── Spec.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.21 2 | nix: 3 | packages: 4 | - zlib 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Not Quite Erlang 2 | 3 | Haskell framework for concurrency inspired by Erlang/OTP. 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | 21 | ## Vim 22 | # swap 23 | [._]*.s[a-v][a-z] 24 | [._]*.sw[a-p] 25 | [._]s[a-v][a-z] 26 | [._]sw[a-p] 27 | # session 28 | Session.vim 29 | # temporary 30 | .netrwhist 31 | *~ 32 | # auto-generated tag files 33 | tags 34 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/topics/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: f4a61482dcad21151331bf84ec85bee9be43965f143791fa4bb202ac1e443e1b 10 | size: 683833 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/21.yaml 12 | original: lts-23.21 13 | -------------------------------------------------------------------------------- /src/NQE.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : NQE 3 | Copyright : No rights reserved 4 | License : UNLICENSE 5 | Maintainer : xenog@protonmail.com 6 | Stability : experimental 7 | Portability : POSIX 8 | 9 | Concurrency library inspired by Erlang/OTP. 10 | -} 11 | module NQE 12 | ( -- * Processes and Mailboxes 13 | module Process 14 | -- * Process Supervisors 15 | , module Supervisor 16 | -- * Publisher and Subscribers 17 | , module Publisher 18 | -- * Conduit Integration 19 | , module Conduit 20 | ) where 21 | 22 | import Control.Concurrent.NQE.Conduit as Conduit 23 | import Control.Concurrent.NQE.Process as Process 24 | import Control.Concurrent.NQE.Publisher as Publisher 25 | import Control.Concurrent.NQE.Supervisor as Supervisor 26 | -------------------------------------------------------------------------------- /src/Control/Concurrent/NQE/Conduit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-| 5 | Module : Control.Concurrent.NQE.Conduit 6 | Copyright : No rights reserved 7 | License : UNLICENSE 8 | Maintainer : xenog@protonmail.com 9 | Stability : experimental 10 | Portability : POSIX 11 | 12 | Mix NQE processes with conduits for easy concurrent IO. 13 | -} 14 | module Control.Concurrent.NQE.Conduit where 15 | 16 | import Conduit 17 | import Control.Concurrent.NQE.Process 18 | import Data.Typeable 19 | 20 | -- | Consumes messages from a 'Conduit' and sends them to a channel. 21 | conduitMailbox :: 22 | (MonadIO m, OutChan mbox, Typeable msg) 23 | => mbox msg 24 | -> ConduitT msg o m () 25 | conduitMailbox mbox = awaitForever (`send` mbox) 26 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: nqe 2 | version: 0.6.6 3 | synopsis: Concurrency library in the style of Erlang/OTP 4 | description: Please see the README on GitHub at 5 | category: Control 6 | author: JP Rupp 7 | maintainer: jprupp@protonmail.ch 8 | license: MIT 9 | license-file: LICENSE 10 | github: xenog/nqe 11 | extra-source-files: 12 | - README.md 13 | - CHANGELOG.md 14 | dependencies: 15 | - base >=4.8 && <5 16 | - conduit 17 | - stm 18 | - unliftio 19 | library: 20 | source-dirs: src 21 | dependencies: 22 | - containers 23 | - hashable 24 | - mtl 25 | - unique 26 | tests: 27 | nqe-test: 28 | main: Spec.hs 29 | source-dirs: test 30 | ghc-options: 31 | - -threaded 32 | - -rtsopts 33 | - -with-rtsopts=-N 34 | dependencies: 35 | - async 36 | - bytestring 37 | - conduit-extra 38 | - exceptions 39 | - hspec 40 | - nqe 41 | - stm-conduit 42 | - text 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020 Haskoin Developers 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software is furnished to do so, 8 | subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 19 | 20 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | All notable changes to this project will be documented in this file. 3 | 4 | The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) 5 | and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). 6 | 7 | ## 0.6.6 8 | ### Changed 9 | - Simplify author name. 10 | - Bump LTS Haskell. 11 | 12 | ## 0.6.5 13 | ### Fixed 14 | - Don't call `waitAnyCatchSTM` with an empty list. 15 | 16 | ## 0.6.4 17 | ### Fixed 18 | - Import `Control.Monad` to fix `mtl-2.3` issue. 19 | 20 | ## 0.6.3 21 | ### Changed 22 | - Add `publish` and `publishSTM` functions. 23 | 24 | ## 0.6.2 25 | ### Changed 26 | - Change license to MIT. 27 | 28 | ## 0.6.1 29 | ### Changed 30 | - Make it compatible with `newTBQueue` getting `Natural` instead of `Int`. 31 | 32 | ## 0.6.0 33 | ### Changed 34 | - Overhaul entire API in a non-backwards-compatible way. 35 | - Separate read/write from write-only mailbox types. 36 | - Improve documentation. 37 | 38 | ## 0.5.0 39 | ### Added 40 | - `Inbox` type is now comparable for equality. 41 | - Haddock documentation for all functions, types and classes. 42 | - Expose `SupervisorMessage` type alias. 43 | - Expose `Publisher` type alias. 44 | 45 | ### Changed 46 | - Change `Mailbox` typeclass. 47 | - Simplify PubSub module. 48 | - Replace network features with a single conduit. 49 | - Multiple API changes. 50 | 51 | ### Removed 52 | - Remove dispatcher functions. 53 | 54 | ## 0.4.1 55 | ### Changed 56 | - Specify different dependencies for test and library. 57 | 58 | ### Removed 59 | - Remove Cabal file from repository. 60 | 61 | ## 0.4.0 62 | ### Added 63 | - Changelog and semantic versions. 64 | - Raw TCP actors. 65 | - Move to `package.yaml` and `hpack`. 66 | - Type-safe asynchronous messages. 67 | - Supervisors for `MonadUnliftIO` actions. 68 | - Test suite. 69 | - PubSub actor. 70 | - Support for bounded PubSub subscribers. 71 | -------------------------------------------------------------------------------- /nqe.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.38.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: eccc612cfd9271d97bc20072fbd9bda9b4353231324881cd805cd2cf55df53e1 8 | 9 | name: nqe 10 | version: 0.6.6 11 | synopsis: Concurrency library in the style of Erlang/OTP 12 | description: Please see the README on GitHub at 13 | category: Control 14 | homepage: https://github.com/xenog/nqe#readme 15 | bug-reports: https://github.com/xenog/nqe/issues 16 | author: JP Rupp 17 | maintainer: jprupp@protonmail.ch 18 | license: MIT 19 | license-file: LICENSE 20 | build-type: Simple 21 | extra-source-files: 22 | README.md 23 | CHANGELOG.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/xenog/nqe 28 | 29 | library 30 | exposed-modules: 31 | Control.Concurrent.NQE.Conduit 32 | Control.Concurrent.NQE.Process 33 | Control.Concurrent.NQE.Publisher 34 | Control.Concurrent.NQE.Supervisor 35 | NQE 36 | other-modules: 37 | Paths_nqe 38 | hs-source-dirs: 39 | src 40 | build-depends: 41 | base >=4.8 && <5 42 | , conduit 43 | , containers 44 | , hashable 45 | , mtl 46 | , stm 47 | , unique 48 | , unliftio 49 | default-language: Haskell2010 50 | 51 | test-suite nqe-test 52 | type: exitcode-stdio-1.0 53 | main-is: Spec.hs 54 | other-modules: 55 | Paths_nqe 56 | hs-source-dirs: 57 | test 58 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 59 | build-depends: 60 | async 61 | , base >=4.8 && <5 62 | , bytestring 63 | , conduit 64 | , conduit-extra 65 | , exceptions 66 | , hspec 67 | , nqe 68 | , stm 69 | , stm-conduit 70 | , text 71 | , unliftio 72 | default-language: Haskell2010 73 | -------------------------------------------------------------------------------- /src/Control/Concurrent/NQE/Publisher.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-| 3 | Module : Control.Concurrent.NQE.Publisher 4 | Copyright : No rights reserved 5 | License : UNLICENSE 6 | Maintainer : xenog@protonmail.com 7 | Stability : experimental 8 | Portability : POSIX 9 | 10 | A publisher is a process that forwards messages to subscribers. NQE publishers 11 | are simple, and do not implement filtering directly, although that can be done 12 | on the 'STM' 'Listen' actions that forward messages to subscribers. 13 | 14 | If a subscriber has been added to a publisher using the 'subscribe' function, it 15 | needs to be removed later using 'unsubscribe' when it is no longer needed, or 16 | the publisher will continue calling its 'Listen' action in the future, likely 17 | causing memory leaks. 18 | -} 19 | module Control.Concurrent.NQE.Publisher 20 | ( Subscriber 21 | , PublisherMessage(..) 22 | , Publisher 23 | , withSubscription 24 | , subscribe 25 | , unsubscribe 26 | , withPublisher 27 | , publisher 28 | , publisherProcess 29 | , publish 30 | , publishSTM 31 | ) where 32 | 33 | import Control.Concurrent.NQE.Process 34 | import Control.Concurrent.Unique 35 | import Control.Monad 36 | import Control.Monad.Reader 37 | import Data.Function 38 | import Data.Hashable 39 | import Data.List 40 | import UnliftIO 41 | 42 | -- | Handle of a subscriber to a process. Should be kept in order to 43 | -- unsubscribe. 44 | data Subscriber msg = Subscriber (Listen msg) Unique 45 | 46 | instance Eq (Subscriber msg) where 47 | (==) = (==) `on` f 48 | where 49 | f (Subscriber _ u) = u 50 | 51 | instance Hashable (Subscriber msg) where 52 | hashWithSalt i (Subscriber _ u) = hashWithSalt i u 53 | 54 | -- | Messages that a publisher will take. 55 | data PublisherMessage msg 56 | = Subscribe !(Listen msg) !(Listen (Subscriber msg)) 57 | | Unsubscribe !(Subscriber msg) 58 | | Event msg 59 | 60 | -- | Alias for a publisher process. 61 | type Publisher msg = Process (PublisherMessage msg) 62 | 63 | publish :: MonadIO m => msg -> Publisher msg -> m () 64 | publish = send . Event 65 | 66 | publishSTM :: msg -> Publisher msg -> STM () 67 | publishSTM = sendSTM . Event 68 | 69 | -- | Create a mailbox, subscribe it to a publisher and pass it to the supplied 70 | -- function . End subscription when function returns. 71 | withSubscription :: 72 | MonadUnliftIO m => Publisher msg -> (Inbox msg -> m a) -> m a 73 | withSubscription pub f = do 74 | inbox <- newInbox 75 | let sub = subscribe pub (`sendSTM` inbox) 76 | unsub = unsubscribe pub 77 | bracket sub unsub $ \_ -> f inbox 78 | 79 | -- | 'Listen' to events from a publisher. 80 | subscribe :: MonadIO m => Publisher msg -> Listen msg -> m (Subscriber msg) 81 | subscribe pub sub = Subscribe sub `query` pub 82 | 83 | -- | Stop listening to events from a publisher. Must provide 'Subscriber' that 84 | -- was returned from corresponding 'subscribe' action. 85 | unsubscribe :: MonadIO m => Publisher msg -> Subscriber msg -> m () 86 | unsubscribe pub sub = Unsubscribe sub `send` pub 87 | 88 | -- | Start a publisher in the background and pass it to a function. The 89 | -- publisher will be stopped when the function function returns. 90 | withPublisher :: MonadUnliftIO m => (Publisher msg -> m a) -> m a 91 | withPublisher = withProcess publisherProcess 92 | 93 | -- | Start a publisher in the background. 94 | publisher :: MonadUnliftIO m => m (Publisher msg) 95 | publisher = process publisherProcess 96 | 97 | -- | Start a publisher in the current thread. 98 | publisherProcess :: MonadUnliftIO m => Inbox (PublisherMessage msg) -> m () 99 | publisherProcess inbox = newTVarIO [] >>= runReaderT go 100 | where 101 | go = forever $ receive inbox >>= publisherMessage 102 | 103 | -- | Internal function to dispatch a publisher message. 104 | publisherMessage :: 105 | (MonadIO m, MonadReader (TVar [Subscriber msg]) m) 106 | => PublisherMessage msg 107 | -> m () 108 | publisherMessage (Subscribe sub r) = 109 | ask >>= \box -> do 110 | u <- liftIO newUnique 111 | let s = Subscriber sub u 112 | atomically $ do 113 | modifyTVar box (`union` [s]) 114 | r s 115 | publisherMessage (Unsubscribe sub) = 116 | ask >>= \box -> atomically (modifyTVar box (delete sub)) 117 | publisherMessage (Event event) = 118 | ask >>= \box -> 119 | atomically $ 120 | readTVar box >>= \subs -> 121 | forM_ subs $ \(Subscriber sub _) -> sub event 122 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | import Conduit 6 | import Control.Concurrent.Async (ExceptionInLinkedThread (..)) 7 | import Control.Concurrent.STM (check) 8 | import Control.Monad 9 | import NQE 10 | import Test.Hspec 11 | import UnliftIO 12 | import UnliftIO.Concurrent hiding (yield) 13 | 14 | data Pong = Pong deriving (Eq, Show) 15 | newtype Ping = Ping (Listen Pong) 16 | 17 | data TestError 18 | = TestError1 19 | | TestError2 20 | deriving (Show, Eq) 21 | instance Exception TestError 22 | 23 | testError :: Selector TestError 24 | testError = const True 25 | 26 | testError1 :: Selector TestError 27 | testError1 e = e == TestError1 28 | 29 | threadError :: Exception e => Selector e -> Selector ExceptionInLinkedThread 30 | threadError e (ExceptionInLinkedThread _ s) = maybe False e (fromException s) 31 | 32 | notifError :: Exception e => Selector e -> Selector (Maybe SomeException) 33 | notifError e s = maybe False e (s >>= fromException) 34 | 35 | pongServer :: MonadIO m => Inbox Ping -> m () 36 | pongServer mbox = 37 | forever $ do 38 | Ping r <- receive mbox 39 | atomically (r Pong) 40 | 41 | main :: IO () 42 | main = 43 | hspec $ do 44 | describe "two communicating processes" $ 45 | it "exchange ping/pong messages" $ do 46 | g <- withProcess pongServer (query Ping) 47 | g `shouldBe` Pong 48 | describe "supervisor" $ do 49 | let dummy = threadDelay $ 1000 * 1000 50 | it "all processes end without failure" $ do 51 | let action = 52 | withSupervisor KillAll $ \sup -> do 53 | addChild sup dummy 54 | addChild sup dummy 55 | threadDelay $ 100 * 1000 56 | action `shouldReturn` () 57 | it "one process crashes" $ do 58 | let action = 59 | withSupervisor IgnoreGraceful $ \sup -> do 60 | addChild sup dummy 61 | addChild sup (throwIO TestError1) 62 | threadDelay $ 500 * 1000 63 | action `shouldThrow` threadError testError1 64 | it "both processes crash" $ do 65 | let action = 66 | withSupervisor IgnoreGraceful $ \sup -> do 67 | addChild sup (throwIO TestError1) 68 | addChild sup (throwIO TestError2) 69 | threadDelay $ 500 * 1000 70 | action `shouldThrow` threadError testError 71 | it "monitors processes" $ do 72 | let rcv i = receive i :: IO (Maybe SomeException) 73 | (inbox, mailbox) <- newMailbox 74 | (t1, t2) <- 75 | withSupervisor (Notify ((`sendSTM` mailbox) . snd)) $ \sup -> do 76 | addChild sup (throwIO TestError1) 77 | addChild sup (throwIO TestError2) 78 | (,) <$> rcv inbox <*> rcv inbox 79 | t1 `shouldSatisfy` notifError testError 80 | t2 `shouldSatisfy` notifError testError 81 | describe "pubsub" $ do 82 | it "sends messages to all subscribers" $ do 83 | let msgs = words "hello world" 84 | (inbox1, mbox1) <- newMailbox 85 | (inbox2, mbox2) <- newMailbox 86 | (msgs1, msgs2) <- 87 | withPublisher $ \pub -> do 88 | subscribe pub (`sendSTM` mbox1) 89 | subscribe pub (`sendSTM` mbox2) 90 | mapM_ ((`send` pub) . Event) msgs 91 | msgs1 <- replicateM 2 (receive inbox1) 92 | msgs2 <- replicateM 2 (receive inbox2) 93 | return (msgs1, msgs2) 94 | msgs1 `shouldBe` msgs 95 | msgs2 `shouldBe` msgs 96 | it "drops messages when bounded queue full" $ do 97 | let msgs = words "hello world drop" 98 | let f mbox msg = mailboxFullSTM mbox >>= \case 99 | True -> return () 100 | False -> msg `sendSTM` mbox 101 | msgs' <- 102 | withPublisher $ \pub -> do 103 | inbox <- newBoundedInbox 2 104 | subscribe pub (f (inboxToMailbox inbox)) 105 | mapM_ ((`send` pub) . Event) msgs 106 | atomically $ check =<< mailboxFullSTM inbox 107 | threadDelay $ 250 * 1000 108 | msgs' <- replicateM 2 (receive inbox) 109 | Event "meh" `send` pub 110 | msg <- receive inbox 111 | return $ msgs' <> [msg] 112 | msgs' `shouldBe` words "hello world meh" 113 | -------------------------------------------------------------------------------- /src/Control/Concurrent/NQE/Supervisor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | 7 | -- | 8 | -- Module : Control.Concurrent.NQE.Supervisor 9 | -- Copyright : No rights reserved 10 | -- License : UNLICENSE 11 | -- Maintainer : xenog@protonmail.com 12 | -- Stability : experimental 13 | -- Portability : POSIX 14 | -- 15 | -- Supervisors run and monitor processes, including other supervisors. A supervisor 16 | -- has a corresponding 'Strategy' that controls its behaviour if a child stops. 17 | -- Supervisors deal with exceptions in concurrent processes so that their code does 18 | -- not need to be written in an overly-defensive style. They help prevent problems 19 | -- caused by processes dying quietly in the background, potentially locking an 20 | -- entire application. 21 | module Control.Concurrent.NQE.Supervisor 22 | ( ChildAction, 23 | Child, 24 | SupervisorMessage, 25 | Supervisor, 26 | Strategy (..), 27 | withSupervisor, 28 | supervisor, 29 | supervisorProcess, 30 | addChild, 31 | removeChild, 32 | ) 33 | where 34 | 35 | import Control.Applicative 36 | import Control.Concurrent.NQE.Process 37 | import Control.Concurrent.STM (retry) 38 | import Control.Monad 39 | import Data.List 40 | import UnliftIO 41 | 42 | -- | Alias for child action to be executed asynchronously by supervisor. 43 | type ChildAction = IO () 44 | 45 | -- | Thread handler for child. 46 | type Child = Async () 47 | 48 | -- | Send this message to a supervisor to add or remove a child. 49 | data SupervisorMessage 50 | = AddChild 51 | !ChildAction 52 | !(Listen Child) 53 | | RemoveChild 54 | !Child 55 | !(Listen ()) 56 | 57 | -- | Alias for supervisor process. 58 | type Supervisor = Process SupervisorMessage 59 | 60 | -- | Supervisor strategies to decide what to do when a child stops. 61 | data Strategy 62 | = -- | send a 'SupervisorNotif' to 'Mailbox' when child dies 63 | Notify (Listen (Child, Maybe SomeException)) 64 | | -- | kill all processes and propagate exception upstream 65 | KillAll 66 | | -- | ignore processes that stop without raising an exception 67 | IgnoreGraceful 68 | | -- | keep running if a child dies and ignore it 69 | IgnoreAll 70 | 71 | -- | Run a supervisor asynchronously and pass its mailbox to a function. 72 | -- Supervisor will be stopped along with all its children when the function 73 | -- ends. 74 | withSupervisor :: 75 | (MonadUnliftIO m) => 76 | Strategy -> 77 | (Supervisor -> m a) -> 78 | m a 79 | withSupervisor = withProcess . supervisorProcess 80 | 81 | -- | Run a supervisor as an asynchronous process. 82 | supervisor :: (MonadUnliftIO m) => Strategy -> m Supervisor 83 | supervisor strat = process (supervisorProcess strat) 84 | 85 | -- | Run a supervisor in the current thread. 86 | supervisorProcess :: 87 | (MonadUnliftIO m) => 88 | Strategy -> 89 | Inbox SupervisorMessage -> 90 | m () 91 | supervisorProcess strat i = do 92 | state <- newTVarIO [] 93 | finally (loop state) (stopAll state) 94 | where 95 | loop state = do 96 | e <- atomically $ Right <$> receiveSTM i <|> Left <$> waitForChild state 97 | again <- 98 | case e of 99 | Right m -> processMessage state m 100 | Left x -> processDead state strat x 101 | when again $ loop state 102 | 103 | -- | Add a new 'ChildAction' to the supervisor. Will return the 'Child' that was 104 | -- just started. This function will not block or raise an exception if the child 105 | -- dies. 106 | addChild :: (MonadIO m) => Supervisor -> ChildAction -> m Child 107 | addChild sup action = AddChild action `query` sup 108 | 109 | -- | Stop a 'Child' controlled by this supervisor. Will block until the child 110 | -- dies. 111 | removeChild :: (MonadIO m) => Supervisor -> Child -> m () 112 | removeChild sup c = RemoveChild c `query` sup 113 | 114 | -- | Internal function to stop all children. 115 | stopAll :: (MonadUnliftIO m) => TVar [Child] -> m () 116 | stopAll state = mask_ $ do 117 | as <- readTVarIO state 118 | mapM_ cancel as 119 | 120 | -- | Internal function to wait for a child process to finish running. 121 | waitForChild :: TVar [Child] -> STM (Child, Either SomeException ()) 122 | waitForChild state = do 123 | as <- readTVar state 124 | when (null as) retry 125 | waitAnyCatchSTM as 126 | 127 | -- | Internal function to process incoming supervisor message. 128 | processMessage :: 129 | (MonadUnliftIO m) => TVar [Child] -> SupervisorMessage -> m Bool 130 | processMessage state (AddChild ch r) = do 131 | a <- startChild state ch 132 | atomically $ r a 133 | return True 134 | processMessage state (RemoveChild a r) = do 135 | stopChild state a 136 | atomically $ r () 137 | return True 138 | 139 | -- | Internal function to run when a child process dies. 140 | processDead :: 141 | (MonadUnliftIO m) => 142 | TVar [Child] -> 143 | Strategy -> 144 | (Child, Either SomeException ()) -> 145 | m Bool 146 | processDead state IgnoreAll (a, _) = do 147 | atomically . modifyTVar' state $ filter (/= a) 148 | return True 149 | processDead state KillAll (a, e) = do 150 | atomically $ modifyTVar' state . filter $ (/= a) 151 | stopAll state 152 | case e of 153 | Left x -> throwIO x 154 | Right () -> return False 155 | processDead state IgnoreGraceful (a, Right ()) = do 156 | atomically (modifyTVar' state (filter (/= a))) 157 | return True 158 | processDead state IgnoreGraceful (a, Left e) = do 159 | atomically $ modifyTVar' state (filter (/= a)) 160 | stopAll state 161 | throwIO e 162 | processDead state (Notify notif) (a, ee) = do 163 | atomically $ do 164 | as <- readTVar state 165 | case find (== a) as of 166 | Just p -> notif (p, me) 167 | Nothing -> return () 168 | modifyTVar state (filter (/= a)) 169 | return True 170 | where 171 | me = 172 | case ee of 173 | Left e -> Just e 174 | Right () -> Nothing 175 | 176 | -- | Internal function to start a child process. 177 | startChild :: (MonadUnliftIO m) => TVar [Child] -> ChildAction -> m Child 178 | startChild state ch = mask_ $ do 179 | a <- liftIO $ async ch 180 | atomically $ modifyTVar' state (a :) 181 | return a 182 | 183 | -- | Internal fuction to stop a child process. 184 | stopChild :: (MonadUnliftIO m) => TVar [Child] -> Child -> m () 185 | stopChild state a = mask_ $ do 186 | isChild <- 187 | atomically $ do 188 | cur <- readTVar state 189 | let new = filter (/= a) cur 190 | writeTVar state new 191 | return (cur /= new) 192 | when isChild $ cancel a 193 | -------------------------------------------------------------------------------- /src/Control/Concurrent/NQE/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-| 7 | Module : Control.Concurrent.NQE.Process 8 | Copyright : No rights reserved 9 | License : UNLICENSE 10 | Maintainer : xenog@protonmail.com 11 | Stability : experimental 12 | Portability : POSIX 13 | 14 | This is the core of the NQE library. It is composed of code to deal with 15 | processes and mailboxes. Processes represent concurrent threads that receive 16 | messages via a mailbox, also referred to as a channel. NQE is inspired by 17 | Erlang/OTP and it stands for “Not Quite Erlang”. A process is analogous to an 18 | actor in Scala, or an object in the original (Alan Kay) sense of the word. To 19 | implement synchronous communication NQE makes use of 'STM' actions embedded in 20 | asynchronous messages. 21 | -} 22 | module Control.Concurrent.NQE.Process where 23 | 24 | import Control.Concurrent.Unique 25 | import Data.Function 26 | import Data.Hashable 27 | import Numeric.Natural 28 | import UnliftIO 29 | 30 | -- | 'STM' function that receives an event and does something with it. 31 | type Listen a = a -> STM () 32 | 33 | -- | Channel that only allows messages to be sent to it. 34 | data Mailbox msg = 35 | forall mbox. (OutChan mbox) => 36 | Mailbox !(mbox msg) 37 | !Unique 38 | 39 | -- | Channel that allows to send or receive messages. 40 | data Inbox msg = 41 | forall mbox. (OutChan mbox, InChan mbox) => 42 | Inbox !(mbox msg) 43 | !Unique 44 | 45 | instance Eq (Mailbox msg) where 46 | (==) = (==) `on` f 47 | where 48 | f (Mailbox _ u) = u 49 | 50 | instance Eq (Inbox msg) where 51 | (==) = (==) `on` f 52 | where 53 | f (Inbox _ u) = u 54 | 55 | -- | 'Async' handle and 'Mailbox' for a process. 56 | data Process msg = Process 57 | { getProcessAsync :: Async () 58 | , getProcessMailbox :: Mailbox msg 59 | } deriving Eq 60 | 61 | -- | Class for implementation of an 'Inbox'. 62 | class InChan mbox where 63 | -- | Are there messages queued? 64 | mailboxEmptySTM :: mbox msg -> STM Bool 65 | -- | Receive a message. 66 | receiveSTM :: mbox msg -> STM msg 67 | -- | Put a message in the mailbox such that it is received next. 68 | requeueSTM :: msg -> mbox msg -> STM () 69 | 70 | -- | Class for implementation of a 'Mailbox'. 71 | class OutChan mbox where 72 | -- | Is this bounded channel full? Always 'False' for unbounded channels. 73 | mailboxFullSTM :: mbox msg -> STM Bool 74 | -- | Send a message to this channel. 75 | sendSTM :: msg -> mbox msg -> STM () 76 | 77 | instance InChan TQueue where 78 | mailboxEmptySTM = isEmptyTQueue 79 | receiveSTM = readTQueue 80 | requeueSTM msg = (`unGetTQueue` msg) 81 | 82 | instance OutChan TQueue where 83 | mailboxFullSTM _ = return False 84 | sendSTM msg = (`writeTQueue` msg) 85 | 86 | instance InChan TBQueue where 87 | mailboxEmptySTM = isEmptyTBQueue 88 | receiveSTM = readTBQueue 89 | requeueSTM msg = (`unGetTBQueue` msg) 90 | 91 | instance OutChan TBQueue where 92 | mailboxFullSTM = isFullTBQueue 93 | sendSTM msg = (`writeTBQueue` msg) 94 | 95 | instance OutChan Mailbox where 96 | mailboxFullSTM (Mailbox mbox _) = mailboxFullSTM mbox 97 | sendSTM msg (Mailbox mbox _) = msg `sendSTM` mbox 98 | 99 | instance InChan Inbox where 100 | mailboxEmptySTM (Inbox mbox _) = mailboxEmptySTM mbox 101 | receiveSTM (Inbox mbox _) = receiveSTM mbox 102 | requeueSTM msg (Inbox mbox _) = msg `requeueSTM` mbox 103 | 104 | instance OutChan Inbox where 105 | mailboxFullSTM (Inbox mbox _) = mailboxFullSTM mbox 106 | sendSTM msg (Inbox mbox _) = msg `sendSTM` mbox 107 | 108 | instance OutChan Process where 109 | mailboxFullSTM (Process _ mbox) = mailboxFullSTM mbox 110 | sendSTM msg (Process _ mbox) = msg `sendSTM` mbox 111 | 112 | instance Hashable (Process msg) where 113 | hashWithSalt i (Process _ m) = hashWithSalt i m 114 | hash (Process _ m) = hash m 115 | 116 | instance Hashable (Mailbox msg) where 117 | hashWithSalt i (Mailbox _ u) = hashWithSalt i u 118 | hash (Mailbox _ u) = hash u 119 | 120 | -- | Get a send-only 'Mailbox' for an 'Inbox'. 121 | inboxToMailbox :: Inbox msg -> Mailbox msg 122 | inboxToMailbox (Inbox m u) = Mailbox m u 123 | 124 | -- | Wrap a channel in an 'Inbox' 125 | wrapChannel :: 126 | (MonadIO m, InChan mbox, OutChan mbox) => mbox msg -> m (Inbox msg) 127 | wrapChannel mbox = Inbox mbox <$> liftIO newUnique 128 | 129 | -- | Create an unbounded 'Inbox'. 130 | newInbox :: MonadIO m => m (Inbox msg) 131 | newInbox = newTQueueIO >>= \c -> wrapChannel c 132 | 133 | -- | 'Inbox' with upper bound on number of allowed queued messages. 134 | newBoundedInbox :: MonadIO m => Natural -> m (Inbox msg) 135 | newBoundedInbox i = newTBQueueIO (fromIntegral i) >>= \c -> wrapChannel c 136 | 137 | -- | Send a message to a channel. 138 | send :: (MonadIO m, OutChan mbox) => msg -> mbox msg -> m () 139 | send msg = atomically . sendSTM msg 140 | 141 | -- | Receive a message from a channel. 142 | receive :: (InChan mbox, MonadIO m) => mbox msg -> m msg 143 | receive mbox = receiveMatch mbox Just 144 | 145 | -- | Send request to channel and wait for a response. The @request@ 'STM' action 146 | -- will be created by this function. 147 | query :: 148 | (MonadIO m, OutChan mbox) 149 | => (Listen response -> request) 150 | -> mbox request 151 | -> m response 152 | query f m = do 153 | r <- newEmptyTMVarIO 154 | f (putTMVar r) `send` m 155 | atomically $ takeTMVar r 156 | 157 | -- | Do a 'query' but timeout after @u@ microseconds. Return 'Nothing' if 158 | -- timeout reached. 159 | queryU :: 160 | (MonadUnliftIO m, OutChan mbox) 161 | => Int 162 | -> (Listen response -> request) 163 | -> mbox request 164 | -> m (Maybe response) 165 | queryU u f m = timeout u (query f m) 166 | 167 | -- | Do a 'query' but timeout after @s@ seconds. Return 'Nothing' if 168 | -- timeout reached. 169 | queryS :: 170 | (MonadUnliftIO m, OutChan mbox) 171 | => Int 172 | -> (Listen response -> request) 173 | -> mbox request 174 | -> m (Maybe response) 175 | queryS s f m = timeout (s * 1000 * 1000) (query f m) 176 | 177 | -- | Test all messages in a channel against the supplied function and return the 178 | -- first matching message. Will block until a match is found. Messages that do 179 | -- not match remain in the channel. 180 | receiveMatch :: (MonadIO m, InChan mbox) => mbox msg -> (msg -> Maybe a) -> m a 181 | receiveMatch mbox = atomically . receiveMatchSTM mbox 182 | 183 | -- | Like 'receiveMatch' but with a timeout set at @u@ microseconds. Returns 184 | -- 'Nothing' if timeout is reached. 185 | receiveMatchU :: 186 | (MonadUnliftIO m, InChan mbox) 187 | => Int 188 | -> mbox msg 189 | -> (msg -> Maybe a) 190 | -> m (Maybe a) 191 | receiveMatchU u mbox f = timeout u $ receiveMatch mbox f 192 | 193 | -- | Like 'receiveMatch' but with a timeout set at @s@ seconds. Returns 194 | -- 'Nothing' if timeout is reached. 195 | receiveMatchS :: 196 | (MonadUnliftIO m, InChan mbox) 197 | => Int 198 | -> mbox msg 199 | -> (msg -> Maybe a) 200 | -> m (Maybe a) 201 | receiveMatchS s mbox f = timeout (s * 1000 * 1000) $ receiveMatch mbox f 202 | 203 | -- | Match a message in the channel as an atomic 'STM' action. 204 | receiveMatchSTM :: InChan mbox => mbox msg -> (msg -> Maybe a) -> STM a 205 | receiveMatchSTM mbox f = go [] 206 | where 207 | go acc = 208 | receiveSTM mbox >>= \msg -> 209 | case f msg of 210 | Just x -> do 211 | requeueListSTM acc mbox 212 | return x 213 | Nothing -> go (msg : acc) 214 | 215 | -- | Check if the channel is empty. 216 | mailboxEmpty :: (MonadIO m, InChan mbox) => mbox msg -> m Bool 217 | mailboxEmpty = atomically . mailboxEmptySTM 218 | 219 | -- | Put a list of messages at the start of a channel, so that the last element 220 | -- of the list is the next message to be received. 221 | requeueListSTM :: InChan mbox => [msg] -> mbox msg -> STM () 222 | requeueListSTM xs mbox = mapM_ (`requeueSTM` mbox) xs 223 | 224 | -- | Run a process in the background and pass it to a function. Stop the 225 | -- background process once the function returns. Background process exceptions 226 | -- are re-thrown in the current thread. 227 | withProcess :: 228 | MonadUnliftIO m => (Inbox msg -> m ()) -> (Process msg -> m a) -> m a 229 | withProcess p f = do 230 | (i, m) <- newMailbox 231 | withAsync (p i) (\a -> link a >> f (Process a m)) 232 | 233 | -- | Run a process in the background and return the 'Process' handle. Background 234 | -- process exceptions are re-thrown in the current thread. 235 | process :: MonadUnliftIO m => (Inbox msg -> m ()) -> m (Process msg) 236 | process p = do 237 | (i, m) <- newMailbox 238 | a <- async $ p i 239 | link a 240 | return (Process a m) 241 | 242 | -- | Create an unbounded inbox and corresponding mailbox. 243 | newMailbox :: MonadUnliftIO m => m (Inbox msg, Mailbox msg) 244 | newMailbox = do 245 | i <- newInbox 246 | let m = inboxToMailbox i 247 | return (i, m) 248 | --------------------------------------------------------------------------------