Skip to content
This repository
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 126 lines (104 sloc) 3.273 kb
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 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
{-# LANGUAGE OverloadedStrings #-}

{-|
A Snap adapter to the HTML5 Server-Sent Events API. Push-mode and
pull-mode interfaces are both available.
-}
module EventStream (
    ServerEvent(..),
    eventStreamPull,
    eventStreamPush
    ) where

import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.ByteString
import Blaze.ByteString.Builder.Char8
import Control.Monad.Trans
import Control.Concurrent
import Data.IORef
import Data.Monoid
import Data.Enumerator.List (generateM)
import Snap.Types

import qualified Data.ByteString.Char8 as BC

{-|
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


{-|
Converts a 'ServerEvent' to its wire representation as specified by the
@text/event-stream@ content type.
-}
eventToBuilder :: ServerEvent -> Maybe Builder
eventToBuilder (CommentEvent txt) = Just $ flushAfter $ field commentField txt
eventToBuilder (RetryEvent n) = Just $ flushAfter $ field retryField (fromShow n)
eventToBuilder (CloseEvent) = Nothing
eventToBuilder (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)


ieWrap :: IO ServerEvent -> IO (IO ServerEvent)
ieWrap src = do
    v <- newIORef False
    return $ do
        i <- readIORef v
        writeIORef v True
        if i then src else return pad
  where
    pad = CommentEvent $ fromByteString $ BC.replicate 2049 ' '


{-|
Sets up this request to act as an event stream, obtaining its events from
polling the given IO action.
-}
eventStreamPull :: IO ServerEvent -> Snap ()
eventStreamPull source = do
    modifyResponse (setContentType "text/event-stream")
    modifyResponse (addHeader "Cache-Control" "no-cache")
    modifyResponse (addHeader "Access-Control-Allow-Origin" "*")
    timeout <- getTimeoutAction
    trueSource <- liftIO $ ieWrap source
    modifyResponse $ setResponseBody $
        generateM (timeout 3600 >> fmap eventToBuilder trueSource)


{-|
Sets up this request to act as an event stream, returning an action to send
events along the stream.
-}
eventStreamPush :: Snap (ServerEvent -> IO ())
eventStreamPush = do
    chan <- liftIO newChan
    eventStreamPull (readChan chan)
    return (writeChan chan)

Something went wrong with that request. Please try again.