module Yesod.EventSource
( RepEventSource
, repEventSource
, ioToRepEventSource
, EventSourcePolyfill(..)
) where
import Blaze.ByteString.Builder (Builder)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Functor ((<$>))
import Data.Monoid (mappend, mempty)
import Yesod.Content
import Yesod.Core
import qualified Data.Conduit as C
import qualified Network.Wai as W
import qualified Network.Wai.EventSource as ES
import qualified Network.Wai.EventSource.EventStream as ES
newtype RepEventSource =
RepEventSource (C.Source (C.ResourceT IO) (C.Flush Builder))
instance HasReps RepEventSource where
chooseRep (RepEventSource src) =
const $ return ("text/event-stream", ContentSource src)
prepareForEventSource :: GHandler sub master EventSourcePolyfill
prepareForEventSource = do
reqWith <- lookup "X-Requested-With" . W.requestHeaders <$> waiRequest
let polyfill | reqWith == Just "XMLHttpRequest" = Remy'sESPolyfill
| otherwise = NoESPolyfill
setHeader "Cache-Control" "no-cache"
return polyfill
repEventSource :: (EventSourcePolyfill -> C.Source (C.ResourceT IO) ES.ServerEvent)
-> GHandler sub master RepEventSource
repEventSource src = RepEventSource . ES.sourceToSource . src <$> prepareForEventSource
ioToRepEventSource :: s
-> (EventSourcePolyfill -> s -> IO ([ES.ServerEvent], s))
-> GHandler sub master RepEventSource
ioToRepEventSource initial act = do
polyfill <- prepareForEventSource
let
getEvents s = do
(evs, s') <- liftIO (act polyfill s)
case evs of
[] -> getEvents s'
_ -> do
let (builder, continue) = joinEvents evs mempty
C.yield (C.Chunk builder)
C.yield C.Flush
when continue (getEvents s')
joinEvents (ev:evs) acc =
case ES.eventToBuilder ev of
Just b -> joinEvents evs (acc `mappend` b)
Nothing -> (fst $ joinEvents [] acc, False)
joinEvents [] acc = (acc, True)
return $ RepEventSource $ getEvents initial
data EventSourcePolyfill =
NoESPolyfill
| Remy'sESPolyfill
deriving (Eq, Ord, Show, Enum)