{-# 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 (Generic, HasLink)
instance HasServer ServerSentEvents context where
type ServerT ServerSentEvents m = ServerT (StreamGet NoFraming EventStream EventSourceHdr) m
route Proxy = route
(Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr))
hoistServerWithContext Proxy = hoistServerWithContext
(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 lang Proxy Proxy req =
req
& reqFuncName . _FunctionName %~ ("stream" :)
& reqMethod .~ method
& reqReturnType ?~ retType
where
retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy EventSourceHdr)
method = reflectMethod (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 _ = "text" // "event-stream" /: ("charset", "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 _ = maybe "" toLazyByteString . eventToBuilder
eventSource :: Pipes.Proxy X () () ServerEvent IO () -> EventSourceHdr
eventSource prod = addHeader "no" $ pipesToSourceIO (prod >-> yieldUntilClose)
where
yieldUntilClose = do
e <- await
case e of
CloseEvent -> return ()
_ -> yield e >> yieldUntilClose
jsForAPI
:: ( HasForeign NoTypes NoContent api
, GenerateList NoContent (Foreign NoContent api)
)
=> Proxy api
-> Text
jsForAPI p = gen
(listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy NoContent) p)
where
gen :: [Req NoContent] -> Text
gen = mconcat . map genEventSource
genEventSource :: Req NoContent -> Text
genEventSource req = T.unlines
[ ""
, fname <> " = function(" <> argsStr <> ")"
, "{"
, " s = new EventSource(" <> url <> ", conf);"
, " Object.entries(eventListeners).forEach(([ev, cb]) => s.addEventListener(ev, cb));"
, " return s;"
, "}"
]
where
argsStr = T.intercalate ", " args
args = captures
++ map (view $ queryArgName . argPath) queryparams
++ ["eventListeners = {}", "conf"]
captures = map (view argPath . captureArg)
. filter isCapture
$ req ^. reqUrl.path
queryparams = req ^.. reqUrl.queryStr.traverse
fname = "var " <> toValidFunctionName (camelCase $ req ^. reqFuncName)
url = if url' == "'" then "'/'" else url'
url' = "'" <> urlArgs
urlArgs = jsSegments $ req ^.. reqUrl . path . traverse