servant-event-stream 0.2.1.0 → 0.3.0.0

raw patch · 4 files changed

+203/−158 lines, 4 filesdep +attoparsecdep +bytestringdep −pipesdep −servant-jsdep −servant-pipesdep ~basedep ~binarydep ~lensPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, bytestring

Dependencies removed: pipes, servant-js, servant-pipes

Dependency ranges changed: base, binary, lens, servant-foreign, servant-server, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−0
• README.md +5/−5
• servant-event-stream.cabal +34/−41
• src/Servant/API/EventStream.hs +144/−112

@@ -1,5 +1,25 @@ # Revision history for servant-event-stream +## 0.3.0.0 -- 2024-09-05++* Breaking changes to the API.++    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, ...]+ ## 0.2.1.0 -- 2021-04-21  * Import `Data.Semigroup` for base < 4.11.0

@@ -4,17 +4,17 @@ This library adds necessary type combinators to support [Server Sent Events](https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events) within [Servant ecosystem](https://github.com/haskell-servant/). -Dev Environment----------------+Development Environment+----------------------- -Dev env is based on [Nix](https://nixos.org) and [Niv](https://github.com/nmattia/niv).+Development environment uses [Nix](https://nixos.org) flakes.  To enter the dev shell, run ```bash-nix-shell+nix develop ```  You can build the project with ```bash-nix-build+nix build ```

@@ -1,22 +1,21 @@-cabal-version:       >=1.10-name:                servant-event-stream-version:             0.2.1.0-stability:           alpha--synopsis:            Servant support for Server-Sent events-category:            Servant, Web-description:         This library adds necessary type combinators to support-                     Server Sent Events within Servant ecosystem.--homepage:            https://github.com/bflyblue/servant-event-stream-bug-reports:         https://github.com/bflyblue/servant-event-stream/issues-license:             BSD3-license-file:        LICENSE-author:              Shaun Sharples-maintainer:          shaun.sharples@gmail.com-copyright:           (c) 2021 Shaun Sharples-build-type:          Simple+cabal-version: >=1.10+name: servant-event-stream+version: 0.3.0.0+stability: alpha+synopsis: Servant support for Server-Sent events+category: Servant, Web+description:+  This library adds necessary type combinators to support+  Server Sent Events within Servant ecosystem. +homepage: https://github.com/bflyblue/servant-event-stream+bug-reports: https://github.com/bflyblue/servant-event-stream/issues+license: BSD3+license-file: LICENSE+author: Shaun Sharples+maintainer: shaun.sharples@gmail.com+copyright: (c) 2024 Shaun Sharples+build-type: Simple extra-source-files:   CHANGELOG.md   README.md@@ -26,36 +25,30 @@   location: https://github.com/bflyblue/servant-event-stream.git  library-  exposed-modules:-    Servant.API.EventStream-+  exposed-modules: Servant.API.EventStream   default-extensions:     MultiParamTypeClasses     OverloadedStrings    build-depends:-      base                  >= 4.9 && < 4.15-    , binary                >= 0.7 && < 0.11-    , http-media            >= 0.7.1.3 && < 0.9-    , lens                  >= 4.17 && < 4.20-    , pipes                 >= 4.3.9 && < 4.4-    , servant-foreign       >= 0.15 && < 0.16-    , servant-js            >= 0.9 && < 0.10-    , servant-pipes         >= 0.15 && < 0.16-    , servant-server        >= 0.15 && < 0.19-    , text                  >= 1.2.3 && < 1.3-    , wai-extra             >= 3.0 && < 3.2+    attoparsec >=0.14 && <0.15,+    base >=4.10 && <4.20,+    binary >=0.8 && <0.9,+    bytestring >=0.11.1.0 && <0.13,+    http-media >=0.7.1.3 && <0.9,+    lens >=4.17 && <5.4,+    servant-foreign >=0.15 && <0.17,+    servant-server >=0.15 && <0.21,+    text >=1.2.3 && <2.2,+    wai-extra >=3.0 && <3.2 -  hs-source-dirs:      src-  default-language:    Haskell2010-  ghc-options:         -Wall+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall  test-suite tests-default   type: exitcode-stdio-1.0   main-is: Spec.hs-  hs-source-dirs:-    tests-  default-language:-    Haskell2010-  build-depends:-    base+  hs-source-dirs: tests+  default-language: Haskell2010+  build-depends: base

@@ -1,138 +1,170 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PolyKinds                  #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -module Servant.API.EventStream-  ( ServerSentEvents-  , EventStream-  , EventSource-  , EventSourceHdr-  , eventSource-  , jsForAPI-  )+module Servant.API.EventStream (+  ServerEvent (..),+  ToServerEvent (..),+  ServerSentEvents,+  EventStream,+  RecommendedEventSourceHeaders,+  recommendedEventSourceHeaders,+) where -import           Control.Lens-import           Data.Binary.Builder            ( toLazyByteString )+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+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 )+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) -newtype ServerSentEvents-  = ServerSentEvents (StreamGet NoFraming EventStream EventSourceHdr)-  deriving (Generic, HasLink)+{- | 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, Generic) -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))+instance HasLink (ServerSentEvents a) where+  type MkLink (ServerSentEvents a) r = r+  toLink toA _ = toA +-- | Represents an event sent from the server to the client in Server-Sent Events (SSE).+data ServerEvent = ServerEvent+  { eventType :: !(Maybe LBS.ByteString)+  -- ^ Optional field specifying the type of event. Can be used to distinguish between different kinds of events.+  , eventId :: !(Maybe LBS.ByteString)+  -- ^ Optional field providing an identifier for the event. Useful for clients to keep track of the last received event.+  , eventData :: !LBS.ByteString+  -- ^ The payload or content of the event. This is the main data sent to the client.+  }+  deriving (Show, Eq, 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 _ = encodeServerEvent . toServerEvent++instance ToServerEvent ServerEvent where+  toServerEvent = 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 Proxy =+    route+      (Proxy :: Proxy (StreamGet ServerEventFraming EventStream a))+  hoistServerWithContext Proxy =+    hoistServerWithContext+      (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 Proxy =+    route+      (Proxy :: Proxy (StreamGet ServerEventFraming EventStream (Headers h a)))+  hoistServerWithContext Proxy =+    hoistServerWithContext+      (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 EventSourceHdr)-  => HasForeign lang ftype ServerSentEvents where-  type Foreign ftype ServerSentEvents = Req ftype+instance+  (HasForeignType lang ftype a) =>+  HasForeign lang ftype (ServerSentEvents a)+  where+  type Foreign ftype (ServerSentEvents a) = Req ftype    foreignFor lang Proxy Proxy req =     req-      &  reqFuncName .  _FunctionName %~ ("stream" :)-      &  reqMethod .~ method-      &  reqReturnType ?~ retType+      & reqFuncName . _FunctionName %~ ("stream" :)+      & reqMethod .~ method+      & reqReturnType ?~ retType    where-    retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy EventSourceHdr)-    method  = reflectMethod (Proxy :: Proxy 'GET)+    retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a)+    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>+{- | 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+{- | This is mostly to guide reverse-proxies like+  <https://www.nginx.com/resources/wiki/start/topics/examples/x-accel/#x-accel-buffering nginx> --- | 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+  Example: -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+  > 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 -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+-- | Add the recommended headers for Server-Sent Events to the response.+recommendedEventSourceHeaders :: a -> RecommendedEventSourceHeaders a+recommendedEventSourceHeaders = addHeader @"X-Accel-Buffering" "no" . addHeader @"Cache-Control" "no-store" -  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"]+data ServerEventFraming -    captures = map (view argPath . captureArg)-              . filter isCapture-              $ req ^. reqUrl.path+instance FramingRender ServerEventFraming where+  framingRender _ f = fmap (\x -> f x <> "\n") -    queryparams = req ^.. reqUrl.queryStr.traverse+{- 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 e =+  optional "event:" (eventType e)+    <> optional "id:" (eventId e)+    <> mconcat (map (field "data:") (safelines (eventData e)))+ where+  optional name = maybe mempty (field name)+  field name val = name <> val <> "\n" -    fname   = "var " <> toValidFunctionName (camelCase $ req ^. reqFuncName)-    url     = if url' == "'" then "'/'" else url'-    url'    = "'" <> urlArgs-    urlArgs = jsSegments $ req ^.. reqUrl . path . traverse+  -- discard CR and split LFs into multiple data values+  safelines = C8.lines . C8.filter (/= '\r')