diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,15 @@
# Revision history for reflex-gadt-api
+## 0.4.0.0
+
+* Add `Reflex.Dom.GadtApi.Codec`, exposing the pure `encodeApiRequest` and `serveApiRequest` codecs used by the transports; `serveApiRequest` gives servers a reusable untagged decode/interpret/encode step
+* Add a test suite covering request tagging and correlation (in order, out of order, and multiple requests per frame), duplicate and unknown tags, malformed payloads and frames, and the codec helpers
+* Enable `FlexibleContexts` for generated test instances, as required by the GHC 9.10 and 9.12 CI builds
+* *Breaking*: `performWebSocketRequests` takes a `WebSocketClientConfig` (URL, subprotocols, close, and reconnect) and additionally returns a `WebSocketClientStatus` exposing connection open/error/close events, unparseable incoming messages, and responses that don't match any outstanding request. Note that outstanding requests still survive disconnects and reconnects
+* *Breaking*: `tagRequests` additionally returns an event of responses whose tag matches no outstanding request; previously such responses were dropped silently
+* *Breaking*: `performXhrRequests` and `apiRequestXhr` take an `XhrClientConfig` whose `configureRequest` hook can adjust the outgoing `XhrRequest` (e.g. to add headers or credentials)
+* *Breaking*: transport-level failures are now reported instead of hanging: `XhrError` carries `Either XhrException XhrResponse`, so aborted requests and requests that could not be sent surface as errors; consequently `XhrError` no longer derives `Generic`
+
## 0.3.0.0
* *Breaking*: switch to a more useful xhr error response type. To retain the current behavior, you must convert `Either XhrResponse` to `Either Text`. See `Readme.lhs` for an example using `xhrErrorToText`.
diff --git a/Readme.lhs b/Readme.lhs
--- a/Readme.lhs
+++ b/Readme.lhs
@@ -1,14 +1,46 @@
+
+
reflex-gadt-api
===============
-[](https://haskell.org) [](https://hackage.haskell.org/package/reflex-gadt-api) [](https://github.com/reflex-frp/reflex-gadt-api/actions) [](https://github.com/reflex-frp/reflex-gadt-api/blob/master/LICENSE)
+**Type-safe, full-stack APIs for Reflex, defined once as a GADT.**
+Describe your API as a [GADT](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/gadt.html), derive its JSON wire format, and call it from your [reflex-dom](https://github.com/reflex-frp/reflex-dom) frontend over XHR or WebSockets, with request and response types checked from end to end.
+[](https://haskell.org) [](https://hackage.haskell.org/package/reflex-gadt-api) [](https://github.com/reflex-frp/reflex-gadt-api/actions) [](https://obsidian.systems) [](LICENSE)
+
+
This package is designed to be used in full-stack Haskell applications where the API is defined as a GADT, the wire format is JSON, and the frontend is using reflex-dom(-core). reflex-gadt-api provides the basic FRP and encoding/decoding infrastructure to support this architecture.
-To serialize the GADT API definition, we use [aeson-gadt-th](https://github.com/obsidiansystems/aeson-gadt-th) with a little help from [constraints-extras](https://github.com/obsidiansystems/constraints-extras).
+Why define your API as a GADT?
+------------------------------
+An ordinary Haskell data type can enumerate the requests an API accepts, but it can't capture what each request *returns*: every constructor of a plain `data Api = ...` has the same type, so a handler can only ever promise "some response," and the link between a particular request and its particular response type is lost.
+
+A GADT (generalized algebraic data type) removes that restriction: each constructor may fix the type parameter to a different type. We use that parameter to record each request's **response type**:
+
+ data DogApi a where
+ DogApi_GetByName :: Text -> DogApi [Dog]
+ DogApi_GetLastSeen :: DogApi (Maybe Dog)
+ DogApi_ReportSighting :: Text -> Bool -> Maybe Text -> DogApi (Either Text ())
+
+Now `DogApi_GetLastSeen` is a `DogApi (Maybe Dog)` and `DogApi_GetByName "Rex"` is a `DogApi [Dog]`: a constructor's arguments are the request, and its type index is the response. That single idea buys a lot:
+
+- **A request and its response can't drift apart.** When the backend pattern matches on a request, GHC knows the exact response type in that branch, so a handler of type `forall a. DogApi a -> m a` is checked to return the right type for every endpoint, and to handle them all. Adding an endpoint means adding a constructor, and the compiler then points you at every place that must account for it.
+- **The types are the contract, shared across the whole stack.** The API is just a datatype in a `common` library, so the *same* definition compiles into both the GHC backend and the (JavaScript) reflex-dom frontend. There is no separate schema or IDL, and no generated client to fall out of sync; client and server cannot disagree about a request's arguments or its response type, because they are the same type.
+- **Endpoints compose.** Because requests are ordinary values, one API can embed another while preserving response types. The example below nests `DogApi` inside a `CatApi` that layers on authentication: `CatApi_DogApi :: Token -> DogApi a -> CatApi a`.
+- **Responses arrive typed, not as raw JSON.** Sending `DogApi_GetLastSeen` gives you back a `Maybe Dog`, not a `Value` you have to re-parse by hand. This library automates the business of preserving that response type across JSON (de)serialization.
+
+Putting it together
+-------------------
+
+- **The GADT** defines the requests and, through its type index, their response types.
+- **Derived instances.** `deriveJSONGADT` (from [aeson-gadt-th](https://github.com/obsidiansystems/aeson-gadt-th)) derives the JSON wire format for the API, and `deriveArgDict` (from [constraints-extras](https://github.com/obsidiansystems/constraints-extras)) derives the machinery that recovers a request's `FromJSON` instance so its response can be decoded. (Once requests with different response types are mixed into a single event, that response type is existentially hidden; this is what brings it back.)
+- **A transport** carries requests to the server and feeds typed responses back into your reflex app. Two are provided: `performXhrRequests` (one HTTP request per call) and `performWebSocketRequests` (a single, multiplexed socket). Each takes a configuration record — `XhrClientConfig` lets you adjust outgoing requests (for example, headers or credentials) and `WebSocketClientConfig` exposes connection knobs like subprotocols and automatic reconnection — and the WebSocket transport also returns a `WebSocketClientStatus` reporting connection lifecycle, unparseable incoming messages, and responses that match no outstanding request. On the server, `Reflex.Dom.GadtApi.Codec` provides the matching codecs and dispatcher (`encodeApiRequest`, `serveApiRequest`).
+
+The rest of this document is a literate Haskell walkthrough that builds a small example app.
+
Example Usage:
--------------
@@ -146,15 +178,18 @@
```
-The `Event` of responses comes, in this case, from a function that will take the requests emitted on the previous line and fetch responses to those requests. It produces an `Event` of responses. We can use either `Reflex.Dom.GadtApi.XHR.performXhrRequests` if we want to send requests using XHR or `Reflex.Dom.GadtApi.WebSocket.performWebSocketRequests` to use WebSockets.
+The `Event` of responses comes, in this case, from a function that will take the requests emitted on the previous line and fetch responses to those requests. It produces an `Event` of responses. We can use either `Reflex.Dom.GadtApi.XHR.performXhrRequests` if we want to send requests using XHR or `Reflex.Dom.GadtApi.WebSocket.performWebSocketRequests` to use WebSockets. Both are configured through `def`-based records; here we only set the URL. The WebSocket transport additionally returns a `WebSocketClientStatus` value, ignored in this toy example; it exposes connection lifecycle events and protocol diagnostics such as unparseable messages and responses that match no outstanding request.
```haskell
> responses <- case endpoint of
> Left xhr -> do
-> r <- performXhrRequests xhr (requests :: Event t (RequesterData CatApi))
+> r <- performXhrRequests (def { _xhrClientConfig_url = xhr }) (requests :: Event t (RequesterData CatApi))
> performEvent $ ffor r $ traverseRequesterData $ \x ->
> pure $ mapLeft xhrErrorToText x
-> Right ws -> performWebSocketRequests ws (requests :: Event t (RequesterData CatApi))
+> Right ws -> do
+> (r, _status) <- performWebSocketRequests
+> (def { _webSocketClientConfig_url = ws }) (requests :: Event t (RequesterData CatApi))
+> pure r
> pure ()
> where
> mapLeft f = \case
@@ -333,3 +368,19 @@
```
Go to the [example](example) directory to run this example (including the [backend](example/backend/src/Backend.md)).
+
+About Obsidian Systems
+----------------------
+
+reflex-gadt-api is built and maintained by **[Obsidian Systems](https://obsidian.systems)**. We provide frontier engineering for high-assurance systems: we build production software in Haskell and Nix, and we're long-time stewards of open-source tooling like [Obelisk](https://github.com/obsidiansystems/obelisk), [Reflex](https://reflex-frp.org/), and [nix-thunk](https://github.com/obsidiansystems/nix-thunk).
+
+If you're working with Reflex, full-stack Haskell, or Nix and want a partner to help design, build, or ship it, we'd love to hear from you.
+
+- Website:
+- Blog:
+- GitHub:
+
+License
+-------
+
+reflex-gadt-api is released under the [BSD-3-Clause License](LICENSE), © 2015 Obsidian Systems LLC.
diff --git a/Readme.md b/Readme.md
--- a/Readme.md
+++ b/Readme.md
@@ -1,14 +1,46 @@
+
+
reflex-gadt-api
===============
-[](https://haskell.org) [](https://hackage.haskell.org/package/reflex-gadt-api) [](https://github.com/reflex-frp/reflex-gadt-api/actions) [](https://github.com/reflex-frp/reflex-gadt-api/blob/master/LICENSE)
+**Type-safe, full-stack APIs for Reflex, defined once as a GADT.**
+Describe your API as a [GADT](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/gadt.html), derive its JSON wire format, and call it from your [reflex-dom](https://github.com/reflex-frp/reflex-dom) frontend over XHR or WebSockets, with request and response types checked from end to end.
+[](https://haskell.org) [](https://hackage.haskell.org/package/reflex-gadt-api) [](https://github.com/reflex-frp/reflex-gadt-api/actions) [](https://obsidian.systems) [](LICENSE)
+
+
This package is designed to be used in full-stack Haskell applications where the API is defined as a GADT, the wire format is JSON, and the frontend is using reflex-dom(-core). reflex-gadt-api provides the basic FRP and encoding/decoding infrastructure to support this architecture.
-To serialize the GADT API definition, we use [aeson-gadt-th](https://github.com/obsidiansystems/aeson-gadt-th) with a little help from [constraints-extras](https://github.com/obsidiansystems/constraints-extras).
+Why define your API as a GADT?
+------------------------------
+An ordinary Haskell data type can enumerate the requests an API accepts, but it can't capture what each request *returns*: every constructor of a plain `data Api = ...` has the same type, so a handler can only ever promise "some response," and the link between a particular request and its particular response type is lost.
+
+A GADT (generalized algebraic data type) removes that restriction: each constructor may fix the type parameter to a different type. We use that parameter to record each request's **response type**:
+
+ data DogApi a where
+ DogApi_GetByName :: Text -> DogApi [Dog]
+ DogApi_GetLastSeen :: DogApi (Maybe Dog)
+ DogApi_ReportSighting :: Text -> Bool -> Maybe Text -> DogApi (Either Text ())
+
+Now `DogApi_GetLastSeen` is a `DogApi (Maybe Dog)` and `DogApi_GetByName "Rex"` is a `DogApi [Dog]`: a constructor's arguments are the request, and its type index is the response. That single idea buys a lot:
+
+- **A request and its response can't drift apart.** When the backend pattern matches on a request, GHC knows the exact response type in that branch, so a handler of type `forall a. DogApi a -> m a` is checked to return the right type for every endpoint, and to handle them all. Adding an endpoint means adding a constructor, and the compiler then points you at every place that must account for it.
+- **The types are the contract, shared across the whole stack.** The API is just a datatype in a `common` library, so the *same* definition compiles into both the GHC backend and the (JavaScript) reflex-dom frontend. There is no separate schema or IDL, and no generated client to fall out of sync; client and server cannot disagree about a request's arguments or its response type, because they are the same type.
+- **Endpoints compose.** Because requests are ordinary values, one API can embed another while preserving response types. The example below nests `DogApi` inside a `CatApi` that layers on authentication: `CatApi_DogApi :: Token -> DogApi a -> CatApi a`.
+- **Responses arrive typed, not as raw JSON.** Sending `DogApi_GetLastSeen` gives you back a `Maybe Dog`, not a `Value` you have to re-parse by hand. This library automates the business of preserving that response type across JSON (de)serialization.
+
+Putting it together
+-------------------
+
+- **The GADT** defines the requests and, through its type index, their response types.
+- **Derived instances.** `deriveJSONGADT` (from [aeson-gadt-th](https://github.com/obsidiansystems/aeson-gadt-th)) derives the JSON wire format for the API, and `deriveArgDict` (from [constraints-extras](https://github.com/obsidiansystems/constraints-extras)) derives the machinery that recovers a request's `FromJSON` instance so its response can be decoded. (Once requests with different response types are mixed into a single event, that response type is existentially hidden; this is what brings it back.)
+- **A transport** carries requests to the server and feeds typed responses back into your reflex app. Two are provided: `performXhrRequests` (one HTTP request per call) and `performWebSocketRequests` (a single, multiplexed socket). Each takes a configuration record — `XhrClientConfig` lets you adjust outgoing requests (for example, headers or credentials) and `WebSocketClientConfig` exposes connection knobs like subprotocols and automatic reconnection — and the WebSocket transport also returns a `WebSocketClientStatus` reporting connection lifecycle, unparseable incoming messages, and responses that match no outstanding request. On the server, `Reflex.Dom.GadtApi.Codec` provides the matching codecs and dispatcher (`encodeApiRequest`, `serveApiRequest`).
+
+The rest of this document is a literate Haskell walkthrough that builds a small example app.
+
Example Usage:
--------------
@@ -146,15 +178,18 @@
```
-The `Event` of responses comes, in this case, from a function that will take the requests emitted on the previous line and fetch responses to those requests. It produces an `Event` of responses. We can use either `Reflex.Dom.GadtApi.XHR.performXhrRequests` if we want to send requests using XHR or `Reflex.Dom.GadtApi.WebSocket.performWebSocketRequests` to use WebSockets.
+The `Event` of responses comes, in this case, from a function that will take the requests emitted on the previous line and fetch responses to those requests. It produces an `Event` of responses. We can use either `Reflex.Dom.GadtApi.XHR.performXhrRequests` if we want to send requests using XHR or `Reflex.Dom.GadtApi.WebSocket.performWebSocketRequests` to use WebSockets. Both are configured through `def`-based records; here we only set the URL. The WebSocket transport additionally returns a `WebSocketClientStatus` value, ignored in this toy example; it exposes connection lifecycle events and protocol diagnostics such as unparseable messages and responses that match no outstanding request.
```haskell
> responses <- case endpoint of
> Left xhr -> do
-> r <- performXhrRequests xhr (requests :: Event t (RequesterData CatApi))
+> r <- performXhrRequests (def { _xhrClientConfig_url = xhr }) (requests :: Event t (RequesterData CatApi))
> performEvent $ ffor r $ traverseRequesterData $ \x ->
> pure $ mapLeft xhrErrorToText x
-> Right ws -> performWebSocketRequests ws (requests :: Event t (RequesterData CatApi))
+> Right ws -> do
+> (r, _status) <- performWebSocketRequests
+> (def { _webSocketClientConfig_url = ws }) (requests :: Event t (RequesterData CatApi))
+> pure r
> pure ()
> where
> mapLeft f = \case
@@ -333,3 +368,19 @@
```
Go to the [example](example) directory to run this example (including the [backend](example/backend/src/Backend.md)).
+
+About Obsidian Systems
+----------------------
+
+reflex-gadt-api is built and maintained by **[Obsidian Systems](https://obsidian.systems)**. We provide frontier engineering for high-assurance systems: we build production software in Haskell and Nix, and we're long-time stewards of open-source tooling like [Obelisk](https://github.com/obsidiansystems/obelisk), [Reflex](https://reflex-frp.org/), and [nix-thunk](https://github.com/obsidiansystems/nix-thunk).
+
+If you're working with Reflex, full-stack Haskell, or Nix and want a partner to help design, build, or ship it, we'd love to hear from you.
+
+- Website:
+- Blog:
+- GitHub:
+
+License
+-------
+
+reflex-gadt-api is released under the [BSD-3-Clause License](LICENSE), © 2015 Obsidian Systems LLC.
diff --git a/reflex-gadt-api.cabal b/reflex-gadt-api.cabal
--- a/reflex-gadt-api.cabal
+++ b/reflex-gadt-api.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: reflex-gadt-api
-version: 0.3.0.0
+version: 0.4.0.0
synopsis: Interact with a GADT API in your reflex-dom application.
description:
This package is designed to be used in full-stack Haskell applications where the API is defined as a GADT and the frontend is using reflex-dom.
@@ -13,7 +13,7 @@
copyright: 2020 Obsidian Systems LLC
category: FRP, API, network
build-type: Simple
-extra-source-files:
+extra-doc-files:
ChangeLog.md
Readme.md
@@ -25,6 +25,7 @@
aeson >=1.4.4 && <2.3
, aeson-gadt-th >=0.2.4 && <0.3
, base >=4.12 && <4.22
+ , bytestring >=0.10 && <0.13
, constraints-extras >=0.3.0 && <0.5
, containers >=0.6 && <0.8
, data-default >=0.6 && <0.9
@@ -37,6 +38,7 @@
exposed-modules:
Reflex.Dom.GadtApi
+ Reflex.Dom.GadtApi.Codec
Reflex.Dom.GadtApi.WebSocket
Reflex.Dom.GadtApi.XHR
@@ -65,6 +67,24 @@
main-is: Readme.lhs
ghc-options: -Wall -optL -q -main-is Readme.main
+test-suite reflex-gadt-api-test
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ hs-source-dirs: test
+ build-depends:
+ aeson >=1.4.4 && <2.3
+ , aeson-gadt-th >=0.2.4 && <0.3
+ , base >=4.12 && <4.22
+ , constraints-extras >=0.3.0 && <0.5
+ , bytestring >=0.10 && <0.13
+ , hspec >=2.8 && <2.12
+ , reflex >=0.9 && <1
+ , reflex-gadt-api
+ , some >=1 && <1.1
+ , text >=1.2 && <2.2
+ default-language: Haskell2010
+ ghc-options: -Wall
+
source-repository head
type: git
- location: git://github.com/reflex-frp/reflex-gadt-api.git
+ location: https://github.com/reflex-frp/reflex-gadt-api.git
diff --git a/src/Reflex/Dom/GadtApi/Codec.hs b/src/Reflex/Dom/GadtApi/Codec.hs
new file mode 100644
--- /dev/null
+++ b/src/Reflex/Dom/GadtApi/Codec.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Pure request\/response codecs and dispatch for a GADT API.
+--
+-- "Reflex.Dom.GadtApi.WebSocket" and "Reflex.Dom.GadtApi.XHR" use these
+-- operations internally. Use them on a server, or in a new transport, to
+-- keep the same wire format.
+--
+-- Client and server constraints are separate. A client encodes requests and
+-- decodes responses. A server decodes requests and encodes responses.
+module Reflex.Dom.GadtApi.Codec
+ ( encodeApiRequest
+ , serveApiRequest
+ ) where
+
+import Data.Aeson
+import Data.Constraint.Extras
+import Data.Some (Some (..))
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- | Encode an API request as JSON, together with a decoder for its response.
+--
+-- The decoder uses the request to find the 'FromJSON' instance of the
+-- response type. Mixed requests hide this type. The decoder makes it known
+-- again. A payload that does not decode as the response type gives 'Left'
+-- with the parser error.
+encodeApiRequest
+ :: forall api a. (Has FromJSON api, forall x. ToJSON (api x))
+ => api a
+ -> (Value, Value -> Either Text a)
+encodeApiRequest r =
+ ( toJSON r
+ , \v -> case has @FromJSON r $ fromJSON v of
+ Success x -> Right x
+ Error e -> Left $ T.pack e
+ )
+
+-- | Decode an incoming request. Run the handler on it. Encode the response.
+--
+-- A request 'Value' that does not match a constructor of the API gives
+-- 'Left' with the parser error. This function does not catch an exception
+-- from the handler. The interpreter or the host application must handle
+-- such exceptions.
+serveApiRequest
+ :: (Monad m, FromJSON (Some api), Has ToJSON api)
+ => (forall a. api a -> m a)
+ -> Value
+ -> m (Either String Value)
+serveApiRequest f v = case fromJSON v of
+ Success (Some a) -> do
+ rsp <- f a
+ pure $ Right $ has @ToJSON a $ toJSON rsp
+ Error e -> pure $ Left e
diff --git a/src/Reflex/Dom/GadtApi/WebSocket.hs b/src/Reflex/Dom/GadtApi/WebSocket.hs
--- a/src/Reflex/Dom/GadtApi/WebSocket.hs
+++ b/src/Reflex/Dom/GadtApi/WebSocket.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
@@ -10,6 +11,8 @@
{-# LANGUAGE UndecidableInstances #-}
module Reflex.Dom.GadtApi.WebSocket
( performWebSocketRequests
+ , WebSocketClientConfig (..)
+ , WebSocketClientStatus (..)
, TaggedRequest (..)
, TaggedResponse (..)
, mkTaggedResponse
@@ -20,8 +23,9 @@
import Control.Monad.Fix (MonadFix)
import Data.Constraint.Extras
import Data.Aeson
+import Data.ByteString (ByteString)
import Data.Default
-import qualified Data.Text as T
+import qualified Data.Set as Set
import GHC.Generics
import qualified Data.Map as Map
import Data.Some
@@ -31,6 +35,8 @@
import Reflex.Dom.Core (Prerender, prerender)
import Reflex.Dom.WebSocket
+import Reflex.Dom.GadtApi.Codec (encodeApiRequest, serveApiRequest)
+
-- | A request tagged with an identifier
data TaggedRequest = TaggedRequest Int Value
deriving Generic
@@ -38,7 +44,7 @@
instance FromJSON TaggedRequest
instance ToJSON TaggedRequest
--- | A response tagged with an identifier matching the one in the 'TaggedRequest'. The identifier is the first argument.
+-- | A response tagged with an identifier. The identifier matches the one in the 'TaggedRequest' and is the first argument.
data TaggedResponse = TaggedResponse Int Value
deriving Generic
@@ -47,51 +53,145 @@
type WebSocketEndpoint = Text
--- | Opens a websockets connection, takes the output of a 'RequesterT' widget
--- and issues that output as API requests over the socket. The result of this
--- function can be fed back into the requester as responses. For example:
+-- | Configuration for the websocket that 'performWebSocketRequests' manages.
+-- These fields match the native 'Reflex.Dom.WebSocket.WebSocketConfig'
+-- fields. The XHR transport has no matching fields. The two transports have
+-- different capabilities.
+data WebSocketClientConfig t = WebSocketClientConfig
+ { _webSocketClientConfig_url :: WebSocketEndpoint
+ -- ^ URL of the websocket
+ , _webSocketClientConfig_reconnect :: Bool
+ -- ^ Whether to connect again automatically after the connection closes.
+ -- Requests sent while no connection is open stay in a queue. The queue
+ -- is sent when a connection opens. Outstanding requests survive
+ -- disconnects and reconnects. See 'WebSocketClientStatus'.
+ , _webSocketClientConfig_protocols :: [Text]
+ -- ^ Subprotocols to request when opening the connection
+ , _webSocketClientConfig_close :: Event t (Word, Text)
+ -- ^ Close the connection with this code and reason when this event
+ -- fires
+ }
+
+-- | The default configuration uses the empty URL. It requests no
+-- subprotocols and never closes the connection itself. It connects again
+-- automatically. Set '_webSocketClientConfig_url' before you use it.
+instance Reflex t => Default (WebSocketClientConfig t) where
+ def = WebSocketClientConfig
+ { _webSocketClientConfig_url = ""
+ , _webSocketClientConfig_reconnect = True
+ , _webSocketClientConfig_protocols = []
+ , _webSocketClientConfig_close = never
+ }
+
+-- | Connection status and protocol diagnostics for the socket that
+-- 'performWebSocketRequests' manages. The lifecycle events come from
+-- 'Reflex.Dom.WebSocket.WebSocket':
--
+-- * '_webSocketClientStatus_open' fires each time a connection opens. This
+-- includes connections after a reconnect.
+-- * '_webSocketClientStatus_error' fires on a connection error. A close
+-- event always follows it.
+-- * '_webSocketClientStatus_close' fires each time a connection closes. It
+-- carries the @wasClean@ flag, the status code, and the reason.
+--
+-- Outstanding requests are /not/ failed when the connection closes. They
+-- stay pending until a matching response arrives. Requests sent while no
+-- connection is open stay in a queue. The queue is sent when a connection
+-- opens. A queued request that changes data can be sent again after a
+-- reconnect. Set '_webSocketClientConfig_reconnect' to 'False' if your
+-- application must not send the same change twice.
+data WebSocketClientStatus t = WebSocketClientStatus
+ { _webSocketClientStatus_open :: Event t ()
+ -- ^ A connection opened
+ , _webSocketClientStatus_error :: Event t ()
+ -- ^ A connection error occurred. A close event always follows.
+ , _webSocketClientStatus_close :: Event t (Bool, Word, Text)
+ -- ^ The connection closed with @wasClean@, code, and reason
+ , _webSocketClientStatus_unparseableMessage :: Event t ByteString
+ -- ^ An incoming message that does not decode as a 'TaggedResponse'.
+ -- The library cannot match such a message to a request. It reports the
+ -- message here instead of a request error. If you share the socket with
+ -- other traffic, use 'tagRequests'. Split the incoming messages
+ -- yourself.
+ , _webSocketClientStatus_unmatchedResponse :: Event t (Int, Value)
+ -- ^ A well-formed 'TaggedResponse' with a tag that no outstanding
+ -- request uses. The tag is unknown, or the response is a duplicate. The
+ -- library cannot correlate such a response. It reports the response
+ -- here.
+ }
+
+-- | Open one websocket connection. Send the output of a 'RequesterT' widget
+-- as API requests on this socket. Integer tags multiplex the requests. Feed
+-- the first result back into the requester as responses. The second result
+-- reports connection and protocol problems. For example:
+--
-- @
-- rec (appResult, requests) <- runRequesterT myApplication responses
--- responses <- performWebSocketRequests myEndpoint requests
+-- (responses, status) <- performWebSocketRequests (def { _webSocketClientConfig_url = myEndpoint }) requests
-- @
--
+-- See 'WebSocketClientStatus' for the lifecycle of outstanding requests
+-- across disconnects and reconnects.
performWebSocketRequests
:: forall req t m.
- ( Prerender t m, Applicative m
+ ( Prerender t m, Monad m
, FromJSON (Some req)
, forall a. ToJSON (req a)
, Has FromJSON req
)
- => WebSocketEndpoint
+ => WebSocketClientConfig t
-> Event t (RequesterData req)
- -> m (Event t (RequesterData (Either Text)))
-performWebSocketRequests url req = fmap switchPromptlyDyn $ prerender (pure never) $ do
- rec w <- webSocket url $ def
- { _webSocketConfig_send = fmap encode <$> reqs
+ -> m (Event t (RequesterData (Either Text)), WebSocketClientStatus t)
+performWebSocketRequests cfg req = do
+ d <- prerender (pure (never, statusNever)) $ do
+ rec w <- webSocket (_webSocketClientConfig_url cfg) $ WebSocketConfig
+ { _webSocketConfig_send = fmap encode <$> reqs
+ , _webSocketConfig_close = _webSocketClientConfig_close cfg
+ , _webSocketConfig_reconnect = _webSocketClientConfig_reconnect cfg
+ , _webSocketConfig_protocols = _webSocketClientConfig_protocols cfg
+ }
+ let decoded = ffor (_webSocket_recv w) $ \msg -> case decodeStrict msg of
+ Just r -> Right r
+ Nothing -> Left msg
+ rsp = fmapMaybe (either (const Nothing) Just) decoded
+ unparseable = fmapMaybe (either Just (const Nothing)) decoded
+ (reqs, rsps, unmatched) <- tagRequests req rsp
+ pure (rsps, WebSocketClientStatus
+ { _webSocketClientStatus_open = _webSocket_open w
+ , _webSocketClientStatus_error = _webSocket_error w
+ , _webSocketClientStatus_close = _webSocket_close w
+ , _webSocketClientStatus_unparseableMessage = unparseable
+ , _webSocketClientStatus_unmatchedResponse = unmatched
+ })
+ pure
+ ( switchPromptlyDyn (fst <$> d)
+ , WebSocketClientStatus
+ { _webSocketClientStatus_open = switchPromptlyDyn (_webSocketClientStatus_open . snd <$> d)
+ , _webSocketClientStatus_error = switchPromptlyDyn (_webSocketClientStatus_error . snd <$> d)
+ , _webSocketClientStatus_close = switchPromptlyDyn (_webSocketClientStatus_close . snd <$> d)
+ , _webSocketClientStatus_unparseableMessage = switchPromptlyDyn (_webSocketClientStatus_unparseableMessage . snd <$> d)
+ , _webSocketClientStatus_unmatchedResponse = switchPromptlyDyn (_webSocketClientStatus_unmatchedResponse . snd <$> d)
}
- let rsp = fmapMaybe decodeStrict $ _webSocket_recv w
- (reqs, rsps) <- tagRequests req rsp
- pure rsps
+ )
+ where
+ statusNever = WebSocketClientStatus never never never never never
--- | Constructs a response for a given request, and handles the
--- decoding/encoding and tagging steps internal to TaggedRequest and
--- TaggedResponse.
+-- | Construct a response for a request. This function does the decoding,
+-- the encoding, and the tagging that 'TaggedRequest' and 'TaggedResponse'
+-- need.
mkTaggedResponse
:: (Monad m, FromJSON (Some f), Has ToJSON f)
=> TaggedRequest
-> (forall a. f a -> m a)
-> m (Either String TaggedResponse)
-mkTaggedResponse (TaggedRequest reqId v) f = case fromJSON v of
- Success (Some a) -> do
- rsp <- f a
- pure $ Right $ TaggedResponse reqId (has @ToJSON a $ toJSON rsp)
- Error err -> pure $ Left err
+mkTaggedResponse (TaggedRequest reqId v) f =
+ fmap (fmap (TaggedResponse reqId)) $ serveApiRequest f v
--- | This function transforms a request 'Event' into an 'Event' of
--- 'TaggedRequest's (the indexed wire format used to transmit requests). It
--- expects to receive an 'Event' of 'TaggedResponse', the corresponding
--- response wire format, which it will transform into an "untagged" response.
+-- | Transform a request 'Event' into an 'Event' of 'TaggedRequest' values.
+-- 'TaggedRequest' is the indexed wire format for requests. This function
+-- expects an 'Event' of 'TaggedResponse' values. 'TaggedResponse' is the
+-- response wire format. This function transforms them into untagged
+-- responses.
--
-- @
-- requests --> |-------------| --> tagged requests
@@ -101,12 +201,16 @@
-- responses <-- |-------------| <-- tagged responses
-- @
--
--- This function is provided so that you can use a single websocket for
--- multiple purposes without reimplementing the functionality of
--- 'performWebSocketRequests'. For instance, you might have a websocket split
--- into two "channels," one for these tagged API requests and another for data
--- being pushed from the server.
+-- Use this function when one websocket serves multiple purposes. It gives
+-- you the behavior of 'performWebSocketRequests' without a dedicated
+-- socket. For example, split the socket into two channels. Use one channel
+-- for these tagged requests. Use the other channel for data that the server
+-- pushes.
--
+-- The third result reports 'TaggedResponse' values with a tag that no
+-- outstanding request uses. The tag is unknown or duplicate. Such responses
+-- are dropped from the response output. Outstanding requests survive
+-- disconnects. They are answered when a matching response arrives.
tagRequests
:: forall req t m.
( Applicative m
@@ -122,6 +226,7 @@
-> Event t TaggedResponse
-> m ( Event t [TaggedRequest]
, Event t (RequesterData (Either Text))
+ , Event t (Int, Value)
)
tagRequests req rsp = do
rec (matchedReq, matchedRsp) <- matchResponsesWithRequests enc req $
@@ -129,12 +234,14 @@
let wireReq = fmap (Map.elems . Map.mapMaybeWithKey (\t v -> case fromJSON v of
Success (r :: Value) -> Just $ TaggedRequest t r
_ -> Nothing)) matchedReq
- pure (wireReq, matchedRsp)
+ outstanding <- foldDyn ($) Set.empty $ leftmost
+ [ ffor matchedReq $ \m s -> Set.union s (Map.keysSet m)
+ , ffor rsp $ \(TaggedResponse t _) s -> Set.delete t s
+ ]
+ let unmatched = flip push rsp $ \(TaggedResponse t v) -> do
+ s <- sample $ current outstanding
+ pure $ if Set.member t s then Nothing else Just (t, v)
+ pure (wireReq, matchedRsp, unmatched)
where
enc :: forall a. req a -> (Value, Value -> Either Text a)
- enc r =
- ( toJSON r
- , \x -> case has @FromJSON r $ fromJSON x of
- Success s-> Right s
- Error e -> Left $ T.pack e
- )
+ enc = encodeApiRequest
diff --git a/src/Reflex/Dom/GadtApi/XHR.hs b/src/Reflex/Dom/GadtApi/XHR.hs
--- a/src/Reflex/Dom/GadtApi/XHR.hs
+++ b/src/Reflex/Dom/GadtApi/XHR.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -11,24 +10,44 @@
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson
import Data.Constraint.Extras (Has, has)
+import Data.Default (Default (..))
import Data.Functor (void)
import Data.Text (Text)
-import GHC.Generics
import Language.Javascript.JSaddle (MonadJSM)
import Language.Javascript.JSaddle.Monad (runJSM, askJSM)
import Reflex.Dom.Core
type ApiEndpoint = Text
--- | Takes the output of a 'RequesterT' widget and issues that
--- output as API requests. The result of this function can be
--- fed back into the requester as responses. For example:
+-- | Configuration for 'performXhrRequests' and 'apiRequestXhr'.
--
+-- 'Reflex.Dom.Xhr.postJson' builds each request as a JSON @POST@. Use
+-- '_xhrClientConfig_configureRequest' to adjust the
+-- 'Reflex.Dom.Xhr.XhrRequest' before the library sends it. For example, add
+-- headers or credentials.
+data XhrClientConfig = XhrClientConfig
+ { _xhrClientConfig_url :: ApiEndpoint
+ -- ^ URL that the requests are sent to
+ , _xhrClientConfig_configureRequest :: XhrRequest Text -> XhrRequest Text
+ -- ^ Adjust each outgoing 'XhrRequest' before it is sent
+ }
+
+-- | The default configuration uses the empty URL and does not change the
+-- requests. Set '_xhrClientConfig_url' before you use it.
+instance Default XhrClientConfig where
+ def = XhrClientConfig
+ { _xhrClientConfig_url = ""
+ , _xhrClientConfig_configureRequest = id
+ }
+
+-- | Send the output of a 'RequesterT' widget as API requests. Feed the
+-- result back into the requester as responses. For example:
+--
-- @
-- rec (appResult, requests) <- runRequesterT myApplication responses
--- responses <- performXhrRequests myApiEndpoint requests
+-- responses <- performXhrRequests (def { _xhrClientConfig_url = myApiEndpoint }) requests
-- @
---
+
performXhrRequests
:: forall t m api.
( Has FromJSON api
@@ -36,32 +55,45 @@
, Prerender t m
, Applicative m
)
- => ApiEndpoint
+ => XhrClientConfig
-> Event t (RequesterData api)
-> m (Event t (RequesterData (Either XhrError)))
-performXhrRequests apiUrl req = fmap switchPromptlyDyn $ prerender (pure never) $ do
+performXhrRequests cfg req = fmap switchPromptlyDyn $ prerender (pure never) $ do
performEventAsync $ ffor req $ \r yield -> do
ctx <- askJSM
void $ liftIO $ forkIO $ flip runJSM ctx $
- liftIO . yield =<< apiRequestXhr apiUrl r
+ liftIO . yield =<< apiRequestXhr cfg r
+-- | A failed request. The record holds the request as it was sent. It also
+-- holds the response, or the 'Reflex.Dom.Xhr.XhrException' that stopped the
+-- request. 'XhrException_Aborted' shows an aborted request.
+-- 'XhrException_Error' shows a request that could not be sent.
data XhrError = XhrError
{ _xhrError_request :: XhrRequest Text
- , _xhrError_response :: XhrResponse
+ , _xhrError_response :: Either XhrException XhrResponse
}
- deriving (Generic)
xhrErrorToText :: XhrError -> Text
xhrErrorToText e =
- let
- status = _xhrResponse_statusText . _xhrError_response $ e
- rsp = _xhrResponse_responseText . _xhrError_response $ e
- in status <> case rsp of
- Nothing -> ""
- Just r -> ": " <> r
+ let url = _xhrRequest_url $ _xhrError_request e
+ in case _xhrError_response e of
+ Left XhrException_Aborted -> "Aborted: " <> url
+ Left XhrException_Error -> "Request error: " <> url
+ Right rsp ->
+ let
+ status = _xhrResponse_statusText rsp
+ body = _xhrResponse_responseText rsp
+ in status <> case body of
+ Nothing -> ""
+ Just b -> ": " <> b
--- | Encodes an API request as JSON and issues an 'XhrRequest',
--- and attempts to decode the response.
+-- | Encode an API request as JSON. Send it with one 'XhrRequest'. Decode
+-- the response.
+--
+-- Only a response that does not decode gives an 'XhrError'. This function
+-- does not check the HTTP status of the response. A non-2xx response with a
+-- body that decodes is a success. Read '_xhrError_response' to get the
+-- status of a failed request.
apiRequestXhr
:: forall api m.
( MonadIO m
@@ -69,10 +101,10 @@
, Has FromJSON api
, forall a. ToJSON (api a)
)
- => ApiEndpoint
+ => XhrClientConfig
-> RequesterData api
-> m (RequesterData (Either XhrError))
-apiRequestXhr apiUrl = traverseRequesterData $ \x ->
+apiRequestXhr cfg = traverseRequesterData $ \x ->
has @FromJSON @api x $ mkRequest x
where
mkRequest
@@ -81,9 +113,12 @@
-> m (Either XhrError b)
mkRequest req = do
response <- liftIO newEmptyMVar
- let request = postJson apiUrl req
- _ <- newXMLHttpRequest request $ liftIO . putMVar response
- xhrResp <- liftIO $ takeMVar response
- case decodeXhrResponse xhrResp of
- Nothing -> pure $ Left $ XhrError request xhrResp
- Just r -> pure $ Right r
+ let request = _xhrClientConfig_configureRequest cfg $
+ postJson (_xhrClientConfig_url cfg) req
+ _ <- newXMLHttpRequestWithError request $ liftIO . putMVar response
+ result <- liftIO $ takeMVar response
+ pure $ case result of
+ Left e -> Left $ XhrError request (Left e)
+ Right xhrResp -> case decodeXhrResponse xhrResp of
+ Nothing -> Left $ XhrError request (Right xhrResp)
+ Just r -> Right r
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,232 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Main (main) where
+
+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), decodeStrict, encode, object, toJSON, (.=))
+import Data.ByteString.Lazy (toStrict)
+import Data.Aeson.GADT.TH (deriveJSONGADT)
+import Data.Constraint.Extras.TH (deriveArgDict)
+import Data.Either (isLeft)
+import Data.Kind (Type)
+import Data.List (isInfixOf)
+import Data.Maybe (isNothing)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import GHC.Generics (Generic)
+import Test.Hspec (describe, hspec, it, shouldBe, shouldSatisfy)
+
+import Reflex
+import Reflex.Pure
+import Reflex.Dom.GadtApi.Codec (encodeApiRequest, serveApiRequest)
+import Reflex.Dom.GadtApi.WebSocket
+
+data DogApi :: Type -> Type where
+ DogApi_GetName :: DogApi Text
+ DogApi_Count :: DogApi Int
+ DogApi_GetLast :: DogApi (Maybe Text)
+ DogApi_Report :: Text -> DogApi (Either Text ())
+
+deriveJSONGADT ''DogApi
+deriveArgDict ''DogApi
+
+newtype Token = Token { unToken :: Text }
+ deriving (Generic)
+
+instance ToJSON Token
+instance FromJSON Token
+
+data CatApi a where
+ CatApi_Identify :: Text -> CatApi (Either Text Token)
+ CatApi_DogApi :: Token -> DogApi a -> CatApi a
+
+deriveJSONGADT ''CatApi
+deriveArgDict ''CatApi
+
+-- The wire format of a request is @("", payload)@ (see aeson-gadt-th);
+-- constructors with no arguments encode @()@ as the empty array.
+tagged :: Text -> Value -> Value
+tagged reqTag payload = toJSON (reqTag, payload)
+
+handleDogApi :: DogApi a -> IO a
+handleDogApi = \case
+ DogApi_GetName -> pure "Rex"
+ DogApi_Count -> pure 2
+ DogApi_GetLast -> pure (Just "Fido")
+ DogApi_Report _ -> pure (Right ())
+
+handleCatApi :: CatApi a -> IO a
+handleCatApi = \case
+ CatApi_Identify name -> pure (Right (Token ("token-" <> name)))
+ CatApi_DogApi _ inner -> handleDogApi inner
+
+-- | A pure timeline: moments are 'Int's, and an 'Event' is just a function
+-- of the moment. This lets us drive 'RequesterT' and 'tagRequests' end to
+-- end, with real request tagging and correlation, without a host framework.
+type T = Pure Int
+
+-- | An event that fires with the given values at the given moments
+occ :: [(Int, a)] -> Event T a
+occ xs = Event (`lookup` xs)
+
+-- | One client network: a 'RequesterT' widget with one 'requesting' call per
+-- response type, wired through 'tagRequests'. Returns each requester's typed
+-- response event, the outgoing wire requests, and unmatched responses.
+buildClient
+ :: Event T (DogApi Text)
+ -> Event T (DogApi Int)
+ -> Event T (DogApi (Maybe Text))
+ -> Event T TaggedResponse
+ -> Int
+ -> ( Event T (Either Text Text)
+ , Event T (Either Text Int)
+ , Event T (Either Text (Maybe Text))
+ , Event T [TaggedRequest]
+ , Event T (Int, Value)
+ )
+buildClient eName eCount eLast rsp t0 =
+ let widget = do
+ wName <- requesting eName
+ wCount <- requesting eCount
+ wLast <- requesting eLast
+ pure (wName, wCount, wLast)
+ ((rName, rCount, rLast), reqs) = runRequesterT widget responses t0
+ (wire, responses, unmatched) = tagRequests reqs rsp t0
+ in (rName, rCount, rLast, wire, unmatched)
+
+-- | Observation of an event at every listed moment
+atEach :: [Int] -> Event T a -> [(Int, Maybe a)]
+atEach ts e = fmap (\t -> (t, unEvent e t)) ts
+
+main :: IO ()
+main = hspec $ do
+ describe "encodeApiRequest" $ do
+ it "encodes the request and decodes a matching response" $ do
+ let (v, dec) = encodeApiRequest DogApi_GetName
+ v `shouldBe` tagged "DogApi_GetName" (toJSON ())
+ dec (String "Rex") `shouldBe` Right "Rex"
+ it "uses each request's own response dictionary" $ do
+ let (_, decText) = encodeApiRequest DogApi_GetName
+ (_, decInt) = encodeApiRequest DogApi_Count
+ (_, decMaybe) = encodeApiRequest DogApi_GetLast
+ (_, decEither) = encodeApiRequest (DogApi_Report "Fido")
+ decText (String "Rex") `shouldBe` Right "Rex"
+ decInt (Number 3) `shouldBe` Right 3
+ decMaybe Null `shouldBe` Right Nothing
+ decEither (object ["Left" .= ("no such dog" :: Text)]) `shouldBe` Right (Left "no such dog")
+ it "reports responses that do not match the response type" $ do
+ let (_, decInt) = encodeApiRequest DogApi_Count
+ decInt (String "seven") `shouldSatisfy` isLeft
+ it "supports nested APIs" $ do
+ let (v, dec) = encodeApiRequest (CatApi_DogApi (Token "t") DogApi_Count)
+ v `shouldBe` tagged "CatApi_DogApi" (toJSON (Token "t", tagged "DogApi_Count" (toJSON ())))
+ dec (Number 3) `shouldBe` Right 3
+
+ describe "serveApiRequest" $ do
+ it "decodes, interprets, and encodes a request" $ do
+ r <- serveApiRequest handleCatApi (tagged "CatApi_Identify" (toJSON ("felix" :: Text)))
+ r `shouldBe` Right (object ["Right" .= object ["unToken" .= ("token-felix" :: Text)]])
+ it "decodes nested requests with the inner response type" $ do
+ r <- serveApiRequest handleCatApi
+ (tagged "CatApi_DogApi" (toJSON (Token "t", tagged "DogApi_GetLast" (toJSON ()))))
+ r `shouldBe` Right (String "Fido")
+ it "rejects unknown request tags" $ do
+ r <- serveApiRequest handleCatApi (tagged "CatApi_Nonsense" (toJSON ()))
+ r `shouldSatisfy` \case
+ Left e -> "CatApi_Nonsense" `isInfixOf` e
+ Right _ -> False
+ it "rejects malformed request payloads" $ do
+ r <- serveApiRequest handleCatApi (tagged "CatApi_Identify" (toJSON (5 :: Int)))
+ r `shouldSatisfy` isLeft
+
+ describe "mkTaggedResponse" $ do
+ it "interprets and re-tags a request" $ do
+ r <- mkTaggedResponse
+ (TaggedRequest 7 (tagged "DogApi_GetName" (toJSON ())))
+ handleDogApi
+ fmap encode r `shouldBe` Right (encode (TaggedResponse 7 (String "Rex")))
+ it "rejects malformed request values" $ do
+ r <- mkTaggedResponse (TaggedRequest 7 (Number 1)) handleDogApi
+ fmap encode r `shouldSatisfy` isLeft
+
+ describe "TaggedResponse wire format" $ do
+ it "round-trips through JSON" $ do
+ let rsp = TaggedResponse 1 (String "Rex")
+ fmap encode (decodeStrict (toStrict (encode rsp)) :: Maybe TaggedResponse) `shouldBe` Just (encode rsp)
+ it "does not decode malformed frames" $ do
+ isNothing (decodeStrict "{" :: Maybe TaggedResponse) `shouldBe` True
+ isNothing (decodeStrict "not json" :: Maybe TaggedResponse) `shouldBe` True
+
+ describe "tagRequests" $ do
+ it "issues sequentially tagged requests and correlates responses" $ do
+ let (rName, _, _, wire, unmatched) =
+ buildClient (occ [(1, DogApi_GetName)]) never never
+ (occ [(2, TaggedResponse 1 (String "Rex"))]) 0
+ fmap toJSON <$> unEvent wire 1 `shouldBe` Just [toJSON (1 :: Int, tagged "DogApi_GetName" (toJSON ()))]
+ atEach [1 .. 3] rName `shouldBe` [(1, Nothing), (2, Just (Right "Rex")), (3, Nothing)]
+ atEach [1 .. 3] unmatched `shouldBe` [(t, Nothing) | t <- [1 .. 3]]
+
+ it "correlates out-of-order responses" $ do
+ let (rName, rCount, _, _, unmatched) =
+ buildClient (occ [(1, DogApi_GetName)]) (occ [(2, DogApi_Count)]) never
+ (occ [ (3, TaggedResponse 2 (Number 7))
+ , (4, TaggedResponse 1 (String "Rex"))
+ ]) 0
+ atEach [1 .. 4] rCount `shouldBe`
+ [(1, Nothing), (2, Nothing), (3, Just (Right 7)), (4, Nothing)]
+ atEach [1 .. 4] rName `shouldBe`
+ [(1, Nothing), (2, Nothing), (3, Nothing), (4, Just (Right "Rex"))]
+ atEach [1 .. 4] unmatched `shouldBe` [(t, Nothing) | t <- [1 .. 4]]
+
+ it "tags multiple requests issued in the same frame" $ do
+ let (rName, rCount, _, wire, _) =
+ buildClient (occ [(1, DogApi_GetName)]) (occ [(1, DogApi_Count)]) never
+ (occ [ (2, TaggedResponse 1 (Number 7))
+ , (3, TaggedResponse 2 (String "Rex"))
+ ]) 0
+ fmap toJSON <$> unEvent wire 1 `shouldBe`
+ Just [ toJSON (1 :: Int, tagged "DogApi_Count" (toJSON ()))
+ , toJSON (2 :: Int, tagged "DogApi_GetName" (toJSON ())) ]
+ atEach [1 .. 3] rCount `shouldBe` [(1, Nothing), (2, Just (Right 7)), (3, Nothing)]
+ atEach [1 .. 3] rName `shouldBe` [(1, Nothing), (2, Nothing), (3, Just (Right "Rex"))]
+
+ it "reports responses with unknown tags instead of dropping them" $ do
+ let (rName, _, _, _, unmatched) =
+ buildClient (occ [(1, DogApi_GetName)]) never never
+ (occ [(2, TaggedResponse 99 (String "Rex"))]) 0
+ atEach [1 .. 2] rName `shouldBe` [(1, Nothing), (2, Nothing)]
+ atEach [1 .. 2] unmatched `shouldBe` [(1, Nothing), (2, Just (99, String "Rex"))]
+
+ it "reports duplicate responses instead of dropping them" $ do
+ let (rName, _, _, _, unmatched) =
+ buildClient (occ [(1, DogApi_GetName)]) never never
+ (occ [ (2, TaggedResponse 1 (String "Rex"))
+ , (3, TaggedResponse 1 (String "Rex again"))
+ ]) 0
+ atEach [1 .. 3] rName `shouldBe`
+ [(1, Nothing), (2, Just (Right "Rex")), (3, Nothing)]
+ atEach [1 .. 3] unmatched `shouldBe`
+ [(1, Nothing), (2, Nothing), (3, Just (1, String "Rex again"))]
+
+ it "surfaces malformed payloads as request errors and retires the tag" $ do
+ let (rName, _, _, _, unmatched) =
+ buildClient (occ [(1, DogApi_GetName)]) never never
+ (occ [ (2, TaggedResponse 1 (Number 7)) -- not Text
+ , (3, TaggedResponse 1 (String "late retry"))
+ ]) 0
+ unEvent rName 1 `shouldBe` Nothing
+ unEvent rName 2 `shouldSatisfy` \case
+ Just (Left e) -> "Text" `isInfixOf` Text.unpack e
+ _ -> False
+ unEvent rName 3 `shouldBe` Nothing
+ atEach [1 .. 3] unmatched `shouldBe`
+ [(1, Nothing), (2, Nothing), (3, Just (1, String "late retry"))]