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
|
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.Chan
import Control.Monad (forever)
import Data.ByteString.Builder (string8)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Network.HTTP.Types (status200)
import Network.Wai (Application, Middleware, pathInfo, responseFile)
import Network.Wai.EventSource (
ServerEvent (..),
eventSourceAppChan,
eventSourceAppIO,
)
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.AddHeaders (addHeaders)
import Network.Wai.Middleware.Gzip (defaultGzipSettings, gzip)
app :: Chan ServerEvent -> Application
app chan req respond =
case pathInfo req of
[] ->
respond $
responseFile
status200
[("Content-Type", "text/html")]
"example/index.html"
Nothing
["esold"] -> eventSourceAppChan chan req respond
["eschan"] -> eventSourceAppChan chan req respond
["esio"] -> eventSourceAppIO eventIO req respond
_ -> error "unexpected pathInfo"
eventChan :: Chan ServerEvent -> IO ()
eventChan chan = forever $ do
threadDelay 1000000
time <- getPOSIXTime
writeChan chan (ServerEvent Nothing Nothing [string8 . show $ time])
eventIO :: IO ServerEvent
eventIO = do
threadDelay 1000000
time <- getPOSIXTime
return $
ServerEvent
(Just $ string8 "io")
Nothing
[string8 . show $ time]
eventRaw :: (ServerEvent -> IO ()) -> IO () -> IO ()
eventRaw = handle (0 :: Int)
where
handle counter emit flush = do
threadDelay 1000000
_ <-
emit $
ServerEvent
(Just $ string8 "raw")
Nothing
[string8 . show $ counter]
_ <- flush
handle (counter + 1) emit flush
main :: IO ()
main = do
chan <- newChan
_ <- forkIO . eventChan $ chan
run 8080 (gzip defaultGzipSettings $ headers $ app chan)
where
-- headers required for SSE to work through nginx
-- not required if using warp directly
headers :: Middleware
headers =
addHeaders
[ ("X-Accel-Buffering", "no")
, ("Cache-Control", "no-cache")
]
|
