75 lines
2.2 KiB
Haskell
75 lines
2.2 KiB
Haskell
{-# LANGUAGE ExistentialQuantification #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
module Network.IRC.MessageBus
|
|
( MessageBus
|
|
, newMessageBus
|
|
, MessageChannel
|
|
, newMessageChannel
|
|
, sendMessage
|
|
, receiveMessage
|
|
, receiveMessageEither
|
|
, closeMessageChannel
|
|
, awaitMessageChannel
|
|
, isClosedMessageChannel ) where
|
|
|
|
import ClassyPrelude
|
|
|
|
newtype Latch = Latch (MVar ())
|
|
|
|
newLatch :: IO Latch
|
|
newLatch = liftM Latch newEmptyMVar
|
|
|
|
doLatch :: Latch -> IO ()
|
|
doLatch (Latch mv) = putMVar mv ()
|
|
|
|
awaitLatch :: Latch -> IO ()
|
|
awaitLatch (Latch mv) = void $ takeMVar mv
|
|
|
|
latched :: Latch -> IO Bool
|
|
latched (Latch mv) = map isJust . tryReadMVar $ mv
|
|
|
|
newtype MessageBus a = MessageBus (TChan a)
|
|
|
|
newMessageBus :: IO (MessageBus a)
|
|
newMessageBus = MessageBus <$> newBroadcastTChanIO
|
|
|
|
-- | A channel through which messages are sent and received.
|
|
data MessageChannel a = MessageChannel Latch (TChan a) (TChan a)
|
|
|
|
newMessageChannel ::MessageBus a -> IO (MessageChannel a)
|
|
newMessageChannel (MessageBus wChan) = do
|
|
latch <- newLatch
|
|
rChan <- atomically $ dupTChan wChan
|
|
return $ MessageChannel latch rChan wChan
|
|
|
|
sendMessageSTM :: MessageChannel a -> a -> STM ()
|
|
sendMessageSTM (MessageChannel _ _ wChan) = writeTChan wChan
|
|
|
|
receiveMessageSTM :: MessageChannel a -> STM a
|
|
receiveMessageSTM (MessageChannel _ rChan _) = readTChan rChan
|
|
|
|
-- | Sends a message through a message channel.
|
|
sendMessage :: MessageChannel a -- ^ The channel
|
|
-> a -- ^ The message to send
|
|
-> IO ()
|
|
sendMessage chan = atomically . sendMessageSTM chan
|
|
|
|
receiveMessage :: MessageChannel a -> IO a
|
|
receiveMessage = atomically . receiveMessageSTM
|
|
|
|
closeMessageChannel :: MessageChannel a -> IO ()
|
|
closeMessageChannel (MessageChannel latch _ _) = doLatch latch
|
|
|
|
awaitMessageChannel :: MessageChannel a -> IO ()
|
|
awaitMessageChannel (MessageChannel latch _ _) = awaitLatch latch
|
|
|
|
isClosedMessageChannel :: MessageChannel a -> IO Bool
|
|
isClosedMessageChannel (MessageChannel latch _ _) = latched latch
|
|
|
|
receiveMessageEither :: MessageChannel a -> MessageChannel b -> IO (Either a b)
|
|
receiveMessageEither chan1 chan2 = atomically $
|
|
map Left (receiveMessageSTM chan1) `orElseSTM` map Right (receiveMessageSTM chan2)
|