Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 126 lines (104 sloc) 3.273 kB
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
1 {-# LANGUAGE OverloadedStrings #-}
2
3 {-|
4 A Snap adapter to the HTML5 Server-Sent Events API. Push-mode and
5 pull-mode interfaces are both available.
6 -}
7 module EventStream (
8 ServerEvent(..),
9 eventStreamPull,
9a0c13c @cdsmith Oops, fix build
authored
10 eventStreamPush
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
11 ) where
12
13 import Blaze.ByteString.Builder
4b7b8f9 Miscellaneous updates
Chris Smith authored
14 import Blaze.ByteString.Builder.ByteString
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
15 import Blaze.ByteString.Builder.Char8
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
16 import Control.Monad.Trans
17 import Control.Concurrent
4b7b8f9 Miscellaneous updates
Chris Smith authored
18 import Data.IORef
9ad5027 @cdsmith Fix buffering for animations
authored
19 import Data.Monoid
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
20 import Data.Enumerator.List (generateM)
21 import Snap.Types
22
4b7b8f9 Miscellaneous updates
Chris Smith authored
23 import qualified Data.ByteString.Char8 as BC
24
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
25 {-|
26 Type representing a communication over an event stream. This can be an
27 actual event, a comment, a modification to the retry timer, or a special
28 "close" event indicating the server should close the connection.
29 -}
30 data ServerEvent
31 = ServerEvent {
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
32 eventName :: Maybe Builder,
33 eventId :: Maybe Builder,
34 eventData :: [Builder]
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
35 }
36 | CommentEvent {
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
37 eventComment :: Builder
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
38 }
39 | RetryEvent {
40 eventRetry :: Int
41 }
42 | CloseEvent
43
44
45 {-|
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
46 Newline as a Builder.
fcb46c3 @cdsmith Rely on builder more to try to improve performance
authored
47 -}
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
48 nl = fromChar '\n'
fcb46c3 @cdsmith Rely on builder more to try to improve performance
authored
49
50
51 {-|
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
52 Field names as Builder
fcb46c3 @cdsmith Rely on builder more to try to improve performance
authored
53 -}
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
54 nameField = fromString "event:"
55 idField = fromString "id:"
56 dataField = fromString "data:"
57 retryField = fromString "retry:"
58 commentField = fromChar ':'
fcb46c3 @cdsmith Rely on builder more to try to improve performance
authored
59
60
61 {-|
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
62 Wraps the text as a labeled field of an event stream.
63 -}
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
64 field l b = l `mappend` b `mappend` nl
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
65
66
67 {-|
9ad5027 @cdsmith Fix buffering for animations
authored
68 Appends a buffer flush to the end of a Builder.
69 -}
70 flushAfter b = b `mappend` flush
71
72
73 {-|
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
74 Converts a 'ServerEvent' to its wire representation as specified by the
75 @text/event-stream@ content type.
76 -}
77 eventToBuilder :: ServerEvent -> Maybe Builder
5fa21ac @cdsmith formatting changes
authored
78 eventToBuilder (CommentEvent txt) = Just $ flushAfter $ field commentField txt
79 eventToBuilder (RetryEvent n) = Just $ flushAfter $ field retryField (fromShow n)
80 eventToBuilder (CloseEvent) = Nothing
2812d6c @cdsmith Oops, fix build
authored
81 eventToBuilder (ServerEvent n i d)= Just $ flushAfter $
82 (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
83 where
84 name Nothing = id
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
85 name (Just n) = mappend (field nameField n)
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
86 evid Nothing = id
9f6fe91 @cdsmith Use Builder from aeson directly instead of converting to/from Text
authored
87 evid (Just i) = mappend (field idField i)
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
88
89
4b7b8f9 Miscellaneous updates
Chris Smith authored
90 ieWrap :: IO ServerEvent -> IO (IO ServerEvent)
91 ieWrap src = do
92 v <- newIORef False
93 return $ do
94 i <- readIORef v
95 writeIORef v True
96 if i then src else return pad
97 where
98 pad = CommentEvent $ fromByteString $ BC.replicate 2049 ' '
99
100
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
101 {-|
102 Sets up this request to act as an event stream, obtaining its events from
103 polling the given IO action.
104 -}
13afa44 @cdsmith Reduce EventStream timeout to handle infinite-looping clients better
authored
105 eventStreamPull :: IO ServerEvent -> Snap ()
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
106 eventStreamPull source = do
107 modifyResponse (setContentType "text/event-stream")
aea79b8 Add parameters to make EventStream perhaps work in more places.
Chris Smith authored
108 modifyResponse (addHeader "Cache-Control" "no-cache")
109 modifyResponse (addHeader "Access-Control-Allow-Origin" "*")
4b7b8f9 Miscellaneous updates
Chris Smith authored
110 timeout <- getTimeoutAction
111 trueSource <- liftIO $ ieWrap source
9ad5027 @cdsmith Fix buffering for animations
authored
112 modifyResponse $ setResponseBody $
4b7b8f9 Miscellaneous updates
Chris Smith authored
113 generateM (timeout 3600 >> fmap eventToBuilder trueSource)
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
114
115
116 {-|
117 Sets up this request to act as an event stream, returning an action to send
2fff1c7 @cdsmith Remove broken "unreliable" push model. It doesn't look like there's …
authored
118 events along the stream.
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
119 -}
13afa44 @cdsmith Reduce EventStream timeout to handle infinite-looping clients better
authored
120 eventStreamPush :: Snap (ServerEvent -> IO ())
2fff1c7 @cdsmith Remove broken "unreliable" push model. It doesn't look like there's …
authored
121 eventStreamPush = do
16dca4e @cdsmith First cut at animation (works, but VERY slow)
authored
122 chan <- liftIO newChan
123 eventStreamPull (readChan chan)
124 return (writeChan chan)
125
Something went wrong with that request. Please try again.