{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

module Okapi.EventSource
  ( ToSSE (..)
  , Event (..)
  , EventSource
  , newEventSource
  , sendEvent
  , sendValue
  , eventSourceAppUnagiChan
  )
where

import qualified Control.Concurrent.Chan.Unagi as Unagi
import qualified Control.Monad.IO.Class as IO
-- import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as ByteString
import qualified Data.ByteString.Builder as Builder
import qualified Data.Function as Function
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import qualified Network.HTTP.Types as HTTP
import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.Wai as Wai
import qualified Network.Wai.EventSource as EventSource

class ToSSE a where
  toSSE :: a -> Event

data Event
  = Event
      { Event -> Maybe Text
eventName :: Maybe Text.Text,
        Event -> Maybe Text
eventID :: Maybe Text.Text,
        Event -> ByteString
eventData :: ByteString.ByteString
      }
  | CommentEvent ByteString.ByteString
  | CloseEvent
  deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show, Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c== :: Event -> Event -> Bool
Eq)

type Chan a = (Unagi.InChan a, Unagi.OutChan a)

type EventSource = Chan Event

newEventSource :: IO EventSource
newEventSource :: IO EventSource
newEventSource = IO EventSource
forall a. IO (InChan a, OutChan a)
Unagi.newChan

sendValue :: ToSSE a => EventSource -> a -> IO ()
sendValue :: EventSource -> a -> IO ()
sendValue (InChan Event
inChan, OutChan Event
_outChan) = InChan Event -> Event -> IO ()
forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan Event
inChan (Event -> IO ()) -> (a -> Event) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Event
forall a. ToSSE a => a -> Event
toSSE

sendEvent :: EventSource -> Event -> IO ()
sendEvent :: EventSource -> Event -> IO ()
sendEvent (InChan Event
inChan, OutChan Event
_outChan) = InChan Event -> Event -> IO ()
forall a. InChan a -> a -> IO ()
Unagi.writeChan InChan Event
inChan

eventSourceAppUnagiChan :: Chan Event -> Wai.Application
eventSourceAppUnagiChan :: EventSource -> Application
eventSourceAppUnagiChan (InChan Event
inChan, OutChan Event
_outChan) Request
req Response -> IO ResponseReceived
sendResponse = do
  OutChan Event
outChan <- IO (OutChan Event) -> IO (OutChan Event)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
IO.liftIO (IO (OutChan Event) -> IO (OutChan Event))
-> IO (OutChan Event) -> IO (OutChan Event)
forall a b. (a -> b) -> a -> b
$ InChan Event -> IO (OutChan Event)
forall a. InChan a -> IO (OutChan a)
Unagi.dupChan InChan Event
inChan
  IO ServerEvent -> Application
eventSourceAppIO (Event -> ServerEvent
eventToServerEvent (Event -> ServerEvent) -> IO Event -> IO ServerEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OutChan Event -> IO Event
forall a. OutChan a -> IO a
Unagi.readChan OutChan Event
outChan) Request
req Response -> IO ResponseReceived
sendResponse

eventSourceAppIO :: IO EventSource.ServerEvent -> Wai.Application
eventSourceAppIO :: IO ServerEvent -> Application
eventSourceAppIO IO ServerEvent
src Request
_ Response -> IO ResponseReceived
sendResponse =
  Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
    Status -> ResponseHeaders -> StreamingBody -> Response
Wai.responseStream
      Status
HTTP.status200
      [(HeaderName
HTTP.hContentType, ByteString
"text/event-stream")]
      (StreamingBody -> Response) -> StreamingBody -> Response
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush -> do
        IO ()
flush
        (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
Function.fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
          ServerEvent
se <- IO ServerEvent
src
          case ServerEvent -> Maybe Builder
eventToBuilder ServerEvent
se of
            Maybe Builder
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Builder
b -> Builder -> IO ()
sendChunk Builder
b IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
flush IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop

eventToBuilder :: EventSource.ServerEvent -> Maybe Builder.Builder
eventToBuilder :: ServerEvent -> Maybe Builder
eventToBuilder (EventSource.CommentEvent Builder
txt) = Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Builder
field Builder
commentField Builder
txt
eventToBuilder (EventSource.RetryEvent Int
n) = Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Builder
field Builder
retryField (String -> Builder
Builder.string8 (String -> Builder) -> (Int -> String) -> Int -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ Int
n)
eventToBuilder ServerEvent
EventSource.CloseEvent = Maybe Builder
forall a. Maybe a
Nothing
eventToBuilder (EventSource.ServerEvent Maybe Builder
n Maybe Builder
i [Builder]
d) =
  Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$
    Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Maybe Builder -> Builder -> Builder
name Maybe Builder
n (Maybe Builder -> Builder -> Builder
evid Maybe Builder
i (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> Builder -> Builder
evdata ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
d) Builder
nl)) Builder
nl
  where
    name :: Maybe Builder -> Builder -> Builder
name Maybe Builder
Nothing = Builder -> Builder
forall a. a -> a
id
    name (Just Builder
n') = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Builder -> Builder -> Builder
field Builder
nameField Builder
n')
    evid :: Maybe Builder -> Builder -> Builder
evid Maybe Builder
Nothing = Builder -> Builder
forall a. a -> a
id
    evid (Just Builder
i') = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Builder -> Builder -> Builder
field Builder
idField Builder
i')
    evdata :: Builder -> Builder -> Builder
evdata Builder
d' = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend (Builder -> Builder -> Builder
field Builder
dataField Builder
d')

nl :: Builder.Builder
nl :: Builder
nl = Char -> Builder
Builder.char7 Char
'\n'

nameField, idField, dataField, retryField, commentField :: Builder.Builder
nameField :: Builder
nameField = String -> Builder
Builder.string7 String
"event:"
idField :: Builder
idField = String -> Builder
Builder.string7 String
"id:"
dataField :: Builder
dataField = String -> Builder
Builder.string7 String
"data:"
retryField :: Builder
retryField = String -> Builder
Builder.string7 String
"retry:"
commentField :: Builder
commentField = Char -> Builder
Builder.char7 Char
':'

-- | Wraps the text as a labeled field of an event stream.
field :: Builder.Builder -> Builder.Builder -> Builder.Builder
field :: Builder -> Builder -> Builder
field Builder
l Builder
b = Builder
l Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
b Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Builder
nl

eventToServerEvent :: Event -> EventSource.ServerEvent
eventToServerEvent :: Event -> ServerEvent
eventToServerEvent Event {Maybe Text
ByteString
eventData :: ByteString
eventID :: Maybe Text
eventName :: Maybe Text
eventData :: Event -> ByteString
eventID :: Event -> Maybe Text
eventName :: Event -> Maybe Text
..} =
  Maybe Builder -> Maybe Builder -> [Builder] -> ServerEvent
EventSource.ServerEvent
    (ByteString -> Builder
Builder.byteString (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> Builder) -> Maybe Text -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
eventName)
    (ByteString -> Builder
Builder.byteString (ByteString -> Builder) -> (Text -> ByteString) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> Builder) -> Maybe Text -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
eventID)
    (Word8 -> Builder
Builder.word8 (Word8 -> Builder) -> [Word8] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [Word8]
ByteString.unpack ByteString
eventData)
eventToServerEvent (CommentEvent ByteString
comment) = Builder -> ServerEvent
EventSource.CommentEvent (Builder -> ServerEvent) -> Builder -> ServerEvent
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
Builder.lazyByteString ByteString
comment
eventToServerEvent Event
CloseEvent = ServerEvent
EventSource.CloseEvent