git.iko.soy/typeable/wai
on master help sign in
Add 'wai-eventsource/' from commit 'f3c7ee74514c584a8f9006db10220476e7033978'
86f0d98Greg Weber
wai-eventsource/eventsource-wai.cabalnew file+34
compare with master
unifiedsplit
@@ -0,0 +1,34 @@
1+Name: eventsource-wai
2+Version: 0.1
3+Synopsis: Project Synopsis Here
4+Description: Project Description Here
5+License: AllRightsReserved
6+Author: Author
7+Maintainer: maintainer@example.com
8+Stability: Experimental
9+Category: Web
10+Build-type: Simple
11+Cabal-version: >=1.2
12+
13+Executable eventsource-wai
14+ hs-source-dirs: src
15+ main-is: Main.hs
16+
17+ Build-depends:
18+ base >= 4.3 && < 5,
19+ bytestring >= 0.9.1 && < 0.10,
20+ blaze-builder >= 0.3,
21+ MonadCatchIO-transformers >= 0.2.1 && < 0.3,
22+ mtl >= 2 && < 3,
23+ http-types >= 0.6,
24+ enumerator >= 0.4,
25+ time >= 1.2,
26+ wai >= 0.4,
27+ warp >= 0.4
28+
29+ if impl(ghc >= 6.12.0)
30+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
31+ -fno-warn-unused-do-bind
32+ else
33+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
34+
wai-eventsource/src/EventStream.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+{-|
4+ A Snap adapter to the HTML5 Server-Sent Events API. Push-mode and
5+ pull-mode interfaces are both available.
6+-}
7+module EventStream (
8+ ServerEvent(..),
9+ eventToBuilder
10+ ) where
11+
12+import Blaze.ByteString.Builder
13+import Blaze.ByteString.Builder.Char8
14+import Control.Monad.Trans
15+import Control.Concurrent
16+import Data.Monoid
17+import Data.Enumerator hiding (map)
18+import Data.Enumerator.List (generateM)
19+
20+{-|
21+ Type representing a communication over an event stream. This can be an
22+ actual event, a comment, a modification to the retry timer, or a special
23+ "close" event indicating the server should close the connection.
24+-}
25+data ServerEvent
26+ = ServerEvent {
27+ eventName :: Maybe Builder,
28+ eventId :: Maybe Builder,
29+ eventData :: [Builder]
30+ }
31+ | CommentEvent {
32+ eventComment :: Builder
33+ }
34+ | RetryEvent {
35+ eventRetry :: Int
36+ }
37+ | CloseEvent
38+
39+
40+{-|
41+ Newline as a Builder.
42+-}
43+nl = fromChar '\n'
44+
45+
46+{-|
47+ Field names as Builder
48+-}
49+nameField = fromString "event:"
50+idField = fromString "id:"
51+dataField = fromString "data:"
52+retryField = fromString "retry:"
53+commentField = fromChar ':'
54+
55+
56+{-|
57+ Wraps the text as a labeled field of an event stream.
58+-}
59+field l b = l `mappend` b `mappend` nl
60+
61+
62+{-|
63+ Appends a buffer flush to the end of a Builder.
64+-}
65+flushAfter b = b `mappend` flush
66+
67+
68+{-|
69+ Converts a 'ServerEvent' to its wire representation as specified by the
70+ @text/event-stream@ content type.
71+-}
72+eventToBuilder :: ServerEvent -> Maybe Builder
73+eventToBuilder (CommentEvent txt) = Just $ flushAfter $ field commentField txt
74+eventToBuilder (RetryEvent n) = Just $ flushAfter $ field retryField (fromShow n)
75+eventToBuilder (CloseEvent) = Nothing
76+eventToBuilder (ServerEvent n i d)= Just $ flushAfter $
77+ (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl
78+ where
79+ name Nothing = id
80+ name (Just n) = mappend (field nameField n)
81+ evid Nothing = id
82+ evid (Just i) = mappend (field idField i)
wai-eventsource/src/Main.hsnew file+52
@@ -0,0 +1,52 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Main where
3+
4+import Control.Monad
5+import Control.Monad.Trans
6+import Control.Concurrent (forkIO, threadDelay)
7+import Control.Concurrent.Chan
8+import Network.Wai.Handler.Warp (run)
9+import Network.Wai
10+import Network.HTTP.Types (statusOK)
11+import Data.Enumerator (Iteratee, Step(Continue), Stream(Chunks,EOF), returnI, run_, (>>==), ($$), generateM)
12+import Data.Time.Clock.POSIX
13+import Data.ByteString (ByteString)
14+import qualified Data.ByteString as B
15+import Blaze.ByteString.Builder (fromByteString)
16+import Blaze.ByteString.Builder.Char.Utf8 (fromString)
17+
18+import EventStream
19+
20+
21+app :: Chan ServerEvent -> Application
22+app chan req =
23+ case pathInfo req of
24+ [] -> return $ ResponseFile statusOK [("Content-Type", "text/html")] "static/index.html" Nothing
25+ ["es"] -> do
26+ chan' <- liftIO $ dupChan chan
27+ return $ res chan'
28+
29+
30+res :: Chan ServerEvent -> Response
31+res chan = ResponseEnumerator (resE chan)
32+
33+
34+resE :: Chan ServerEvent -> ResponseEnumerator a
35+resE chan genIter =
36+ run_ $ generateM (fmap eventToBuilder $ readChan chan) $$ iter
37+ where
38+ iter = genIter statusOK [("Content-Type", "text/event-stream")]
39+
40+
41+source :: Chan ServerEvent -> IO ()
42+source chan = forever $ do
43+ threadDelay 1000000
44+ time <- getPOSIXTime
45+ writeChan chan (ServerEvent Nothing Nothing [fromString . show $ time])
46+
47+
48+main :: IO ()
49+main = do
50+ chan <- newChan
51+ forkIO . source $ chan
52+ run 8000 (app chan)
wai-eventsource/static/index.htmlnew file+19
@@ -0,0 +1,19 @@
1+<!doctype html>
2+<head>
3+ <title>Hello</title>
4+</head>
5+<h1>Testing</h1>
6+
7+<div id="output"></div>
8+
9+<script>
10+ var output = document.getElementById("output");
11+
12+ var src = new EventSource("/es");
13+
14+ src.onmessage = function(msg) {
15+ var p = document.createElement("p");
16+ p.appendChild(document.createTextNode(msg.data));
17+ output.appendChild(p);
18+ }
19+</script>