← Back to branch summary

~ubuntu-branches/ubuntu/utopic/haskell-wai-extra/utopic-proposed

« back to all changes in this revision

Viewing changes to Network/Wai/EventSource.hs

  • Committer: Package Import Robot
  • Author(s): Clint Adams
  • Date: 2014-06-06 11:40:45 UTC
  • mfrom: (15.1.1 sid)
  • Revision ID: package-import@ubuntu.com-20140606114045-cc7h7xuui844a1l0
Tags: 3.0.0-1
New upstream version.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/EventSource.hs
 
1
{-# LANGUAGE OverloadedStrings #-}
 
2
{-|
 
3
    A WAI adapter to the HTML5 Server-Sent Events API.
 
4
-}
 
5
module Network.Wai.EventSource (
 
6
    ServerEvent(..),
 
7
    eventSourceAppChan,
 
8
    eventSourceAppIO
 
9
    ) where
 
10
 
 
11
import           Blaze.ByteString.Builder (Builder)
 
12
import           Data.Function (fix)
 
13
import           Control.Concurrent.Chan (Chan, dupChan, readChan)
 
14
import           Control.Monad.IO.Class (liftIO)
 
15
import           Network.HTTP.Types (status200)
 
16
import           Network.Wai (Application, Response, responseStream)
 
17
 
 
18
import Network.Wai.EventSource.EventStream
 
19
 
 
20
-- | Make a new WAI EventSource application reading events from
 
21
-- the given channel.
 
22
eventSourceAppChan :: Chan ServerEvent -> Application
 
23
eventSourceAppChan chan req sendResponse = do
 
24
    chan' <- liftIO $ dupChan chan
 
25
    eventSourceAppIO (readChan chan') req sendResponse
 
26
 
 
27
-- | Make a new WAI EventSource application reading events from
 
28
-- the given IO action.
 
29
eventSourceAppIO :: IO ServerEvent -> Application
 
30
eventSourceAppIO src _ sendResponse =
 
31
    sendResponse $ responseStream
 
32
        status200
 
33
        [("Content-Type", "text/event-stream")]
 
34
        $ \sendChunk flush -> fix $ \loop -> do
 
35
            se <- src
 
36
            case eventToBuilder se of
 
37
                Nothing -> return ()
 
38
                Just b  -> sendChunk b >> flush >> loop