{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Servant.API.EventStream (
  ServerEvent (..),
  ToServerEvent (..),
  ServerSentEvents,
  EventStream,
  RecommendedEventSourceHeaders,
  recommendedEventSourceHeaders,
)
where

import Control.Lens
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.Kind (Type)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Network.HTTP.Media (
  (//),
  (/:),
 )
import Servant
import Servant.Foreign
import Servant.Foreign.Internal (_FunctionName)

{- | A ServerSentEvents endpoint emits an event stream using the format described at
  <https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events#event_stream_format>
-}
data ServerSentEvents (a :: Type)
  deriving (Typeable, (forall x. ServerSentEvents a -> Rep (ServerSentEvents a) x)
-> (forall x. Rep (ServerSentEvents a) x -> ServerSentEvents a)
-> Generic (ServerSentEvents a)
forall x. Rep (ServerSentEvents a) x -> ServerSentEvents a
forall x. ServerSentEvents a -> Rep (ServerSentEvents a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ServerSentEvents a) x -> ServerSentEvents a
forall a x. ServerSentEvents a -> Rep (ServerSentEvents a) x
$cfrom :: forall a x. ServerSentEvents a -> Rep (ServerSentEvents a) x
from :: forall x. ServerSentEvents a -> Rep (ServerSentEvents a) x
$cto :: forall a x. Rep (ServerSentEvents a) x -> ServerSentEvents a
to :: forall x. Rep (ServerSentEvents a) x -> ServerSentEvents a
Generic)

instance HasLink (ServerSentEvents a) where
  type MkLink (ServerSentEvents a) r = r
  toLink :: forall a.
(Link -> a)
-> Proxy (ServerSentEvents a)
-> Link
-> MkLink (ServerSentEvents a) a
toLink Link -> a
toA Proxy (ServerSentEvents a)
_ = Link -> a
Link -> MkLink (ServerSentEvents a) a
toA

-- | Represents an event sent from the server to the client in Server-Sent Events (SSE).
data ServerEvent = ServerEvent
  { ServerEvent -> Maybe ByteString
eventType :: !(Maybe LBS.ByteString)
  -- ^ Optional field specifying the type of event. Can be used to distinguish between different kinds of events.
  , ServerEvent -> Maybe ByteString
eventId :: !(Maybe LBS.ByteString)
  -- ^ Optional field providing an identifier for the event. Useful for clients to keep track of the last received event.
  , ServerEvent -> ByteString
eventData :: !LBS.ByteString
  -- ^ The payload or content of the event. This is the main data sent to the client.
  }
  deriving (Int -> ServerEvent -> ShowS
[ServerEvent] -> ShowS
ServerEvent -> String
(Int -> ServerEvent -> ShowS)
-> (ServerEvent -> String)
-> ([ServerEvent] -> ShowS)
-> Show ServerEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerEvent -> ShowS
showsPrec :: Int -> ServerEvent -> ShowS
$cshow :: ServerEvent -> String
show :: ServerEvent -> String
$cshowList :: [ServerEvent] -> ShowS
showList :: [ServerEvent] -> ShowS
Show, ServerEvent -> ServerEvent -> Bool
(ServerEvent -> ServerEvent -> Bool)
-> (ServerEvent -> ServerEvent -> Bool) -> Eq ServerEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerEvent -> ServerEvent -> Bool
== :: ServerEvent -> ServerEvent -> Bool
$c/= :: ServerEvent -> ServerEvent -> Bool
/= :: ServerEvent -> ServerEvent -> Bool
Eq, (forall x. ServerEvent -> Rep ServerEvent x)
-> (forall x. Rep ServerEvent x -> ServerEvent)
-> Generic ServerEvent
forall x. Rep ServerEvent x -> ServerEvent
forall x. ServerEvent -> Rep ServerEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ServerEvent -> Rep ServerEvent x
from :: forall x. ServerEvent -> Rep ServerEvent x
$cto :: forall x. Rep ServerEvent x -> ServerEvent
to :: forall x. Rep ServerEvent x -> ServerEvent
Generic)

{- | This typeclass allows you to define custom event types that can be
  transformed into the 'ServerEvent' type, which is used to represent events in
  the Server-Sent Events (SSE) protocol.
-}
class ToServerEvent a where
  toServerEvent :: a -> ServerEvent

instance (ToServerEvent a) => MimeRender EventStream a where
  mimeRender :: Proxy EventStream -> a -> ByteString
mimeRender Proxy EventStream
_ = ServerEvent -> ByteString
encodeServerEvent (ServerEvent -> ByteString)
-> (a -> ServerEvent) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ServerEvent
forall a. ToServerEvent a => a -> ServerEvent
toServerEvent

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

{- | Event streams are implemented using servant's 'Stream' endpoint.
  You should provide a handler that returns a stream of events that implements
  'ToSourceIO' where events have a 'ToServerEvent' instance.

  Example:

  > type MyApi = "books" :> ServerSentEvents (SourceIO Book)
  >
  > instance ToServerEvent Book where
  >   toServerEvent book = ...
  >
  > server :: Server MyApi
  > server = streamBooks
  >   where streamBooks :: Handler (SourceIO Book)
  >         streamBooks = pure $ source [book1, ...]
-}
instance {-# OVERLAPPABLE #-} (ToServerEvent chunk, ToSourceIO chunk a) => HasServer (ServerSentEvents a) context where
  type ServerT (ServerSentEvents a) m = ServerT (StreamGet ServerEventFraming EventStream a) m
  route :: forall env.
Proxy (ServerSentEvents a)
-> Context context
-> Delayed env (Server (ServerSentEvents a))
-> Router env
route Proxy (ServerSentEvents a)
Proxy =
    Proxy (StreamGet ServerEventFraming EventStream a)
-> Context context
-> Delayed
     env (Server (StreamGet ServerEventFraming EventStream a))
-> Router' env RoutingApplication
forall env.
Proxy (StreamGet ServerEventFraming EventStream a)
-> Context context
-> Delayed
     env (Server (StreamGet ServerEventFraming EventStream a))
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route
      (Proxy (StreamGet ServerEventFraming EventStream a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (StreamGet ServerEventFraming EventStream a))
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (ServerSentEvents a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ServerSentEvents a) m
-> ServerT (ServerSentEvents a) n
hoistServerWithContext Proxy (ServerSentEvents a)
Proxy =
    Proxy (StreamGet ServerEventFraming EventStream a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (StreamGet ServerEventFraming EventStream a) m
-> ServerT (StreamGet ServerEventFraming EventStream a) n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy (StreamGet ServerEventFraming EventStream a)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (StreamGet ServerEventFraming EventStream a) m
-> ServerT (StreamGet ServerEventFraming EventStream a) n
hoistServerWithContext
      (Proxy (StreamGet ServerEventFraming EventStream a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (StreamGet ServerEventFraming EventStream a))

instance {-# OVERLAPPING #-} (ToServerEvent chunk, ToSourceIO chunk a, GetHeaders (Headers h a)) => HasServer (ServerSentEvents (Headers h a)) context where
  type ServerT (ServerSentEvents (Headers h a)) m = ServerT (StreamGet ServerEventFraming EventStream (Headers h a)) m
  route :: forall env.
Proxy (ServerSentEvents (Headers h a))
-> Context context
-> Delayed env (Server (ServerSentEvents (Headers h a)))
-> Router env
route Proxy (ServerSentEvents (Headers h a))
Proxy =
    Proxy (StreamGet ServerEventFraming EventStream (Headers h a))
-> Context context
-> Delayed
     env
     (Server (StreamGet ServerEventFraming EventStream (Headers h a)))
-> Router' env RoutingApplication
forall env.
Proxy (StreamGet ServerEventFraming EventStream (Headers h a))
-> Context context
-> Delayed
     env
     (Server (StreamGet ServerEventFraming EventStream (Headers h a)))
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route
      (Proxy (StreamGet ServerEventFraming EventStream (Headers h a))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (StreamGet ServerEventFraming EventStream (Headers h a)))
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (ServerSentEvents (Headers h a))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ServerSentEvents (Headers h a)) m
-> ServerT (ServerSentEvents (Headers h a)) n
hoistServerWithContext Proxy (ServerSentEvents (Headers h a))
Proxy =
    Proxy (StreamGet ServerEventFraming EventStream (Headers h a))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT
     (StreamGet ServerEventFraming EventStream (Headers h a)) m
-> ServerT
     (StreamGet ServerEventFraming EventStream (Headers h a)) n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy (StreamGet ServerEventFraming EventStream (Headers h a))
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT
     (StreamGet ServerEventFraming EventStream (Headers h a)) m
-> ServerT
     (StreamGet ServerEventFraming EventStream (Headers h a)) n
hoistServerWithContext
      (Proxy (StreamGet ServerEventFraming EventStream (Headers h a))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (StreamGet ServerEventFraming EventStream (Headers h a)))

-- | a helper instance for <https://hackage.haskell.org/package/servant-foreign-0.15.3/docs/Servant-Foreign.html servant-foreign>
instance
  (HasForeignType lang ftype a) =>
  HasForeign lang ftype (ServerSentEvents a)
  where
  type Foreign ftype (ServerSentEvents a) = Req ftype

  foreignFor :: Proxy lang
-> Proxy ftype
-> Proxy (ServerSentEvents a)
-> Req ftype
-> Foreign ftype (ServerSentEvents a)
foreignFor Proxy lang
lang Proxy ftype
Proxy Proxy (ServerSentEvents a)
Proxy Req ftype
req =
    Req ftype
req
      Req ftype -> (Req ftype -> Req ftype) -> Req ftype
forall a b. a -> (a -> b) -> b
& (FunctionName -> Identity FunctionName)
-> Req ftype -> Identity (Req ftype)
forall ftype (f :: * -> *).
Functor f =>
(FunctionName -> f FunctionName) -> Req ftype -> f (Req ftype)
reqFuncName ((FunctionName -> Identity FunctionName)
 -> Req ftype -> Identity (Req ftype))
-> (([Text] -> Identity [Text])
    -> FunctionName -> Identity FunctionName)
-> ([Text] -> Identity [Text])
-> Req ftype
-> Identity (Req ftype)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Identity [Text])
-> FunctionName -> Identity FunctionName
Iso' FunctionName [Text]
_FunctionName (([Text] -> Identity [Text]) -> Req ftype -> Identity (Req ftype))
-> ([Text] -> [Text]) -> Req ftype -> Req ftype
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Text
"stream" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
      Req ftype -> (Req ftype -> Req ftype) -> Req ftype
forall a b. a -> (a -> b) -> b
& (Method -> Identity Method) -> Req ftype -> Identity (Req ftype)
forall ftype (f :: * -> *).
Functor f =>
(Method -> f Method) -> Req ftype -> f (Req ftype)
reqMethod ((Method -> Identity Method) -> Req ftype -> Identity (Req ftype))
-> Method -> Req ftype -> Req ftype
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Method
method
      Req ftype -> (Req ftype -> Req ftype) -> Req ftype
forall a b. a -> (a -> b) -> b
& (Maybe ftype -> Identity (Maybe ftype))
-> Req ftype -> Identity (Req ftype)
forall ftype (f :: * -> *).
Functor f =>
(Maybe ftype -> f (Maybe ftype)) -> Req ftype -> f (Req ftype)
reqReturnType ((Maybe ftype -> Identity (Maybe ftype))
 -> Req ftype -> Identity (Req ftype))
-> ftype -> Req ftype -> Req ftype
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ftype
retType
   where
    retType :: ftype
retType = Proxy lang -> Proxy ftype -> Proxy a -> ftype
forall {k} {k1} (lang :: k) ftype (a :: k1).
HasForeignType lang ftype a =>
Proxy lang -> Proxy ftype -> Proxy a -> ftype
typeFor Proxy lang
lang (Proxy ftype
forall {k} (t :: k). Proxy t
Proxy :: Proxy ftype) (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    method :: Method
method = Proxy 'GET -> Method
forall {k} (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod (Proxy 'GET
forall {k} (t :: k). Proxy t
Proxy :: Proxy 'GET)

{- | A type representation of an event stream. It's responsible for setting proper content-type
  and buffering headers, as well as for providing parser implementations for the streams.
  Read more on <https://docs.servant.dev/en/stable/tutorial/Server.html#streaming-endpoints Servant Streaming Docs>
-}
data EventStream

instance Accept EventStream where
  contentType :: Proxy EventStream -> MediaType
contentType Proxy EventStream
_ = Method
"text" Method -> Method -> MediaType
// Method
"event-stream" MediaType -> (Method, Method) -> MediaType
/: (Method
"charset", Method
"utf-8")

{- | This is mostly to guide reverse-proxies like
  <https://www.nginx.com/resources/wiki/start/topics/examples/x-accel/#x-accel-buffering nginx>

  Example:

  > type MyApi = "books" :> ServerSentEvents (RecommendedEventSourceHeaders (SourceIO Book))
  >
  > server :: Server MyApi
  > server = streamBooks
  >   where streamBooks :: Handler (RecommendedEventSourceHeaders (SourceIO Book))
  >         streamBooks = pure $ recommendedEventSourceHeaders $ source [book1, ...]
-}
type RecommendedEventSourceHeaders (a :: Type) = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] a

-- | Add the recommended headers for Server-Sent Events to the response.
recommendedEventSourceHeaders :: a -> RecommendedEventSourceHeaders a
recommendedEventSourceHeaders :: forall a. a -> RecommendedEventSourceHeaders a
recommendedEventSourceHeaders = forall (h :: Symbol) v orig new.
AddHeader '[Optional, Strict] h v orig new =>
v -> orig -> new
addHeader @"X-Accel-Buffering" Text
"no" (Headers '[Header' '[Optional, Strict] "Cache-Control" Text] a
 -> RecommendedEventSourceHeaders a)
-> (a
    -> Headers '[Header' '[Optional, Strict] "Cache-Control" Text] a)
-> a
-> RecommendedEventSourceHeaders a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: Symbol) v orig new.
AddHeader '[Optional, Strict] h v orig new =>
v -> orig -> new
addHeader @"Cache-Control" Text
"no-store"

data ServerEventFraming

instance FramingRender ServerEventFraming where
  framingRender :: forall (m :: * -> *) a.
Monad m =>
Proxy ServerEventFraming
-> (a -> ByteString) -> SourceT m a -> SourceT m ByteString
framingRender Proxy ServerEventFraming
_ a -> ByteString
f = (a -> ByteString) -> SourceT m a -> SourceT m ByteString
forall a b. (a -> b) -> SourceT m a -> SourceT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> a -> ByteString
f a
x ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")

{- 1. Field names must not contain LF, CR or COLON characters.
   2. Values must not contain LF or CR characters.
      Multple consecutive `data:` fields will be joined with LFs on the client.
-}
encodeServerEvent :: ServerEvent -> LBS.ByteString
encodeServerEvent :: ServerEvent -> ByteString
encodeServerEvent ServerEvent
e =
  ByteString -> Maybe ByteString -> ByteString
forall {b}. (Monoid b, IsString b) => b -> Maybe b -> b
optional ByteString
"event:" (ServerEvent -> Maybe ByteString
eventType ServerEvent
e)
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Maybe ByteString -> ByteString
forall {b}. (Monoid b, IsString b) => b -> Maybe b -> b
optional ByteString
"id:" (ServerEvent -> Maybe ByteString
eventId ServerEvent
e)
    ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ((ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
forall {a}. (Semigroup a, IsString a) => a -> a -> a
field ByteString
"data:") (ByteString -> [ByteString]
safelines (ServerEvent -> ByteString
eventData ServerEvent
e)))
 where
  optional :: b -> Maybe b -> b
optional b
name = b -> (b -> b) -> Maybe b -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
forall a. Monoid a => a
mempty (b -> b -> b
forall {a}. (Semigroup a, IsString a) => a -> a -> a
field b
name)
  field :: a -> a -> a
field a
name a
val = a
name a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
val a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\n"

  -- discard CR and split LFs into multiple data values
  safelines :: ByteString -> [ByteString]
safelines = ByteString -> [ByteString]
C8.lines (ByteString -> [ByteString])
-> (ByteString -> ByteString) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
C8.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')