/src/EventStream.hs

http://github.com/biilmann/eventsource-broker · Haskell · 185 lines · 83 code · 25 blank · 77 comment · 2 complexity · 8be868eec01720c2e7421ed502a36f78 MD5 · raw file

  1. {-# LANGUAGE OverloadedStrings #-}
  2. {-
  3. Based on https://github.com/cdsmith/gloss-web
  4. Copyright (c)2011, Chris Smith <cdsmith@gmail.com>
  5. All rights reserved.
  6. Redistribution and use in source and binary forms, with or without
  7. modification, are permitted provided that the following conditions are met:
  8. * Redistributions of source code must retain the above copyright
  9. notice, this list of conditions and the following disclaimer.
  10. * Redistributions in binary form must reproduce the above
  11. copyright notice, this list of conditions and the following
  12. disclaimer in the documentation and/or other materials provided
  13. with the distribution.
  14. * Neither the name of Chris Smith <cdsmith@gmail.com> nor the names of other
  15. contributors may be used to endorse or promote products derived
  16. from this software without specific prior written permission.
  17. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  18. "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  19. LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  20. A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  21. OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  22. SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  23. LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  24. DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  25. THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  26. (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  27. OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28. -}
  29. {-|
  30. A Snap adapter to the HTML5 Server-Sent Events API. Push-mode and
  31. pull-mode interfaces are both available.
  32. -}
  33. module EventStream (
  34. ServerEvent(..),
  35. eventSourceStream,
  36. eventSourceResponse
  37. ) where
  38. import Blaze.ByteString.Builder
  39. import Blaze.ByteString.Builder.Char8
  40. import Control.Monad.Trans
  41. import Control.Concurrent
  42. import Control.Exception (onException)
  43. import Data.Monoid
  44. import Data.Enumerator (Step(..), Stream(..), (>>==), returnI)
  45. -- import Data.Enumerator.List (generateM)
  46. import Snap.Types
  47. import System.Timeout
  48. {-|
  49. Type representing a communication over an event stream. This can be an
  50. actual event, a comment, a modification to the retry timer, or a special
  51. "close" event indicating the server should close the connection.
  52. -}
  53. data ServerEvent
  54. = ServerEvent {
  55. eventName :: Maybe Builder,
  56. eventId :: Maybe Builder,
  57. eventData :: [Builder]
  58. }
  59. | CommentEvent {
  60. eventComment :: Builder
  61. }
  62. | RetryEvent {
  63. eventRetry :: Int
  64. }
  65. | CloseEvent
  66. {-|
  67. Newline as a Builder.
  68. -}
  69. nl = fromChar '\n'
  70. {-|
  71. Field names as Builder
  72. -}
  73. nameField = fromString "event:"
  74. idField = fromString "id:"
  75. dataField = fromString "data:"
  76. retryField = fromString "retry:"
  77. commentField = fromChar ':'
  78. {-|
  79. Wraps the text as a labeled field of an event stream.
  80. -}
  81. field l b = l `mappend` b `mappend` nl
  82. {-|
  83. Appends a buffer flush to the end of a Builder.
  84. -}
  85. flushAfter b = b `mappend` flush
  86. {-|
  87. Send a comment with the string "ping" to the client.
  88. -}
  89. pingEvent = flushAfter $ field commentField (fromString "ping")
  90. {-|
  91. Converts a 'ServerEvent' to its wire representation as specified by the
  92. @text/event-stream@ content type.
  93. -}
  94. eventSourceBuilder :: ServerEvent -> Maybe Builder
  95. eventSourceBuilder (CommentEvent txt) = Just $ flushAfter $ field commentField txt
  96. eventSourceBuilder (RetryEvent n) = Just $ flushAfter $ field retryField (fromShow n)
  97. eventSourceBuilder (CloseEvent) = Nothing
  98. eventSourceBuilder (ServerEvent n i d)= Just $ flushAfter $
  99. (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl
  100. where
  101. name Nothing = id
  102. name (Just n) = mappend (field nameField n)
  103. evid Nothing = id
  104. evid (Just i) = mappend (field idField i)
  105. eventSourceEnum source builder timeoutAction finalizer = withInitialPing
  106. where
  107. withInitialPing (Continue k) = k (Chunks [pingEvent]) >>== go
  108. go (Continue k) = do
  109. liftIO $ timeoutAction 10
  110. event <- liftIO $ timeout 9000000 source
  111. case fmap builder event of
  112. Just (Just b) -> k (Chunks [b]) >>== go
  113. Just Nothing -> k EOF
  114. Nothing -> do
  115. k (Chunks [pingEvent]) >>== go
  116. go step = do
  117. liftIO finalizer
  118. returnI step
  119. {-|
  120. Send a stream of events to the client. Takes a function to convert an
  121. event to a builder. If that function returns Nothing the stream is closed.
  122. -}
  123. eventStream :: IO ServerEvent -> (ServerEvent -> Maybe Builder) -> IO () -> Snap ()
  124. eventStream source builder finalizer = do
  125. timeoutAction <- getTimeoutAction
  126. modifyResponse $ setResponseBody $
  127. eventSourceEnum source builder timeoutAction finalizer
  128. {-|
  129. Return a single response when the source returns an event. Takes a function
  130. used to convert the event to a builder.
  131. -}
  132. eventResponse :: IO ServerEvent -> (ServerEvent -> Maybe Builder) -> IO () -> Snap ()
  133. eventResponse source builder finalizer = do
  134. event <- liftIO $ source `onException` finalizer
  135. case builder event of
  136. Just b -> writeBuilder b
  137. Nothing -> do
  138. liftIO finalizer
  139. response <- getResponse
  140. finishWith response
  141. {-|
  142. Sets up this request to act as an event stream, obtaining its events from
  143. polling the given IO action.
  144. -}
  145. eventSourceStream source finalizer = do
  146. modifyResponse $ setContentType "text/event-stream"
  147. . setHeader "Cache-Control" "no-cache"
  148. eventStream source eventSourceBuilder finalizer
  149. -- |Long polling fallback - sends a single response when an event is pulled
  150. eventSourceResponse source finalizer = do
  151. modifyResponse $ setContentType "text/event-stream"
  152. . setHeader "Cache-Control" "no-cache"
  153. eventResponse source eventSourceBuilder finalizer