1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
{- notification broadcaster
-
- This is used to allow clients to block until there is a new notification
- that some thing occurred. It does not communicate what the change is,
- it only provides blocking reads to wait on notifications.
-
- Multiple clients are supported. Each has a unique id.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.NotificationBroadcaster (
NotificationBroadcaster,
NotificationHandle,
newNotificationBroadcaster,
newNotificationHandle,
notificationHandleToId,
notificationHandleFromId,
sendNotification,
waitNotification,
) where
import Common
import Control.Concurrent.STM
import Control.Concurrent.SampleVar
{- One SampleVar per client. The TMVar is never empty, so never blocks. -}
type NotificationBroadcaster = TMVar [SampleVar ()]
{- Handle given out to an individual client. -}
data NotificationHandle = NotificationHandle NotificationBroadcaster Int
newNotificationBroadcaster :: IO NotificationBroadcaster
newNotificationBroadcaster = atomically (newTMVar [])
{- Allocates a notification handle for a client to use. -}
newNotificationHandle :: NotificationBroadcaster -> IO NotificationHandle
newNotificationHandle b = NotificationHandle
<$> pure b
<*> addclient
where
addclient = do
s <- newEmptySampleVar
atomically $ do
l <- readTMVar b
putTMVar b $ l ++ [s]
return $ length l
{- Extracts the Int identifier from a notification handle.
- This can be used to eg, pass the identifier through to a WebApp. -}
notificationHandleToId :: NotificationHandle -> Int
notificationHandleToId (NotificationHandle _ i) = i
{- Given a NotificationBroadcaster, and an Int identifier, recreates the
- NotificationHandle. -}
notificationHandleFromId :: NotificationBroadcaster -> Int -> NotificationHandle
notificationHandleFromId = NotificationHandle
{- Sends a notification to all clients. -}
sendNotification :: NotificationBroadcaster -> IO ()
sendNotification b = do
l <- atomically $ readTMVar b
mapM_ notify l
where
notify s = writeSampleVar s ()
{- Used by a client to block until a new notification is available since
- the last time it tried. -}
waitNotification :: NotificationHandle -> IO ()
waitNotification (NotificationHandle b i) = do
l <- atomically $ readTMVar b
readSampleVar (l !! i)
|
