/src/EventStream.hs

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