----------------------------------------------------------------------------- {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Miso.Concurrent -- Copyright : (C) 2016-2025 David M. Johnson -- License : BSD3-style (see the file LICENSE) -- Maintainer : David M. Johnson <code@dmj.io> -- Stability : experimental -- Portability : non-portable ---------------------------------------------------------------------------- module Miso.Concurrent ( -- * Synchronization primitives Waiter (..) , waiter , Mailbox , Mail , newMailbox , copyMailbox , cloneMailbox , sendMail , readMail ) where ----------------------------------------------------------------------------- import Control.Concurrent import Control.Concurrent.STM import Data.Aeson ----------------------------------------------------------------------------- -- | Synchronization primitive for event loop data Waiter = Waiter { Waiter -> IO () wait :: IO () -- ^ Blocks on MVar , Waiter -> IO () serve :: IO () -- ^ Unblocks threads waiting on MVar } ----------------------------------------------------------------------------- -- | Creates a new 'Waiter' waiter :: IO Waiter waiter :: IO Waiter waiter = do mvar <- IO (MVar ()) forall a. IO (MVar a) newEmptyMVar pure Waiter { wait = takeMVar mvar , serve = do _ <- tryPutMVar mvar () pure () } ----------------------------------------------------------------------------- -- | Type for expressing 'Mail' (or message payloads) put into a 'Mailbox' for delivery type Mail = Value ----------------------------------------------------------------------------- -- | Publish / Subscribe concurrency primitive -- -- A 'Mailbox' is a broadcast 'TChan' that can express the following concurrency patterns -- -- * Broadcast (one-to-all, 1:n) -- * Multicast (one-to-many, 1:n) -- * Unicast (one-to-one, 1:1) -- -- All the above are supported as well in a bidirectional setting. -- -- * Bidirectional (multicast / broadcast / unicast) (n:m) -- -- Practically this pattern resembles cloud notifcation services like -- -- * Amazon SNS -- * Google Pub/Sub -- -- See 'examples/components/Main.hs' for example usage. -- type Mailbox = TChan Mail ----------------------------------------------------------------------------- -- | Constructs a new 'Mailbox' newMailbox :: IO Mailbox newMailbox :: IO Mailbox newMailbox = IO Mailbox forall a. IO (TChan a) newBroadcastTChanIO ----------------------------------------------------------------------------- -- | Duplicates a 'Mailbox', all new 'Mail' is sent to all duplicated 'Mailbox' copyMailbox :: Mailbox -> IO Mailbox copyMailbox :: Mailbox -> IO Mailbox copyMailbox Mailbox mailbox = STM Mailbox -> IO Mailbox forall a. STM a -> IO a atomically (Mailbox -> STM Mailbox forall a. TChan a -> STM (TChan a) dupTChan Mailbox mailbox) ----------------------------------------------------------------------------- -- | Duplicates a 'Mailbox', all new 'Mail' is sent to all cloned 'Mailbox' -- Messages in original 'Mailbox' are retained (unlike `copyMailbox`). cloneMailbox :: Mailbox -> IO Mailbox cloneMailbox :: Mailbox -> IO Mailbox cloneMailbox Mailbox mailbox = STM Mailbox -> IO Mailbox forall a. STM a -> IO a atomically (Mailbox -> STM Mailbox forall a. TChan a -> STM (TChan a) cloneTChan Mailbox mailbox) ----------------------------------------------------------------------------- -- | Sends mail to a mailbox, all duplicated 'Mailbox' receive the same message. sendMail :: Mailbox -> Mail -> IO () sendMail :: Mailbox -> Mail -> IO () sendMail Mailbox mailbox Mail mail = STM () -> IO () forall a. STM a -> IO a atomically (Mailbox -> Mail -> STM () forall a. TChan a -> a -> STM () writeTChan Mailbox mailbox Mail mail) ----------------------------------------------------------------------------- -- | Reads mail from a 'Mailbox'. This only works on a duplicated 'Mailbox'. -- So call this function only on 'Mailbox' that have been created from 'copyMailbox'. readMail :: Mailbox -> IO Mail readMail :: Mailbox -> IO Mail readMail Mailbox mailbox = STM Mail -> IO Mail forall a. STM a -> IO a atomically (Mailbox -> STM Mail forall a. TChan a -> STM a readTChan Mailbox mailbox) -----------------------------------------------------------------------------