{-# LANGUAGE OverloadedStrings #-}
-- | This module contains everything that you need to support
-- server-sent events in Yesod applications.
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



-- | (Internal) Find out the request's 'EventSourcePolyfill' and
-- set any necessary headers.
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" -- extremely important!
  EventSourcePolyfill -> m EventSourcePolyfill
forall (m :: * -> *) a. Monad m => a -> m a
return EventSourcePolyfill
polyfill


-- | (Internal) Source with a event stream content-type.
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"


-- | Returns a Server-Sent Event stream from a 'Source' of
-- 'ES.ServerEvent'@s@.  The HTTP socket is flushed after every
-- event.  The connection is closed either when the 'Source'
-- finishes outputting data or a 'ES.CloseEvent' is outputted,
-- whichever comes first.
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

-- | Convert a ServerEvent source into a Builder source of serialized
-- events.
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


-- | Return a Server-Sent Event stream given a 'HandlerFor' action
-- that is repeatedly called.  A state is threaded for the action
-- so that it may avoid using @IORefs@.  The @HandlerFor@ action
-- may sleep or block while waiting for more data.  The HTTP
-- socket is flushed after every list of simultaneous events.
-- The connection is closed as soon as an 'ES.CloseEvent' is
-- outputted, after which no other events are sent to the client.
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 -- Get new events to be sent.
      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')

      -- Join all events in a single Builder.  Returns @False@
      -- when we the connection should be closed.
      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)


-- | Return a Server-Sent Event stream given an @IO@ action that
-- is repeatedly called.  A state is threaded for the action so
-- that it may avoid using @IORefs@.  The @IO@ action may sleep
-- or block while waiting for more data.  The HTTP socket is
-- flushed after every list of simultaneous events.  The
-- connection is closed as soon as an 'ES.CloseEvent' is
-- outputted, after which no other events are sent to the client.
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)


-- | Which @EventSource@ polyfill was detected (if any).
data EventSourcePolyfill =
    NoESPolyfill
    -- ^ We didn't detect any @EventSource@ polyfill that we know.
  | Remy'sESPolyfill
    -- ^ See
    -- <https://github.com/remy/polyfills/blob/master/EventSource.js>.
    -- In order to support Remy\'s polyfill, your server needs to
    -- explicitly close the connection from time to
    -- time--browsers such as IE7 will not show any event until
    -- the connection is closed.
    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)