/src/EventStream.hs
http://github.com/biilmann/eventsource-broker · Haskell · 185 lines · 83 code · 25 blank · 77 comment · 2 complexity · 8be868eec01720c2e7421ed502a36f78 MD5 · raw file
- {-# LANGUAGE OverloadedStrings #-}
- {-
- Based on https://github.com/cdsmith/gloss-web
- Copyright (c)2011, Chris Smith <cdsmith@gmail.com>
- All rights reserved.
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions are met:
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
- * Neither the name of Chris Smith <cdsmith@gmail.com> nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- -}
- {-|
- A Snap adapter to the HTML5 Server-Sent Events API. Push-mode and
- pull-mode interfaces are both available.
- -}
- module EventStream (
- ServerEvent(..),
- eventSourceStream,
- eventSourceResponse
- ) where
- import Blaze.ByteString.Builder
- import Blaze.ByteString.Builder.Char8
- import Control.Monad.Trans
- import Control.Concurrent
- import Control.Exception (onException)
- import Data.Monoid
- import Data.Enumerator (Step(..), Stream(..), (>>==), returnI)
- -- import Data.Enumerator.List (generateM)
- import Snap.Types
- import System.Timeout
- {-|
- Type representing a communication over an event stream. This can be an
- actual event, a comment, a modification to the retry timer, or a special
- "close" event indicating the server should close the connection.
- -}
- data ServerEvent
- = ServerEvent {
- eventName :: Maybe Builder,
- eventId :: Maybe Builder,
- eventData :: [Builder]
- }
- | CommentEvent {
- eventComment :: Builder
- }
- | RetryEvent {
- eventRetry :: Int
- }
- | CloseEvent
- {-|
- Newline as a Builder.
- -}
- nl = fromChar '\n'
- {-|
- Field names as Builder
- -}
- nameField = fromString "event:"
- idField = fromString "id:"
- dataField = fromString "data:"
- retryField = fromString "retry:"
- commentField = fromChar ':'
- {-|
- Wraps the text as a labeled field of an event stream.
- -}
- field l b = l `mappend` b `mappend` nl
- {-|
- Appends a buffer flush to the end of a Builder.
- -}
- flushAfter b = b `mappend` flush
- {-|
- Send a comment with the string "ping" to the client.
- -}
- pingEvent = flushAfter $ field commentField (fromString "ping")
- {-|
- Converts a 'ServerEvent' to its wire representation as specified by the
- @text/event-stream@ content type.
- -}
- eventSourceBuilder :: ServerEvent -> Maybe Builder
- eventSourceBuilder (CommentEvent txt) = Just $ flushAfter $ field commentField txt
- eventSourceBuilder (RetryEvent n) = Just $ flushAfter $ field retryField (fromShow n)
- eventSourceBuilder (CloseEvent) = Nothing
- eventSourceBuilder (ServerEvent n i d)= Just $ flushAfter $
- (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl
- where
- name Nothing = id
- name (Just n) = mappend (field nameField n)
- evid Nothing = id
- evid (Just i) = mappend (field idField i)
- eventSourceEnum source builder timeoutAction finalizer = withInitialPing
- where
- withInitialPing (Continue k) = k (Chunks [pingEvent]) >>== go
- go (Continue k) = do
- liftIO $ timeoutAction 10
- event <- liftIO $ timeout 9000000 source
- case fmap builder event of
- Just (Just b) -> k (Chunks [b]) >>== go
- Just Nothing -> k EOF
- Nothing -> do
- k (Chunks [pingEvent]) >>== go
- go step = do
- liftIO finalizer
- returnI step
- {-|
- Send a stream of events to the client. Takes a function to convert an
- event to a builder. If that function returns Nothing the stream is closed.
- -}
- eventStream :: IO ServerEvent -> (ServerEvent -> Maybe Builder) -> IO () -> Snap ()
- eventStream source builder finalizer = do
- timeoutAction <- getTimeoutAction
- modifyResponse $ setResponseBody $
- eventSourceEnum source builder timeoutAction finalizer
- {-|
- Return a single response when the source returns an event. Takes a function
- used to convert the event to a builder.
- -}
- eventResponse :: IO ServerEvent -> (ServerEvent -> Maybe Builder) -> IO () -> Snap ()
- eventResponse source builder finalizer = do
- event <- liftIO $ source `onException` finalizer
- case builder event of
- Just b -> writeBuilder b
- Nothing -> do
- liftIO finalizer
- response <- getResponse
- finishWith response
- {-|
- Sets up this request to act as an event stream, obtaining its events from
- polling the given IO action.
- -}
- eventSourceStream source finalizer = do
- modifyResponse $ setContentType "text/event-stream"
- . setHeader "Cache-Control" "no-cache"
- eventStream source eventSourceBuilder finalizer
- -- |Long polling fallback - sends a single response when an event is pulled
- eventSourceResponse source finalizer = do
- modifyResponse $ setContentType "text/event-stream"
- . setHeader "Cache-Control" "no-cache"
- eventResponse source eventSourceBuilder finalizer