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

module Servant.API.EventStream
  ( ServerSentEvents
  , EventStream
  , EventSource
  , EventSourceHdr
  , eventSource
  , jsForAPI
  )
where

import           Control.Lens
import           Data.Binary.Builder            ( toLazyByteString )
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup
#endif
import           Data.Text                      ( Text )
import qualified Data.Text                     as T
import           GHC.Generics                   ( Generic )
import           Network.HTTP.Media             ( (//)
                                                , (/:)
                                                )
import           Network.Wai.EventSource        ( ServerEvent(..) )
import           Network.Wai.EventSource.EventStream
                                                ( eventToBuilder )
import qualified Pipes
import           Pipes                          ( X
                                                , (>->)
                                                , await
                                                , yield
                                                )
import           Servant
import           Servant.Foreign
import           Servant.Foreign.Internal       ( _FunctionName )
import           Servant.JS.Internal
import           Servant.Pipes                  ( pipesToSourceIO )

newtype ServerSentEvents
  = ServerSentEvents (StreamGet NoFraming EventStream EventSourceHdr)
  deriving ((forall x. ServerSentEvents -> Rep ServerSentEvents x)
-> (forall x. Rep ServerSentEvents x -> ServerSentEvents)
-> Generic ServerSentEvents
forall x. Rep ServerSentEvents x -> ServerSentEvents
forall x. ServerSentEvents -> Rep ServerSentEvents x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ServerSentEvents x -> ServerSentEvents
$cfrom :: forall x. ServerSentEvents -> Rep ServerSentEvents x
Generic, (Link -> a)
-> Proxy ServerSentEvents -> Link -> MkLink ServerSentEvents a
(forall a.
 (Link -> a)
 -> Proxy ServerSentEvents -> Link -> MkLink ServerSentEvents a)
-> HasLink ServerSentEvents
forall a.
(Link -> a)
-> Proxy ServerSentEvents -> Link -> MkLink ServerSentEvents a
forall k (endpoint :: k).
(forall a.
 (Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a)
-> HasLink endpoint
toLink :: (Link -> a)
-> Proxy ServerSentEvents -> Link -> MkLink ServerSentEvents a
$ctoLink :: forall a.
(Link -> a)
-> Proxy ServerSentEvents -> Link -> MkLink ServerSentEvents a
HasLink)

instance HasServer ServerSentEvents context where
  type ServerT ServerSentEvents m = ServerT (StreamGet NoFraming EventStream EventSourceHdr) m
  route :: Proxy ServerSentEvents
-> Context context
-> Delayed env (Server ServerSentEvents)
-> Router env
route Proxy ServerSentEvents
Proxy = Proxy (StreamGet NoFraming EventStream EventSourceHdr)
-> Context context
-> Delayed
     env (Server (StreamGet NoFraming EventStream EventSourceHdr))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route
    (Proxy (StreamGet NoFraming EventStream EventSourceHdr)
forall k (t :: k). Proxy t
Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr))
  hoistServerWithContext :: Proxy ServerSentEvents
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT ServerSentEvents m
-> ServerT ServerSentEvents n
hoistServerWithContext Proxy ServerSentEvents
Proxy = Proxy (StreamGet NoFraming EventStream EventSourceHdr)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (StreamGet NoFraming EventStream EventSourceHdr) m
-> ServerT (StreamGet NoFraming EventStream EventSourceHdr) 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
hoistServerWithContext
    (Proxy (StreamGet NoFraming EventStream EventSourceHdr)
forall k (t :: k). Proxy t
Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr))

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

  foreignFor :: Proxy lang
-> Proxy ftype
-> Proxy ServerSentEvents
-> Req ftype
-> Foreign ftype ServerSentEvents
foreignFor Proxy lang
lang Proxy ftype
Proxy Proxy ServerSentEvents
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 f. Lens' (Req f) FunctionName
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 f. Lens' (Req f) Method
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 f. Lens' (Req f) (Maybe f)
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 EventSourceHdr -> 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 EventSourceHdr
forall k (t :: k). Proxy t
Proxy :: Proxy EventSourceHdr)
    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")

type EventSource = SourceIO ServerEvent

-- | This is mostly to guide reverse-proxies like 
--   <https://www.nginx.com/resources/wiki/start/topics/examples/x-accel/#x-accel-buffering nginx>
type EventSourceHdr = Headers '[Header "X-Accel-Buffering" Text] EventSource

-- | See details at
--   https://hackage.haskell.org/package/wai-extra-3.1.6/docs/Network-Wai-EventSource-EventStream.html#v:eventToBuilder
instance MimeRender EventStream ServerEvent where
  mimeRender :: Proxy EventStream -> ServerEvent -> ByteString
mimeRender Proxy EventStream
_ = ByteString
-> (Builder -> ByteString) -> Maybe Builder -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" Builder -> ByteString
toLazyByteString (Maybe Builder -> ByteString)
-> (ServerEvent -> Maybe Builder) -> ServerEvent -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerEvent -> Maybe Builder
eventToBuilder

eventSource :: Pipes.Proxy X () () ServerEvent IO () -> EventSourceHdr
eventSource :: Proxy X () () ServerEvent IO () -> EventSourceHdr
eventSource Proxy X () () ServerEvent IO ()
prod = Text -> SourceIO ServerEvent -> EventSourceHdr
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader Text
"no" (SourceIO ServerEvent -> EventSourceHdr)
-> SourceIO ServerEvent -> EventSourceHdr
forall a b. (a -> b) -> a -> b
$ Proxy X () () ServerEvent IO () -> SourceIO ServerEvent
forall (m :: * -> *) b.
PipesToSourceIO m =>
Proxy X () () b m () -> SourceIO b
pipesToSourceIO (Proxy X () () ServerEvent IO ()
prod Proxy X () () ServerEvent IO ()
-> Proxy () ServerEvent () ServerEvent IO ()
-> Proxy X () () ServerEvent IO ()
forall (m :: * -> *) a' a b r c' c.
Functor m =>
Proxy a' a () b m r -> Proxy () b c' c m r -> Proxy a' a c' c m r
>-> Proxy () ServerEvent () ServerEvent IO ()
yieldUntilClose)
 where
  yieldUntilClose :: Proxy () ServerEvent () ServerEvent IO ()
yieldUntilClose = do
    ServerEvent
e <- Proxy () ServerEvent () ServerEvent IO ServerEvent
forall (m :: * -> *) a. Functor m => Consumer' a m a
await
    case ServerEvent
e of
      ServerEvent
CloseEvent -> () -> Proxy () ServerEvent () ServerEvent IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ServerEvent
_          -> ServerEvent -> Proxy () ServerEvent () ServerEvent IO ()
forall (m :: * -> *) a x' x. Functor m => a -> Proxy x' x () a m ()
yield ServerEvent
e Proxy () ServerEvent () ServerEvent IO ()
-> Proxy () ServerEvent () ServerEvent IO ()
-> Proxy () ServerEvent () ServerEvent IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Proxy () ServerEvent () ServerEvent IO ()
yieldUntilClose

jsForAPI
  :: ( HasForeign NoTypes NoContent api
     , GenerateList NoContent (Foreign NoContent api)
     )
  => Proxy api
  -> Text
jsForAPI :: Proxy api -> Text
jsForAPI Proxy api
p = [Req NoContent] -> Text
gen
  (Proxy NoTypes -> Proxy NoContent -> Proxy api -> [Req NoContent]
forall k (lang :: k) ftype api.
(HasForeign lang ftype api,
 GenerateList ftype (Foreign ftype api)) =>
Proxy lang -> Proxy ftype -> Proxy api -> [Req ftype]
listFromAPI (Proxy NoTypes
forall k (t :: k). Proxy t
Proxy :: Proxy NoTypes) (Proxy NoContent
forall k (t :: k). Proxy t
Proxy :: Proxy NoContent) Proxy api
p)
 where
  gen :: [Req NoContent] -> Text
  gen :: [Req NoContent] -> Text
gen = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text)
-> ([Req NoContent] -> [Text]) -> [Req NoContent] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Req NoContent -> Text) -> [Req NoContent] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Req NoContent -> Text
genEventSource

  genEventSource :: Req NoContent -> Text
  genEventSource :: Req NoContent -> Text
genEventSource Req NoContent
req = [Text] -> Text
T.unlines
    [ Text
""
    , Text
fname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = function(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
argsStr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    , Text
"{"
    , Text
"  s = new EventSource(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", conf);"
    , Text
"  Object.entries(eventListeners).forEach(([ev, cb]) => s.addEventListener(ev, cb));"
    , Text
"  return s;"
    , Text
"}"
    ]
   where
    argsStr :: Text
argsStr = Text -> [Text] -> Text
T.intercalate Text
", " [Text]
args
    args :: [Text]
args = [Text]
captures
        [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (QueryArg NoContent -> Text) -> [QueryArg NoContent] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Getting Text (QueryArg NoContent) Text
-> QueryArg NoContent -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Text (QueryArg NoContent) Text
 -> QueryArg NoContent -> Text)
-> Getting Text (QueryArg NoContent) Text
-> QueryArg NoContent
-> Text
forall a b. (a -> b) -> a -> b
$ (Arg NoContent -> Const Text (Arg NoContent))
-> QueryArg NoContent -> Const Text (QueryArg NoContent)
forall f1 f2. Lens (QueryArg f1) (QueryArg f2) (Arg f1) (Arg f2)
queryArgName ((Arg NoContent -> Const Text (Arg NoContent))
 -> QueryArg NoContent -> Const Text (QueryArg NoContent))
-> ((Text -> Const Text Text)
    -> Arg NoContent -> Const Text (Arg NoContent))
-> Getting Text (QueryArg NoContent) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> Arg NoContent -> Const Text (Arg NoContent)
forall f. Getter (Arg f) Text
argPath) [QueryArg NoContent]
queryparams
        [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"eventListeners = {}", Text
"conf"]

    captures :: [Text]
captures = (Segment NoContent -> Text) -> [Segment NoContent] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (((Text -> Const Text Text)
 -> Arg NoContent -> Const Text (Arg NoContent))
-> Arg NoContent -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Text -> Const Text Text)
-> Arg NoContent -> Const Text (Arg NoContent)
forall f. Getter (Arg f) Text
argPath (Arg NoContent -> Text)
-> (Segment NoContent -> Arg NoContent)
-> Segment NoContent
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment NoContent -> Arg NoContent
forall f. Segment f -> Arg f
captureArg)
              ([Segment NoContent] -> [Text])
-> ([Segment NoContent] -> [Segment NoContent])
-> [Segment NoContent]
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Segment NoContent -> Bool)
-> [Segment NoContent] -> [Segment NoContent]
forall a. (a -> Bool) -> [a] -> [a]
filter Segment NoContent -> Bool
forall f. Segment f -> Bool
isCapture
              ([Segment NoContent] -> [Text]) -> [Segment NoContent] -> [Text]
forall a b. (a -> b) -> a -> b
$ Req NoContent
req Req NoContent
-> Getting [Segment NoContent] (Req NoContent) [Segment NoContent]
-> [Segment NoContent]
forall s a. s -> Getting a s a -> a
^. (Url NoContent -> Const [Segment NoContent] (Url NoContent))
-> Req NoContent -> Const [Segment NoContent] (Req NoContent)
forall f. Lens' (Req f) (Url f)
reqUrl((Url NoContent -> Const [Segment NoContent] (Url NoContent))
 -> Req NoContent -> Const [Segment NoContent] (Req NoContent))
-> (([Segment NoContent]
     -> Const [Segment NoContent] [Segment NoContent])
    -> Url NoContent -> Const [Segment NoContent] (Url NoContent))
-> Getting [Segment NoContent] (Req NoContent) [Segment NoContent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Segment NoContent]
 -> Const [Segment NoContent] [Segment NoContent])
-> Url NoContent -> Const [Segment NoContent] (Url NoContent)
forall f. Lens' (Url f) (Path f)
path

    queryparams :: [QueryArg NoContent]
queryparams = Req NoContent
req Req NoContent
-> Getting
     (Endo [QueryArg NoContent]) (Req NoContent) (QueryArg NoContent)
-> [QueryArg NoContent]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Url NoContent
 -> Const (Endo [QueryArg NoContent]) (Url NoContent))
-> Req NoContent
-> Const (Endo [QueryArg NoContent]) (Req NoContent)
forall f. Lens' (Req f) (Url f)
reqUrl((Url NoContent
  -> Const (Endo [QueryArg NoContent]) (Url NoContent))
 -> Req NoContent
 -> Const (Endo [QueryArg NoContent]) (Req NoContent))
-> ((QueryArg NoContent
     -> Const (Endo [QueryArg NoContent]) (QueryArg NoContent))
    -> Url NoContent
    -> Const (Endo [QueryArg NoContent]) (Url NoContent))
-> Getting
     (Endo [QueryArg NoContent]) (Req NoContent) (QueryArg NoContent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([QueryArg NoContent]
 -> Const (Endo [QueryArg NoContent]) [QueryArg NoContent])
-> Url NoContent
-> Const (Endo [QueryArg NoContent]) (Url NoContent)
forall f. Lens' (Url f) [QueryArg f]
queryStr(([QueryArg NoContent]
  -> Const (Endo [QueryArg NoContent]) [QueryArg NoContent])
 -> Url NoContent
 -> Const (Endo [QueryArg NoContent]) (Url NoContent))
-> ((QueryArg NoContent
     -> Const (Endo [QueryArg NoContent]) (QueryArg NoContent))
    -> [QueryArg NoContent]
    -> Const (Endo [QueryArg NoContent]) [QueryArg NoContent])
-> (QueryArg NoContent
    -> Const (Endo [QueryArg NoContent]) (QueryArg NoContent))
-> Url NoContent
-> Const (Endo [QueryArg NoContent]) (Url NoContent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(QueryArg NoContent
 -> Const (Endo [QueryArg NoContent]) (QueryArg NoContent))
-> [QueryArg NoContent]
-> Const (Endo [QueryArg NoContent]) [QueryArg NoContent]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse

    fname :: Text
fname   = Text
"var " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
toValidFunctionName (FunctionName -> Text
camelCase (FunctionName -> Text) -> FunctionName -> Text
forall a b. (a -> b) -> a -> b
$ Req NoContent
req Req NoContent
-> Getting FunctionName (Req NoContent) FunctionName
-> FunctionName
forall s a. s -> Getting a s a -> a
^. Getting FunctionName (Req NoContent) FunctionName
forall f. Lens' (Req f) FunctionName
reqFuncName)
    url :: Text
url     = if Text
url' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"'" then Text
"'/'" else Text
url'
    url' :: Text
url'    = Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
urlArgs
    urlArgs :: Text
urlArgs = [Segment NoContent] -> Text
forall f. [Segment f] -> Text
jsSegments ([Segment NoContent] -> Text) -> [Segment NoContent] -> Text
forall a b. (a -> b) -> a -> b
$ Req NoContent
req Req NoContent
-> Getting
     (Endo [Segment NoContent]) (Req NoContent) (Segment NoContent)
-> [Segment NoContent]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Url NoContent -> Const (Endo [Segment NoContent]) (Url NoContent))
-> Req NoContent
-> Const (Endo [Segment NoContent]) (Req NoContent)
forall f. Lens' (Req f) (Url f)
reqUrl ((Url NoContent
  -> Const (Endo [Segment NoContent]) (Url NoContent))
 -> Req NoContent
 -> Const (Endo [Segment NoContent]) (Req NoContent))
-> ((Segment NoContent
     -> Const (Endo [Segment NoContent]) (Segment NoContent))
    -> Url NoContent
    -> Const (Endo [Segment NoContent]) (Url NoContent))
-> Getting
     (Endo [Segment NoContent]) (Req NoContent) (Segment NoContent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Segment NoContent]
 -> Const (Endo [Segment NoContent]) [Segment NoContent])
-> Url NoContent
-> Const (Endo [Segment NoContent]) (Url NoContent)
forall f. Lens' (Url f) (Path f)
path (([Segment NoContent]
  -> Const (Endo [Segment NoContent]) [Segment NoContent])
 -> Url NoContent
 -> Const (Endo [Segment NoContent]) (Url NoContent))
-> ((Segment NoContent
     -> Const (Endo [Segment NoContent]) (Segment NoContent))
    -> [Segment NoContent]
    -> Const (Endo [Segment NoContent]) [Segment NoContent])
-> (Segment NoContent
    -> Const (Endo [Segment NoContent]) (Segment NoContent))
-> Url NoContent
-> Const (Endo [Segment NoContent]) (Url NoContent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Segment NoContent
 -> Const (Endo [Segment NoContent]) (Segment NoContent))
-> [Segment NoContent]
-> Const (Endo [Segment NoContent]) [Segment NoContent]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse