2017-11-27 00:43:43 +00:00
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
2017-12-15 16:48:12 +00:00
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
2017-12-20 01:00:48 +00:00
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2017-12-13 03:37:16 +00:00
|
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
2017-12-20 01:00:48 +00:00
|
|
|
{-# LANGUAGE ExistentialQuantification #-}
|
2017-12-13 03:37:16 +00:00
|
|
|
module Affection.MessageBus.Class
|
|
|
|
( Participant(..)
|
|
|
|
, genUUID
|
|
|
|
, UUID
|
2017-12-27 16:33:31 +00:00
|
|
|
-- , MsgId(..)
|
2017-12-13 03:37:16 +00:00
|
|
|
) where
|
2017-11-26 21:26:41 +00:00
|
|
|
|
|
|
|
import Affection.MessageBus.Message
|
2017-11-27 22:30:11 +00:00
|
|
|
import Affection.Types
|
2017-11-26 21:26:41 +00:00
|
|
|
|
2017-12-13 03:37:16 +00:00
|
|
|
import Control.Monad.IO.Class (liftIO)
|
2017-11-26 21:26:41 +00:00
|
|
|
|
2017-12-13 03:37:16 +00:00
|
|
|
import Data.UUID
|
|
|
|
import Data.UUID.V4
|
2017-11-26 21:26:41 +00:00
|
|
|
|
2017-12-13 03:37:16 +00:00
|
|
|
import Affection.Logging
|
2017-11-26 21:26:41 +00:00
|
|
|
|
2017-12-27 16:33:31 +00:00
|
|
|
class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where
|
|
|
|
type Mesg prt us :: *
|
2017-12-15 16:48:12 +00:00
|
|
|
|
|
|
|
-- | Function to get the list of subscribers from the participant
|
2017-12-13 03:37:16 +00:00
|
|
|
partSubscribers
|
2017-12-15 16:48:12 +00:00
|
|
|
:: prt
|
|
|
|
-- ^ the 'Participant''s subscriber storage
|
2017-12-27 16:33:31 +00:00
|
|
|
-> Affection us [Mesg prt us -> Affection us ()]
|
2017-12-15 16:48:12 +00:00
|
|
|
-- ^ List of Subscriber functions
|
2017-12-13 03:37:16 +00:00
|
|
|
|
|
|
|
-- | Subscribe to the 'Participant''s events
|
|
|
|
partSubscribe
|
2017-12-15 16:48:12 +00:00
|
|
|
:: prt
|
|
|
|
-- ^ The 'Participant''s subscriber storage
|
2017-12-27 16:33:31 +00:00
|
|
|
-> (Mesg prt us -> Affection us ())
|
2017-12-15 16:48:12 +00:00
|
|
|
-- ^ What to do in case of a 'Message'
|
|
|
|
-- (Subscriber function)
|
2017-12-27 16:33:31 +00:00
|
|
|
-> Affection us UUID
|
2017-12-15 16:48:12 +00:00
|
|
|
-- ^ 'UUID' of the registered subscriber Function
|
2017-12-13 03:37:16 +00:00
|
|
|
|
|
|
|
-- | Unsubscribe a Subscriber function from Participant
|
|
|
|
partUnSubscribe
|
2017-12-15 16:48:12 +00:00
|
|
|
:: prt
|
|
|
|
-- ^ The 'Participant''s subscriber storage to unsubscribe from
|
2017-12-27 16:33:31 +00:00
|
|
|
-> UUID
|
2017-12-15 16:48:12 +00:00
|
|
|
-- ^ The subscriber function's 'UUID'
|
2017-12-13 14:53:51 +00:00
|
|
|
-> Affection us ()
|
2017-12-13 03:37:16 +00:00
|
|
|
|
|
|
|
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers
|
2017-12-12 12:12:27 +00:00
|
|
|
partEmit
|
2017-12-15 16:48:12 +00:00
|
|
|
:: prt
|
|
|
|
-- ^ The 'Participant''s subscriber storage
|
2017-12-27 16:33:31 +00:00
|
|
|
-> Mesg prt us
|
2017-12-15 16:48:12 +00:00
|
|
|
-- ^ The 'Message' to emit
|
2017-12-13 14:53:51 +00:00
|
|
|
-> Affection us ()
|
2017-12-13 03:37:16 +00:00
|
|
|
partEmit p m = do
|
2017-12-22 05:28:58 +00:00
|
|
|
liftIO $ logIO Verbose $ "Emitting message: " ++ show m
|
2017-12-13 03:37:16 +00:00
|
|
|
l <- partSubscribers p
|
|
|
|
mapM_ ($ m) l
|
2017-12-12 12:12:27 +00:00
|
|
|
|
2017-12-15 16:48:12 +00:00
|
|
|
-- | Helper function to generate new 'UUID's
|
2017-12-13 14:53:51 +00:00
|
|
|
genUUID :: Affection us UUID
|
2017-12-15 17:12:16 +00:00
|
|
|
genUUID = liftIO nextRandom
|