{-# 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 )
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))
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)
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
type EventSourceHdr = Headers '[Header "X-Accel-Buffering" Text] EventSource
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