module Web.Minion.Response.ServerEvent (
  EventSource (..),
  ToServerEvent (..),
  Wai.ServerEvent (..),
) where

import Data.Function (fix)
import Network.HTTP.Types qualified as Http
import Network.Wai qualified as Wai
import Network.Wai.EventSource qualified as Wai
import Network.Wai.EventSource.EventStream qualified as Wai
import Web.Minion

import Data.Maybe (isJust)
import Network.HTTP.Media

newtype EventSource a = EventSource (IO a)

class ToServerEvent a where
  toServerEvent :: a -> Wai.ServerEvent

instance ToServerEvent Wai.ServerEvent where
  toServerEvent :: ServerEvent -> ServerEvent
toServerEvent = ServerEvent -> ServerEvent
forall a. a -> a
id

textEventStream :: MediaType
textEventStream :: MediaType
textEventStream = ByteString
"text" ByteString -> ByteString -> MediaType
// ByteString
"event-stream"

instance CanRespond (EventSource a) where
  canRespond :: [ByteString] -> Bool
canRespond [] = Bool
True
  canRespond [ByteString]
l = (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe MediaType -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MediaType -> Bool)
-> (ByteString -> Maybe MediaType) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
matchAccept [Item [MediaType]
MediaType
textEventStream]) [ByteString]
l

instance (Monad m, ToServerEvent a) => ToResponse m (EventSource a) where
  toResponse :: [ByteString] -> EventSource a -> m Response
toResponse [ByteString]
_ (EventSource IO a
poll) = do
    Response -> m Response
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> StreamingBody -> Response
Wai.responseStream
      Status
Http.status200
      [(HeaderName
Http.hContentType, MediaType -> ByteString
forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
textEventStream)]
      \Builder -> IO ()
write IO ()
flush ->
        IO ()
flush IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix \IO ()
continue -> do
          a
event <- IO a
poll
          case ServerEvent -> Maybe Builder
Wai.eventToBuilder (ServerEvent -> Maybe Builder) -> ServerEvent -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ a -> ServerEvent
forall a. ToServerEvent a => a -> ServerEvent
toServerEvent a
event of
            Maybe Builder
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Builder
e -> Builder -> IO ()
write Builder
e IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flush IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
continue