From 385816c0d32cd0f18dba06c21e2d52800759abf9 Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 19 Oct 2023 10:18:08 +0200 Subject: [PATCH 01/11] Get it to build on GHC 9.6 and servant 0.20. - dropped dependency on servant-js, as it depends on servant <0.20: * jsForAPI was removed - dropped dependency on servant-pipes * prefer use of SourceIO rather than depend on a particular implementation using pipes * eventSource changed from `eventSource :: Pipes.Proxy X () () ServerEvent IO () -> EventSourceHdr` to `eventSource :: EventSource -> EventSourceHdr` - bumped pinned versions using niv for nix --- nix/sources.json | 12 ++--- servant-event-stream.cabal | 83 +++++++++++++++------------------- servant-event-stream.nix | 18 +++++--- src/Servant/API/EventStream.hs | 59 +----------------------- 4 files changed, 56 insertions(+), 116 deletions(-) diff --git a/nix/sources.json b/nix/sources.json index 9247caf..c08f570 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -5,10 +5,10 @@ "homepage": "https://github.com/nmattia/niv", "owner": "nmattia", "repo": "niv", - "rev": "af958e8057f345ee1aca714c1247ef3ba1c15f5e", - "sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n", + "rev": "723f0eeb969a730db3c30f977c2b66b9dce9fe4a", + "sha256": "0016l7230gd2kdh0g2w573r9a2krqb7x4ifcjhhsn4h1bwap7qr0", "type": "tarball", - "url": "https://github.com/nmattia/niv/archive/af958e8057f345ee1aca714c1247ef3ba1c15f5e.tar.gz", + "url": "https://github.com/nmattia/niv/archive/723f0eeb969a730db3c30f977c2b66b9dce9fe4a.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, "nixpkgs": { @@ -17,10 +17,10 @@ "homepage": "", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e5cc06a1e806070693add4f231060a62b962fc44", - "sha256": "04543i332fx9m7jf6167ac825s4qb8is0d0x0pz39il979mlc87v", + "rev": "ca012a02bf8327be9e488546faecae5e05d7d749", + "sha256": "1nlxb2jldq51mnb0japs5pqi82msrginm0kjhsgbzrlvpag9525f", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/e5cc06a1e806070693add4f231060a62b962fc44.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/ca012a02bf8327be9e488546faecae5e05d7d749.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/servant-event-stream.cabal b/servant-event-stream.cabal index eb1a4dc..4736393 100644 --- a/servant-event-stream.cabal +++ b/servant-event-stream.cabal @@ -1,61 +1,52 @@ -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) 2023 Shaun Sharples +build-type: Simple extra-source-files: CHANGELOG.md README.md source-repository head - type: git + type: git 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.10 && < 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.4 && < 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 - - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + base >=4.10 && <4.19 + , binary >=0.7 && <0.11 + , http-media >=0.7.1.3 && <0.9 + , lens >=4.17 && <5.3 + , 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 test-suite tests-default - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: - tests - default-language: - Haskell2010 - build-depends: - base \ No newline at end of file + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + default-language: Haskell2010 + build-depends: base diff --git a/servant-event-stream.nix b/servant-event-stream.nix index 3f81189..ff3ba9d 100644 --- a/servant-event-stream.nix +++ b/servant-event-stream.nix @@ -1,18 +1,22 @@ let sources = import ./nix/sources.nix; pkgs = import sources.nixpkgs { inherit config; }; - compilerVersion = "ghc8104"; + compilerVersion = "ghc96"; compilerSet = pkgs.haskell.packages."${compilerVersion}"; gitIgnore = pkgs.nix-gitignore.gitignoreSourcePure; config = { - packageOverrides = super: let self = super.pkgs; in rec { - haskell = super.haskell // { - packageOverrides = with pkgs.haskell.lib; self: super: { - servant-event-stream = super.callCabal2nix "servant-event-stream" (gitIgnore [./.gitignore] ./.) {}; - servant-js = markUnbroken (doJailbreak super.servant-js); + packageOverrides = super: + let self = super.pkgs; + in rec { + haskell = super.haskell // { + packageOverrides = with pkgs.haskell.lib; + self: super: { + servant-event-stream = super.callCabal2nix "servant-event-stream" + (gitIgnore [ ./.gitignore ] ./.) { }; + servant-foreign = dontCheck super.servant-foreign; + }; }; }; - }; }; in { diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs index 12d192d..8850250 100644 --- a/src/Servant/API/EventStream.hs +++ b/src/Servant/API/EventStream.hs @@ -15,7 +15,6 @@ module Servant.API.EventStream , EventSource , EventSourceHdr , eventSource - , jsForAPI ) where @@ -25,7 +24,6 @@ import Data.Binary.Builder ( toLazyByteString ) import Data.Semigroup #endif import Data.Text ( Text ) -import qualified Data.Text as T import GHC.Generics ( Generic ) import Network.HTTP.Media ( (//) , (/:) @@ -33,17 +31,9 @@ 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) @@ -89,50 +79,5 @@ type EventSourceHdr = Headers '[Header "X-Accel-Buffering" Text] EventSource 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 +eventSource :: EventSource -> EventSourceHdr +eventSource = addHeader "no" From 13c62f03a66e5a3d68efcfe4fb090d1572e61fa7 Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 19 Oct 2023 10:40:17 +0200 Subject: [PATCH 02/11] updated to use nix flakes --- default.nix | 1 - flake.lock | 26 ++++++ flake.nix | 42 ++++++++++ nix/sources.json | 26 ------ nix/sources.nix | 174 --------------------------------------- servant-event-stream.nix | 32 ------- shell.nix | 1 - 7 files changed, 68 insertions(+), 234 deletions(-) delete mode 100644 default.nix create mode 100644 flake.lock create mode 100644 flake.nix delete mode 100644 nix/sources.json delete mode 100644 nix/sources.nix delete mode 100644 servant-event-stream.nix delete mode 100644 shell.nix diff --git a/default.nix b/default.nix deleted file mode 100644 index 29e1fbd..0000000 --- a/default.nix +++ /dev/null @@ -1 +0,0 @@ -(import ./servant-event-stream.nix).servant-event-stream diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..8f85863 --- /dev/null +++ b/flake.lock @@ -0,0 +1,26 @@ +{ + "nodes": { + "nixpkgs": { + "locked": { + "lastModified": 1697703837, + "narHash": "sha256-7zov8gJlmLF62OHhEpc+PDLreIZaBv/4nlHfyws9SHA=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "4a2788ea2ad7f1607f272c829f37e79a396b4d1a", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..3ac8ea2 --- /dev/null +++ b/flake.nix @@ -0,0 +1,42 @@ +{ + description = "servant-event-stream"; + + inputs = { nixpkgs.url = "github:nixos/nixpkgs"; }; + + outputs = { self, nixpkgs, ... }: + let + supportedSystems = [ "x86_64-linux" ]; + forallSystems = f: + nixpkgs.lib.genAttrs supportedSystems (system: + f (rec { + inherit system; + pkgs = nixpkgsFor system; + haskellPackages = hpkgsFor pkgs; + })); + nixpkgsFor = system: import nixpkgs { inherit system; }; + hpkgsFor = pkgs: + with pkgs.haskell.lib; + pkgs.haskell.packages.ghc96.override { + overrides = self: super: { + servant-foreign = dontCheck super.servant-foreign; + }; + }; + in { + packages = forallSystems ({ system, pkgs, haskellPackages }: { + servant-event-stream = + haskellPackages.callCabal2nix "servant-event-stream" ./. { }; + default = self.packages.${system}.servant-event-stream; + }); + devShells = forallSystems ({ system, pkgs, haskellPackages }: { + servant-event-stream = haskellPackages.shellFor { + packages = p: [ self.packages.${system}.servant-event-stream ]; + buildInputs = with haskellPackages; [ + cabal-install + haskell-language-server + ]; + withHoogle = true; + }; + default = self.devShells.${system}.servant-event-stream; + }); + }; +} diff --git a/nix/sources.json b/nix/sources.json deleted file mode 100644 index c08f570..0000000 --- a/nix/sources.json +++ /dev/null @@ -1,26 +0,0 @@ -{ - "niv": { - "branch": "master", - "description": "Easy dependency management for Nix projects", - "homepage": "https://github.com/nmattia/niv", - "owner": "nmattia", - "repo": "niv", - "rev": "723f0eeb969a730db3c30f977c2b66b9dce9fe4a", - "sha256": "0016l7230gd2kdh0g2w573r9a2krqb7x4ifcjhhsn4h1bwap7qr0", - "type": "tarball", - "url": "https://github.com/nmattia/niv/archive/723f0eeb969a730db3c30f977c2b66b9dce9fe4a.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, - "nixpkgs": { - "branch": "nixos-unstable", - "description": "Nix Packages collection", - "homepage": "", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "ca012a02bf8327be9e488546faecae5e05d7d749", - "sha256": "1nlxb2jldq51mnb0japs5pqi82msrginm0kjhsgbzrlvpag9525f", - "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/ca012a02bf8327be9e488546faecae5e05d7d749.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - } -} diff --git a/nix/sources.nix b/nix/sources.nix deleted file mode 100644 index 1938409..0000000 --- a/nix/sources.nix +++ /dev/null @@ -1,174 +0,0 @@ -# This file has been generated by Niv. - -let - - # - # The fetchers. fetch_ fetches specs of type . - # - - fetch_file = pkgs: name: spec: - let - name' = sanitizeName name + "-src"; - in - if spec.builtin or true then - builtins_fetchurl { inherit (spec) url sha256; name = name'; } - else - pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; - - fetch_tarball = pkgs: name: spec: - let - name' = sanitizeName name + "-src"; - in - if spec.builtin or true then - builtins_fetchTarball { name = name'; inherit (spec) url sha256; } - else - pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; - - fetch_git = name: spec: - let - ref = - if spec ? ref then spec.ref else - if spec ? branch then "refs/heads/${spec.branch}" else - if spec ? tag then "refs/tags/${spec.tag}" else - abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; - in - builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; - - fetch_local = spec: spec.path; - - fetch_builtin-tarball = name: throw - ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. - $ niv modify ${name} -a type=tarball -a builtin=true''; - - fetch_builtin-url = name: throw - ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. - $ niv modify ${name} -a type=file -a builtin=true''; - - # - # Various helpers - # - - # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 - sanitizeName = name: - ( - concatMapStrings (s: if builtins.isList s then "-" else s) - ( - builtins.split "[^[:alnum:]+._?=-]+" - ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) - ) - ); - - # The set of packages used when specs are fetched using non-builtins. - mkPkgs = sources: system: - let - sourcesNixpkgs = - import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; - hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; - hasThisAsNixpkgsPath = == ./.; - in - if builtins.hasAttr "nixpkgs" sources - then sourcesNixpkgs - else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then - import {} - else - abort - '' - Please specify either (through -I or NIX_PATH=nixpkgs=...) or - add a package called "nixpkgs" to your sources.json. - ''; - - # The actual fetching function. - fetch = pkgs: name: spec: - - if ! builtins.hasAttr "type" spec then - abort "ERROR: niv spec ${name} does not have a 'type' attribute" - else if spec.type == "file" then fetch_file pkgs name spec - else if spec.type == "tarball" then fetch_tarball pkgs name spec - else if spec.type == "git" then fetch_git name spec - else if spec.type == "local" then fetch_local spec - else if spec.type == "builtin-tarball" then fetch_builtin-tarball name - else if spec.type == "builtin-url" then fetch_builtin-url name - else - abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; - - # If the environment variable NIV_OVERRIDE_${name} is set, then use - # the path directly as opposed to the fetched source. - replace = name: drv: - let - saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; - ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; - in - if ersatz == "" then drv else - # this turns the string into an actual Nix path (for both absolute and - # relative paths) - if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; - - # Ports of functions for older nix versions - - # a Nix version of mapAttrs if the built-in doesn't exist - mapAttrs = builtins.mapAttrs or ( - f: set: with builtins; - listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) - ); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 - range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 - stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 - stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); - concatMapStrings = f: list: concatStrings (map f list); - concatStrings = builtins.concatStringsSep ""; - - # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 - optionalAttrs = cond: as: if cond then as else {}; - - # fetchTarball version that is compatible between all the versions of Nix - builtins_fetchTarball = { url, name ? null, sha256 }@attrs: - let - inherit (builtins) lessThan nixVersion fetchTarball; - in - if lessThan nixVersion "1.12" then - fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchTarball attrs; - - # fetchurl version that is compatible between all the versions of Nix - builtins_fetchurl = { url, name ? null, sha256 }@attrs: - let - inherit (builtins) lessThan nixVersion fetchurl; - in - if lessThan nixVersion "1.12" then - fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchurl attrs; - - # Create the final "sources" from the config - mkSources = config: - mapAttrs ( - name: spec: - if builtins.hasAttr "outPath" spec - then abort - "The values in sources.json should not have an 'outPath' attribute" - else - spec // { outPath = replace name (fetch config.pkgs name spec); } - ) config.sources; - - # The "config" used by the fetchers - mkConfig = - { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null - , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) - , system ? builtins.currentSystem - , pkgs ? mkPkgs sources system - }: rec { - # The sources, i.e. the attribute set of spec name to spec - inherit sources; - - # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers - inherit pkgs; - }; - -in -mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/servant-event-stream.nix b/servant-event-stream.nix deleted file mode 100644 index ff3ba9d..0000000 --- a/servant-event-stream.nix +++ /dev/null @@ -1,32 +0,0 @@ -let - sources = import ./nix/sources.nix; - pkgs = import sources.nixpkgs { inherit config; }; - compilerVersion = "ghc96"; - compilerSet = pkgs.haskell.packages."${compilerVersion}"; - gitIgnore = pkgs.nix-gitignore.gitignoreSourcePure; - config = { - packageOverrides = super: - let self = super.pkgs; - in rec { - haskell = super.haskell // { - packageOverrides = with pkgs.haskell.lib; - self: super: { - servant-event-stream = super.callCabal2nix "servant-event-stream" - (gitIgnore [ ./.gitignore ] ./.) { }; - servant-foreign = dontCheck super.servant-foreign; - }; - }; - }; - }; - -in { - inherit pkgs; - servant-event-stream = compilerSet.servant-event-stream; - shell = compilerSet.shellFor { - packages = p: [ p.servant-event-stream ]; - buildInputs = with pkgs; [ - compilerSet.cabal-install - compilerSet.haskell-language-server - ]; - }; -} diff --git a/shell.nix b/shell.nix deleted file mode 100644 index aa667f5..0000000 --- a/shell.nix +++ /dev/null @@ -1 +0,0 @@ -(import ./servant-event-stream.nix).shell From 60e6d75af76f492292a41218560ed3b8c7bc3e7d Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 19 Oct 2023 11:37:58 +0200 Subject: [PATCH 03/11] reformat with fourmolu --- src/Servant/API/EventStream.hs | 103 ++++++++++++++++++--------------- 1 file changed, 56 insertions(+), 47 deletions(-) diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs index 8850250..bd0c38d 100644 --- a/src/Servant/API/EventStream.hs +++ b/src/Servant/API/EventStream.hs @@ -1,39 +1,41 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -module Servant.API.EventStream - ( ServerSentEvents - , EventStream - , EventSource - , EventSourceHdr - , eventSource - ) +module Servant.API.EventStream ( + ServerSentEvents, + EventStream, + EventSource, + EventSourceHdr, + eventSource, +) where -import Control.Lens -import Data.Binary.Builder ( toLazyByteString ) +import Control.Lens +import Data.Binary.Builder (toLazyByteString) #if !MIN_VERSION_base(4,11,0) -import Data.Semigroup +import Data.Semigroup #endif -import Data.Text ( Text ) -import GHC.Generics ( Generic ) -import Network.HTTP.Media ( (//) - , (/:) - ) -import Network.Wai.EventSource ( ServerEvent(..) ) -import Network.Wai.EventSource.EventStream - ( eventToBuilder ) -import Servant -import Servant.Foreign -import Servant.Foreign.Internal ( _FunctionName ) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.HTTP.Media ( + (//), + (/:), + ) +import Network.Wai.EventSource (ServerEvent (..)) +import Network.Wai.EventSource.EventStream ( + eventToBuilder, + ) +import Servant +import Servant.Foreign +import Servant.Foreign.Internal (_FunctionName) newtype ServerSentEvents = ServerSentEvents (StreamGet NoFraming EventStream EventSourceHdr) @@ -41,28 +43,33 @@ newtype ServerSentEvents 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)) + route Proxy = + route + (Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr)) + hoistServerWithContext Proxy = + hoistServerWithContext + (Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr)) -- | a helper instance for -instance (HasForeignType lang ftype EventSourceHdr) - => HasForeign lang ftype ServerSentEvents where +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 + & reqFuncName . _FunctionName %~ ("stream" :) + & reqMethod .~ method + & reqReturnType ?~ retType where retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy EventSourceHdr) - method = reflectMethod (Proxy :: Proxy 'GET) + 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 +{- | 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 +-} data EventStream instance Accept EventStream where @@ -70,12 +77,14 @@ instance Accept EventStream where type EventSource = SourceIO ServerEvent --- | This is mostly to guide reverse-proxies like --- +{- | This is mostly to guide reverse-proxies like + +-} 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 +{- | 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 From 943ac2a99764d2f64e366f615b6bf6491d9e514a Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 19 Oct 2023 11:38:53 +0200 Subject: [PATCH 04/11] Add .envrc to use nix flake --- .envrc | 2 ++ .gitignore | 1 + 2 files changed, 3 insertions(+) create mode 100644 .envrc diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..eb9c60d --- /dev/null +++ b/.envrc @@ -0,0 +1,2 @@ +use flake +watch_file *.cabal diff --git a/.gitignore b/.gitignore index 58fe346..3d95d8a 100644 --- a/.gitignore +++ b/.gitignore @@ -2,5 +2,6 @@ dist/ dist-newstyle/ .ghc.environment.* .stack-work/ +.direnv/ # nix results result \ No newline at end of file From fd6416ccfa9f2fe85c4e71484b2de556ac4d3d79 Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 19 Oct 2023 12:03:12 +0200 Subject: [PATCH 05/11] Use flakes in github actions --- .github/workflows/test.yml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 945c991..f8d1a17 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -6,8 +6,7 @@ jobs: tests: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v2.3.4 - - uses: cachix/install-nix-action@v13 - with: - nix_path: nixpkgs=channel:nixos-unstable - - run: nix-build \ No newline at end of file + - uses: actions/checkout@v3 + - uses: cachix/install-nix-action@v22 + - run: nix build + - run: nix flake check \ No newline at end of file From 14d6af45e6ed42264a5adeaea0984326798a67ed Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 19 Oct 2023 12:32:24 +0200 Subject: [PATCH 06/11] Add recommended Cache-Control header --- src/Servant/API/EventStream.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs index bd0c38d..897dfcd 100644 --- a/src/Servant/API/EventStream.hs +++ b/src/Servant/API/EventStream.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -80,7 +81,7 @@ type EventSource = SourceIO ServerEvent {- | This is mostly to guide reverse-proxies like -} -type EventSourceHdr = Headers '[Header "X-Accel-Buffering" Text] EventSource +type EventSourceHdr = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] EventSource {- | See details at https://hackage.haskell.org/package/wai-extra-3.1.6/docs/Network-Wai-EventSource-EventStream.html#v:eventToBuilder @@ -89,4 +90,4 @@ instance MimeRender EventStream ServerEvent where mimeRender _ = maybe "" toLazyByteString . eventToBuilder eventSource :: EventSource -> EventSourceHdr -eventSource = addHeader "no" +eventSource = addHeader @"X-Accel-Buffering" "no" . addHeader @"Cache-Control" "no-store" From 39498e1179c269f1836aa23b7c9f74f9e51410dd Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 19 Oct 2023 14:31:54 +0200 Subject: [PATCH 07/11] Added ToServerEvent class --- servant-event-stream.cabal | 16 +++---- src/Servant/API/EventStream.hs | 84 +++++++++++++++++++++++++--------- 2 files changed, 70 insertions(+), 30 deletions(-) diff --git a/servant-event-stream.cabal b/servant-event-stream.cabal index 4736393..fc1df39 100644 --- a/servant-event-stream.cabal +++ b/servant-event-stream.cabal @@ -31,14 +31,14 @@ library OverloadedStrings build-depends: - base >=4.10 && <4.19 - , binary >=0.7 && <0.11 - , http-media >=0.7.1.3 && <0.9 - , lens >=4.17 && <5.3 - , servant-foreign >=0.15 && <0.17 - , servant-server >=0.15 && <0.21 - , text >=1.2.3 && <2.2 - , wai-extra >=3.0 && <3.2 + base >=4.10 && <4.19 + , bytestring >=0.11.1.0 && <0.13 + , http-media >=0.7.1.3 && <0.9 + , lens >=4.17 && <5.3 + , 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 diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs index 897dfcd..a48292c 100644 --- a/src/Servant/API/EventStream.hs +++ b/src/Servant/API/EventStream.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -16,47 +15,64 @@ module Servant.API.EventStream ( EventSource, EventSourceHdr, eventSource, + ServerEvent (..), + ToServerEvent (..), ) where import Control.Lens -import Data.Binary.Builder (toLazyByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as C8 #if !MIN_VERSION_base(4,11,0) import Data.Semigroup #endif +import Data.Kind (Type) import Data.Text (Text) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Network.HTTP.Media ( (//), (/:), ) -import Network.Wai.EventSource (ServerEvent (..)) -import Network.Wai.EventSource.EventStream ( - eventToBuilder, - ) import Servant import Servant.Foreign import Servant.Foreign.Internal (_FunctionName) -newtype ServerSentEvents - = ServerSentEvents (StreamGet NoFraming EventStream EventSourceHdr) - deriving (Generic, HasLink) +data ServerEvent = ServerEvent + { eventType :: Maybe LBS.ByteString + , eventId :: Maybe LBS.ByteString + , eventData :: LBS.ByteString + } + deriving (Show, Eq, Generic) + +class ToServerEvent a where + toServerEvent :: a -> ServerEvent + +{- | A ServerSentEvents endpoint emits an event stream using the format described at + +-} +data ServerSentEvents (a :: Type) + deriving (Typeable, Generic) + +instance HasLink (ServerSentEvents a) where + type MkLink (ServerSentEvents a) r = r + toLink toA _ = toA -instance HasServer ServerSentEvents context where - type ServerT ServerSentEvents m = ServerT (StreamGet NoFraming EventStream EventSourceHdr) m +instance (ToServerEvent a) => HasServer (ServerSentEvents a) context where + type ServerT (ServerSentEvents a) m = ServerT (StreamGet ServerEventFraming EventStream (EventSourceHdr a)) m route Proxy = route - (Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr)) + (Proxy :: Proxy (StreamGet ServerEventFraming EventStream (EventSourceHdr a))) hoistServerWithContext Proxy = hoistServerWithContext - (Proxy :: Proxy (StreamGet NoFraming EventStream EventSourceHdr)) + (Proxy :: Proxy (StreamGet ServerEventFraming EventStream (EventSourceHdr a))) -- | a helper instance for instance - (HasForeignType lang ftype EventSourceHdr) => - HasForeign lang ftype ServerSentEvents + (HasForeignType lang ftype (EventSourceHdr a)) => + HasForeign lang ftype (ServerSentEvents a) where - type Foreign ftype ServerSentEvents = Req ftype + type Foreign ftype (ServerSentEvents a) = Req ftype foreignFor lang Proxy Proxy req = req @@ -64,7 +80,7 @@ instance & reqMethod .~ method & reqReturnType ?~ retType where - retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy EventSourceHdr) + retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (EventSourceHdr a)) method = reflectMethod (Proxy :: Proxy 'GET) {- | A type representation of an event stream. It's responsible for setting proper content-type @@ -76,18 +92,42 @@ data EventStream instance Accept EventStream where contentType _ = "text" // "event-stream" /: ("charset", "utf-8") -type EventSource = SourceIO ServerEvent +type EventSource a = SourceIO a {- | This is mostly to guide reverse-proxies like -} -type EventSourceHdr = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] EventSource +type EventSourceHdr (a :: Type) = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] (EventSource a) {- | 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 +instance (ToServerEvent a) => MimeRender EventStream a where + mimeRender _ = encodeServerEvent . toServerEvent + +instance ToServerEvent ServerEvent where + toServerEvent = id -eventSource :: EventSource -> EventSourceHdr +{- 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" + + -- discard CR and split LFs into multiple data values + safelines = C8.lines . C8.filter (/= '\r') + +eventSource :: EventSource a -> EventSourceHdr a eventSource = addHeader @"X-Accel-Buffering" "no" . addHeader @"Cache-Control" "no-store" + +data ServerEventFraming + +instance FramingRender ServerEventFraming where + framingRender _ f = fmap (\x -> f x <> "\n") \ No newline at end of file From 6de12b8efb9b6a1c268f36f4d0bebb9c77dfd469 Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Tue, 24 Oct 2023 10:56:27 +0200 Subject: [PATCH 08/11] Support custom headers, provide recommended ones --- src/Servant/API/EventStream.hs | 66 ++++++++++++++++++++++------------ 1 file changed, 44 insertions(+), 22 deletions(-) diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs index a48292c..f7e5df9 100644 --- a/src/Servant/API/EventStream.hs +++ b/src/Servant/API/EventStream.hs @@ -10,13 +10,12 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.API.EventStream ( - ServerSentEvents, - EventStream, - EventSource, - EventSourceHdr, - eventSource, ServerEvent (..), ToServerEvent (..), + ServerSentEvents, + EventStream, + RecommendedEventSourceHeaders, + recommendedEventSourceHeaders, ) where @@ -58,18 +57,43 @@ instance HasLink (ServerSentEvents a) where type MkLink (ServerSentEvents a) r = r toLink toA _ = toA -instance (ToServerEvent a) => HasServer (ServerSentEvents a) context where - type ServerT (ServerSentEvents a) m = ServerT (StreamGet ServerEventFraming EventStream (EventSourceHdr a)) m +{- | 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 = 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 (EventSourceHdr a))) + (Proxy :: Proxy (StreamGet ServerEventFraming EventStream a)) hoistServerWithContext Proxy = hoistServerWithContext - (Proxy :: Proxy (StreamGet ServerEventFraming EventStream (EventSourceHdr a))) + (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 instance - (HasForeignType lang ftype (EventSourceHdr a)) => + (HasForeignType lang ftype a) => HasForeign lang ftype (ServerSentEvents a) where type Foreign ftype (ServerSentEvents a) = Req ftype @@ -80,7 +104,7 @@ instance & reqMethod .~ method & reqReturnType ?~ retType where - retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (EventSourceHdr a)) + 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 @@ -92,12 +116,18 @@ data EventStream instance Accept EventStream where contentType _ = "text" // "event-stream" /: ("charset", "utf-8") -type EventSource a = SourceIO a - {- | This is mostly to guide reverse-proxies like -} -type EventSourceHdr (a :: Type) = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] (EventSource a) +type RecommendedEventSourceHeaders (a :: Type) = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] a + +recommendedEventSourceHeaders :: a -> RecommendedEventSourceHeaders a +recommendedEventSourceHeaders = addHeader @"X-Accel-Buffering" "no" . addHeader @"Cache-Control" "no-store" + +data ServerEventFraming + +instance FramingRender ServerEventFraming where + framingRender _ f = fmap (\x -> f x <> "\n") {- | See details at https://hackage.haskell.org/package/wai-extra-3.1.6/docs/Network-Wai-EventSource-EventStream.html#v:eventToBuilder @@ -123,11 +153,3 @@ encodeServerEvent e = -- discard CR and split LFs into multiple data values safelines = C8.lines . C8.filter (/= '\r') - -eventSource :: EventSource a -> EventSourceHdr a -eventSource = addHeader @"X-Accel-Buffering" "no" . addHeader @"Cache-Control" "no-store" - -data ServerEventFraming - -instance FramingRender ServerEventFraming where - framingRender _ f = fmap (\x -> f x <> "\n") \ No newline at end of file From f1bd96cb99d26ca040bbd3d05bd08207d9727b3c Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 5 Sep 2024 16:08:49 +0200 Subject: [PATCH 09/11] relax bounds --- flake.lock | 7 ++-- flake.nix | 73 +++++++++++++++++++++++--------------- servant-event-stream.cabal | 6 ++-- 3 files changed, 52 insertions(+), 34 deletions(-) diff --git a/flake.lock b/flake.lock index 8f85863..fa327fb 100644 --- a/flake.lock +++ b/flake.lock @@ -2,15 +2,16 @@ "nodes": { "nixpkgs": { "locked": { - "lastModified": 1697703837, - "narHash": "sha256-7zov8gJlmLF62OHhEpc+PDLreIZaBv/4nlHfyws9SHA=", + "lastModified": 1725407940, + "narHash": "sha256-tiN5Rlg/jiY0tyky+soJZoRzLKbPyIdlQ77xVgREDNM=", "owner": "nixos", "repo": "nixpkgs", - "rev": "4a2788ea2ad7f1607f272c829f37e79a396b4d1a", + "rev": "6f6c45b5134a8ee2e465164811e451dcb5ad86e3", "type": "github" }, "original": { "owner": "nixos", + "ref": "nixos-24.05", "repo": "nixpkgs", "type": "github" } diff --git a/flake.nix b/flake.nix index 3ac8ea2..f3cd137 100644 --- a/flake.nix +++ b/flake.nix @@ -1,42 +1,59 @@ { description = "servant-event-stream"; - inputs = { nixpkgs.url = "github:nixos/nixpkgs"; }; + inputs = { + nixpkgs.url = "github:nixos/nixpkgs/nixos-24.05"; + }; - outputs = { self, nixpkgs, ... }: + outputs = + { self, nixpkgs, ... }: let supportedSystems = [ "x86_64-linux" ]; - forallSystems = f: - nixpkgs.lib.genAttrs supportedSystems (system: + forallSystems = + f: + nixpkgs.lib.genAttrs supportedSystems ( + system: f (rec { inherit system; pkgs = nixpkgsFor system; - haskellPackages = hpkgsFor pkgs; - })); + haskellPackages = hpkgsFor system pkgs; + }) + ); nixpkgsFor = system: import nixpkgs { inherit system; }; - hpkgsFor = pkgs: + hpkgsFor = + system: pkgs: with pkgs.haskell.lib; - pkgs.haskell.packages.ghc96.override { - overrides = self: super: { - servant-foreign = dontCheck super.servant-foreign; + pkgs.haskell.packages.ghc98.override { overrides = self: super: { }; }; + in + { + packages = forallSystems ( + { + system, + pkgs, + haskellPackages, + }: + { + servant-event-stream = haskellPackages.callCabal2nix "servant-event-stream" ./. { }; + default = self.packages.${system}.servant-event-stream; + } + ); + devShells = forallSystems ( + { + system, + pkgs, + haskellPackages, + }: + { + servant-event-stream = haskellPackages.shellFor { + packages = p: [ self.packages.${system}.servant-event-stream ]; + buildInputs = with haskellPackages; [ + cabal-install + haskell-language-server + ]; + withHoogle = true; }; - }; - in { - packages = forallSystems ({ system, pkgs, haskellPackages }: { - servant-event-stream = - haskellPackages.callCabal2nix "servant-event-stream" ./. { }; - default = self.packages.${system}.servant-event-stream; - }); - devShells = forallSystems ({ system, pkgs, haskellPackages }: { - servant-event-stream = haskellPackages.shellFor { - packages = p: [ self.packages.${system}.servant-event-stream ]; - buildInputs = with haskellPackages; [ - cabal-install - haskell-language-server - ]; - withHoogle = true; - }; - default = self.devShells.${system}.servant-event-stream; - }); + default = self.devShells.${system}.servant-event-stream; + } + ); }; } diff --git a/servant-event-stream.cabal b/servant-event-stream.cabal index fc1df39..8c92b5d 100644 --- a/servant-event-stream.cabal +++ b/servant-event-stream.cabal @@ -14,7 +14,7 @@ license: BSD3 license-file: LICENSE author: Shaun Sharples maintainer: shaun.sharples@gmail.com -copyright: (c) 2023 Shaun Sharples +copyright: (c) 2024 Shaun Sharples build-type: Simple extra-source-files: CHANGELOG.md @@ -31,10 +31,10 @@ library OverloadedStrings build-depends: - base >=4.10 && <4.19 + base >=4.10 && <4.20 , bytestring >=0.11.1.0 && <0.13 , http-media >=0.7.1.3 && <0.9 - , lens >=4.17 && <5.3 + , lens >=4.17 && <5.4 , servant-foreign >=0.15 && <0.17 , servant-server >=0.15 && <0.21 , text >=1.2.3 && <2.2 From cc834bc7ff744f42a2cc9c1c26b7d2e6125d0f79 Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 5 Sep 2024 17:17:25 +0200 Subject: [PATCH 10/11] cleanup and document --- CHANGELOG.md | 20 +++++++++++ servant-event-stream.cabal | 64 ++++++++++++++++++---------------- src/Servant/API/EventStream.hs | 57 +++++++++++++++++++----------- 3 files changed, 89 insertions(+), 52 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c268a98..be535c1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/servant-event-stream.cabal b/servant-event-stream.cabal index 8c92b5d..39d6c3d 100644 --- a/servant-event-stream.cabal +++ b/servant-event-stream.cabal @@ -1,52 +1,54 @@ -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 +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 +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 source-repository head - type: git + type: git 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.10 && <4.20 - , 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 + 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 + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests default-language: Haskell2010 - build-depends: base + build-depends: base diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs index f7e5df9..09282e7 100644 --- a/src/Servant/API/EventStream.hs +++ b/src/Servant/API/EventStream.hs @@ -22,10 +22,10 @@ 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.Kind (Type) import Data.Text (Text) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -37,16 +37,6 @@ import Servant import Servant.Foreign import Servant.Foreign.Internal (_FunctionName) -data ServerEvent = ServerEvent - { eventType :: Maybe LBS.ByteString - , eventId :: Maybe LBS.ByteString - , eventData :: LBS.ByteString - } - deriving (Show, Eq, Generic) - -class ToServerEvent a where - toServerEvent :: a -> ServerEvent - {- | A ServerSentEvents endpoint emits an event stream using the format described at -} @@ -57,6 +47,30 @@ 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. @@ -71,7 +85,7 @@ instance HasLink (ServerSentEvents a) where > server :: Server MyApi > server = streamBooks > where streamBooks :: Handler (SourceIO Book) - streamBooks = source [book1, ...] + 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 @@ -118,9 +132,19 @@ instance Accept EventStream where {- | This is mostly to guide reverse-proxies like + + 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 = addHeader @"X-Accel-Buffering" "no" . addHeader @"Cache-Control" "no-store" @@ -129,15 +153,6 @@ data ServerEventFraming instance FramingRender ServerEventFraming where framingRender _ f = fmap (\x -> f x <> "\n") -{- | See details at - https://hackage.haskell.org/package/wai-extra-3.1.6/docs/Network-Wai-EventSource-EventStream.html#v:eventToBuilder --} -instance (ToServerEvent a) => MimeRender EventStream a where - mimeRender _ = encodeServerEvent . toServerEvent - -instance ToServerEvent ServerEvent where - toServerEvent = id - {- 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. From f9a218600c0b6e8ea23c7f036943cb3802b365cf Mon Sep 17 00:00:00 2001 From: Shaun Sharples Date: Thu, 5 Sep 2024 17:18:35 +0200 Subject: [PATCH 11/11] small fix to documentation --- CHANGELOG.md | 2 +- src/Servant/API/EventStream.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index be535c1..d71a16a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,7 +18,7 @@ > server :: Server MyApi > server = streamBooks > where streamBooks :: Handler (SourceIO Book) - streamBooks = pure $ source [book1, ...] + > streamBooks = pure $ source [book1, ...] ## 0.2.1.0 -- 2021-04-21 diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs index 09282e7..b88956e 100644 --- a/src/Servant/API/EventStream.hs +++ b/src/Servant/API/EventStream.hs @@ -85,7 +85,7 @@ instance ToServerEvent ServerEvent where > server :: Server MyApi > server = streamBooks > where streamBooks :: Handler (SourceIO Book) - streamBooks = pure $ source [book1, ...] + > 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 @@ -140,7 +140,7 @@ instance Accept EventStream where > server :: Server MyApi > server = streamBooks > where streamBooks :: Handler (RecommendedEventSourceHeaders (SourceIO Book)) - streamBooks = pure $ recommendedEventSourceHeaders $ source [book1, ...] + > streamBooks = pure $ recommendedEventSourceHeaders $ source [book1, ...] -} type RecommendedEventSourceHeaders (a :: Type) = Headers '[Header "X-Accel-Buffering" Text, Header "Cache-Control" Text] a