{-# LANGUAGE OverloadedStrings #-}
module Yesod.EventSource
( repEventSource
, pollingEventSource
, ioToRepEventSource
, EventSourcePolyfill(..)
) where
import Blaze.ByteString.Builder (Builder)
import Control.Monad (when)
import Data.Functor ((<$>))
import Data.Monoid (Monoid (..))
import Yesod.Core
import Data.Conduit
import qualified Network.Wai as W
import qualified Network.Wai.EventSource as ES
import qualified Network.Wai.EventSource.EventStream as ES
prepareForEventSource :: MonadHandler m => m EventSourcePolyfill
prepareForEventSource :: m EventSourcePolyfill
prepareForEventSource = do
Maybe ByteString
reqWith <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Requested-With" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(HeaderName, ByteString)]
W.requestHeaders (Request -> Maybe ByteString) -> m Request -> m (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Data.Functor.<$> m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
let polyfill :: EventSourcePolyfill
polyfill | Maybe ByteString
reqWith Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"XMLHttpRequest" = EventSourcePolyfill
Remy'sESPolyfill
| Bool
otherwise = EventSourcePolyfill
NoESPolyfill
Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"Cache-Control" Text
"no-cache"
EventSourcePolyfill -> m EventSourcePolyfill
forall (m :: * -> *) a. Monad m => a -> m a
return EventSourcePolyfill
polyfill
respondEventStream :: ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondEventStream :: ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondEventStream = ByteString
-> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
forall site.
ByteString
-> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondSource ByteString
"text/event-stream"
repEventSource :: (EventSourcePolyfill -> ConduitT () ES.ServerEvent (HandlerFor site) ())
-> HandlerFor site TypedContent
repEventSource :: (EventSourcePolyfill
-> ConduitT () ServerEvent (HandlerFor site) ())
-> HandlerFor site TypedContent
repEventSource EventSourcePolyfill -> ConduitT () ServerEvent (HandlerFor site) ()
src =
HandlerFor site EventSourcePolyfill
forall (m :: * -> *). MonadHandler m => m EventSourcePolyfill
prepareForEventSource HandlerFor site EventSourcePolyfill
-> (EventSourcePolyfill -> HandlerFor site TypedContent)
-> HandlerFor site TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
forall site.
ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondEventStream (ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent)
-> (EventSourcePolyfill
-> ConduitT () (Flush Builder) (HandlerFor site) ())
-> EventSourcePolyfill
-> HandlerFor site TypedContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT () ServerEvent (HandlerFor site) ()
-> ConduitT () (Flush Builder) (HandlerFor site) ()
forall (m :: * -> *).
Monad m =>
ConduitT () ServerEvent m () -> ConduitT () (Flush Builder) m ()
sourceToSource (ConduitT () ServerEvent (HandlerFor site) ()
-> ConduitT () (Flush Builder) (HandlerFor site) ())
-> (EventSourcePolyfill
-> ConduitT () ServerEvent (HandlerFor site) ())
-> EventSourcePolyfill
-> ConduitT () (Flush Builder) (HandlerFor site) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventSourcePolyfill -> ConduitT () ServerEvent (HandlerFor site) ()
src
sourceToSource
:: Monad m
=> ConduitT () ES.ServerEvent m ()
-> ConduitT () (Flush Builder) m ()
sourceToSource :: ConduitT () ServerEvent m () -> ConduitT () (Flush Builder) m ()
sourceToSource ConduitT () ServerEvent m ()
src =
ConduitT () ServerEvent m ()
src ConduitT () ServerEvent m ()
-> ConduitM ServerEvent (Flush Builder) m ()
-> ConduitT () (Flush Builder) m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (ServerEvent -> ConduitM ServerEvent (Flush Builder) m ())
-> ConduitM ServerEvent (Flush Builder) m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ServerEvent -> ConduitM ServerEvent (Flush Builder) m ()
forall (m :: * -> *) i.
Monad m =>
ServerEvent -> ConduitT i (Flush Builder) m ()
eventToFlushBuilder
where
eventToFlushBuilder :: ServerEvent -> ConduitT i (Flush Builder) m ()
eventToFlushBuilder ServerEvent
event =
case ServerEvent -> Maybe Builder
ES.eventToBuilder ServerEvent
event of
Maybe Builder
Nothing -> () -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Builder
x -> Flush Builder -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Builder -> Flush Builder
forall a. a -> Flush a
Chunk Builder
x) ConduitT i (Flush Builder) m ()
-> ConduitT i (Flush Builder) m ()
-> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Flush Builder -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Flush Builder
forall a. Flush a
Flush
pollingEventSource :: s
-> (EventSourcePolyfill -> s -> HandlerFor site ([ES.ServerEvent], s))
-> HandlerFor site TypedContent
pollingEventSource :: s
-> (EventSourcePolyfill -> s -> HandlerFor site ([ServerEvent], s))
-> HandlerFor site TypedContent
pollingEventSource s
initial EventSourcePolyfill -> s -> HandlerFor site ([ServerEvent], s)
act = do
EventSourcePolyfill
polyfill <- HandlerFor site EventSourcePolyfill
forall (m :: * -> *). MonadHandler m => m EventSourcePolyfill
prepareForEventSource
let
getEvents :: s -> ConduitT i (Flush Builder) (HandlerFor site) ()
getEvents s
s = do
([ServerEvent]
evs, s
s') <- HandlerFor site ([ServerEvent], s)
-> ConduitT i (Flush Builder) (HandlerFor site) ([ServerEvent], s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EventSourcePolyfill -> s -> HandlerFor site ([ServerEvent], s)
act EventSourcePolyfill
polyfill s
s)
case [ServerEvent]
evs of
[] -> s -> ConduitT i (Flush Builder) (HandlerFor site) ()
getEvents s
s'
[ServerEvent]
_ -> do
let (Builder
builder, Bool
continue) = [ServerEvent] -> Builder -> (Builder, Bool)
joinEvents [ServerEvent]
evs Builder
forall a. Monoid a => a
mempty
Flush Builder -> ConduitT i (Flush Builder) (HandlerFor site) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Builder -> Flush Builder
forall a. a -> Flush a
Chunk Builder
builder)
Flush Builder -> ConduitT i (Flush Builder) (HandlerFor site) ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Flush Builder
forall a. Flush a
Flush
Bool
-> ConduitT i (Flush Builder) (HandlerFor site) ()
-> ConduitT i (Flush Builder) (HandlerFor site) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
continue (s -> ConduitT i (Flush Builder) (HandlerFor site) ()
getEvents s
s')
joinEvents :: [ServerEvent] -> Builder -> (Builder, Bool)
joinEvents (ServerEvent
ev:[ServerEvent]
evs) Builder
acc =
case ServerEvent -> Maybe Builder
ES.eventToBuilder ServerEvent
ev of
Just Builder
b -> [ServerEvent] -> Builder -> (Builder, Bool)
joinEvents [ServerEvent]
evs (Builder
acc Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`Data.Monoid.mappend` Builder
b)
Maybe Builder
Nothing -> ((Builder, Bool) -> Builder
forall a b. (a, b) -> a
fst ((Builder, Bool) -> Builder) -> (Builder, Bool) -> Builder
forall a b. (a -> b) -> a -> b
$ [ServerEvent] -> Builder -> (Builder, Bool)
joinEvents [] Builder
acc, Bool
False)
joinEvents [] Builder
acc = (Builder
acc, Bool
True)
ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
forall site.
ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondEventStream (s -> ConduitT () (Flush Builder) (HandlerFor site) ()
forall i. s -> ConduitT i (Flush Builder) (HandlerFor site) ()
getEvents s
initial)
ioToRepEventSource :: s
-> (EventSourcePolyfill -> s -> IO ([ES.ServerEvent], s))
-> HandlerFor site TypedContent
ioToRepEventSource :: s
-> (EventSourcePolyfill -> s -> IO ([ServerEvent], s))
-> HandlerFor site TypedContent
ioToRepEventSource s
initial EventSourcePolyfill -> s -> IO ([ServerEvent], s)
act = s
-> (EventSourcePolyfill -> s -> HandlerFor site ([ServerEvent], s))
-> HandlerFor site TypedContent
forall s site.
s
-> (EventSourcePolyfill -> s -> HandlerFor site ([ServerEvent], s))
-> HandlerFor site TypedContent
pollingEventSource s
initial EventSourcePolyfill -> s -> HandlerFor site ([ServerEvent], s)
forall (m :: * -> *).
MonadIO m =>
EventSourcePolyfill -> s -> m ([ServerEvent], s)
act'
where act' :: EventSourcePolyfill -> s -> m ([ServerEvent], s)
act' EventSourcePolyfill
p s
s = IO ([ServerEvent], s) -> m ([ServerEvent], s)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (EventSourcePolyfill -> s -> IO ([ServerEvent], s)
act EventSourcePolyfill
p s
s)
data EventSourcePolyfill =
NoESPolyfill
| Remy'sESPolyfill
deriving (EventSourcePolyfill -> EventSourcePolyfill -> Bool
(EventSourcePolyfill -> EventSourcePolyfill -> Bool)
-> (EventSourcePolyfill -> EventSourcePolyfill -> Bool)
-> Eq EventSourcePolyfill
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
$c/= :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
== :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
$c== :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
Eq, Eq EventSourcePolyfill
Eq EventSourcePolyfill
-> (EventSourcePolyfill -> EventSourcePolyfill -> Ordering)
-> (EventSourcePolyfill -> EventSourcePolyfill -> Bool)
-> (EventSourcePolyfill -> EventSourcePolyfill -> Bool)
-> (EventSourcePolyfill -> EventSourcePolyfill -> Bool)
-> (EventSourcePolyfill -> EventSourcePolyfill -> Bool)
-> (EventSourcePolyfill
-> EventSourcePolyfill -> EventSourcePolyfill)
-> (EventSourcePolyfill
-> EventSourcePolyfill -> EventSourcePolyfill)
-> Ord EventSourcePolyfill
EventSourcePolyfill -> EventSourcePolyfill -> Bool
EventSourcePolyfill -> EventSourcePolyfill -> Ordering
EventSourcePolyfill -> EventSourcePolyfill -> EventSourcePolyfill
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EventSourcePolyfill -> EventSourcePolyfill -> EventSourcePolyfill
$cmin :: EventSourcePolyfill -> EventSourcePolyfill -> EventSourcePolyfill
max :: EventSourcePolyfill -> EventSourcePolyfill -> EventSourcePolyfill
$cmax :: EventSourcePolyfill -> EventSourcePolyfill -> EventSourcePolyfill
>= :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
$c>= :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
> :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
$c> :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
<= :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
$c<= :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
< :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
$c< :: EventSourcePolyfill -> EventSourcePolyfill -> Bool
compare :: EventSourcePolyfill -> EventSourcePolyfill -> Ordering
$ccompare :: EventSourcePolyfill -> EventSourcePolyfill -> Ordering
$cp1Ord :: Eq EventSourcePolyfill
Ord, Int -> EventSourcePolyfill -> ShowS
[EventSourcePolyfill] -> ShowS
EventSourcePolyfill -> String
(Int -> EventSourcePolyfill -> ShowS)
-> (EventSourcePolyfill -> String)
-> ([EventSourcePolyfill] -> ShowS)
-> Show EventSourcePolyfill
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EventSourcePolyfill] -> ShowS
$cshowList :: [EventSourcePolyfill] -> ShowS
show :: EventSourcePolyfill -> String
$cshow :: EventSourcePolyfill -> String
showsPrec :: Int -> EventSourcePolyfill -> ShowS
$cshowsPrec :: Int -> EventSourcePolyfill -> ShowS
Show, Int -> EventSourcePolyfill
EventSourcePolyfill -> Int
EventSourcePolyfill -> [EventSourcePolyfill]
EventSourcePolyfill -> EventSourcePolyfill
EventSourcePolyfill -> EventSourcePolyfill -> [EventSourcePolyfill]
EventSourcePolyfill
-> EventSourcePolyfill
-> EventSourcePolyfill
-> [EventSourcePolyfill]
(EventSourcePolyfill -> EventSourcePolyfill)
-> (EventSourcePolyfill -> EventSourcePolyfill)
-> (Int -> EventSourcePolyfill)
-> (EventSourcePolyfill -> Int)
-> (EventSourcePolyfill -> [EventSourcePolyfill])
-> (EventSourcePolyfill
-> EventSourcePolyfill -> [EventSourcePolyfill])
-> (EventSourcePolyfill
-> EventSourcePolyfill -> [EventSourcePolyfill])
-> (EventSourcePolyfill
-> EventSourcePolyfill
-> EventSourcePolyfill
-> [EventSourcePolyfill])
-> Enum EventSourcePolyfill
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: EventSourcePolyfill
-> EventSourcePolyfill
-> EventSourcePolyfill
-> [EventSourcePolyfill]
$cenumFromThenTo :: EventSourcePolyfill
-> EventSourcePolyfill
-> EventSourcePolyfill
-> [EventSourcePolyfill]
enumFromTo :: EventSourcePolyfill -> EventSourcePolyfill -> [EventSourcePolyfill]
$cenumFromTo :: EventSourcePolyfill -> EventSourcePolyfill -> [EventSourcePolyfill]
enumFromThen :: EventSourcePolyfill -> EventSourcePolyfill -> [EventSourcePolyfill]
$cenumFromThen :: EventSourcePolyfill -> EventSourcePolyfill -> [EventSourcePolyfill]
enumFrom :: EventSourcePolyfill -> [EventSourcePolyfill]
$cenumFrom :: EventSourcePolyfill -> [EventSourcePolyfill]
fromEnum :: EventSourcePolyfill -> Int
$cfromEnum :: EventSourcePolyfill -> Int
toEnum :: Int -> EventSourcePolyfill
$ctoEnum :: Int -> EventSourcePolyfill
pred :: EventSourcePolyfill -> EventSourcePolyfill
$cpred :: EventSourcePolyfill -> EventSourcePolyfill
succ :: EventSourcePolyfill -> EventSourcePolyfill
$csucc :: EventSourcePolyfill -> EventSourcePolyfill
Enum)