diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# Revision history for servant-event-stream + +## 0.2.0.0 -- 2021-04-x + +* `Servant.EventStream` was moved to `Servant.API.EventStream` to adhere existing [upstream layout](https://hackage.haskell.org/package/servant-0.18.2/docs/Servant-API-Stream.html). + +## 0.1.0.0 -- 2018-04-30 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2021, Shaun Sharples + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Shaun Sharples nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +servant-event-stream +==================== + +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 +--------------- + +Dev env is based on [Nix](https://nixos.org) and [Niv](https://github.com/nmattia/niv). + +To enter the dev shell, run +```bash +nix-shell +``` + +You can build the project with +```bash +nix-build +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-event-stream.cabal b/servant-event-stream.cabal new file mode 100644 --- /dev/null +++ b/servant-event-stream.cabal @@ -0,0 +1,61 @@ +cabal-version: >=1.10 +name: servant-event-stream +version: 0.2.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) 2021 Shaun Sharples +build-type: Simple + +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/bflyblue/servant-event-stream.git + +library + 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 + + 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 diff --git a/src/Servant/API/EventStream.hs b/src/Servant/API/EventStream.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/EventStream.hs @@ -0,0 +1,134 @@ +{-# 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 (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 +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 +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 +-- +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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"