-----------------------------------------------------------------------------
{-# 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)
-----------------------------------------------------------------------------