reflex-gadt-api 0.1.0.0 → 0.2.0.0

raw patch · 7 files changed

+262/−96 lines, 7 filesdep +containersdep +data-defaultdep +dependent-sumPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, data-default, dependent-sum, reflex

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• Readme.lhs +12/−9
• Readme.md +12/−9
• reflex-gadt-api.cabal +11/−5
• src/Reflex/Dom/GadtApi.hs +5/−73
• src/Reflex/Dom/GadtApi/WebSocket.hs +144/−0
• src/Reflex/Dom/GadtApi/XHR.hs +73/−0

@@ -1,5 +1,10 @@ # Revision history for reflex-gadt-api +## 0.2.0.0++* Add WebSocket interface+* Breaking Change: `performXhrRequests` now returns an `Event` instead of a `Dynamic` of an `Event`.+ ## 0.1.0.0  * XML HTTP Request FRP interface for interacting with an API defined as a GADT

@@ -1,8 +1,9 @@ reflex-gadt-api ===============-[![travis-ci](https://api.travis-ci.org/reflex-frp/reflex-gadt-api.svg?branch=develop)](https://travis-ci.org/reflex-frp/reflex-gadt-api)+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex-gadt-api.svg)](https://hackage.haskell.org/package/reflex-gadt-api) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex-gadt-api/badge)](https://matrix.hackage.haskell.org/#/package/reflex-gadt-api) [![Travis CI](https://api.travis-ci.org/reflex-frp/reflex-gadt-api.svg?branch=develop)](https://travis-ci.org/reflex-frp/reflex-gadt-api) [![Github CI](https://github.com/reflex-frp/reflex-gadt-api/workflows/Haskell%20CI/badge.svg)](https://github.com/reflex-frp/reflex-gadt-api/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex-gadt-api/blob/master/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).@@ -41,7 +42,7 @@ > import Data.Time (UTCTime, Day) > import GHC.Generics (Generic) > import Reflex.Dom.Core-> import Reflex.Dom.GadtApi (ApiEndpoint, performXhrRequests)+> import Reflex.Dom.GadtApi >  ```@@ -126,9 +127,9 @@ >      , Has FromJSON CatApi >      , forall a. ToJSON (CatApi a) >      )->   => ApiEndpoint+>   => Either ApiEndpoint WebSocketEndpoint >   -> m ()-> startCatnet apiUrl = do+> startCatnet endpoint = do  ``` `runRequesterT` expects us to provide some reflex widget as its first argument (here `start`). The reflex widget is able to issue API requests, and one of the results of `runRequesterT` is an `Event` of those requests.@@ -138,20 +139,22 @@  ```haskell ->   rec (_, requests) <- runRequesterT start $ switchPromptlyDyn responses+>   rec (_, requests) <- runRequesterT start responses  ``` -The `Event` of responses comes, in this case, from `Reflex.Dom.GadtApi.performXhrRequests`, which will take the requests emitted on the previous line and fetch responses (using XHR requests) to those requests. It produces an `Event` of responses.-+The `Event` of responses comes, in this case, from a functoin 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. ```haskell ->       responses <- performXhrRequests apiUrl (requests :: Event t (RequesterData CatApi))+>       responses <- case endpoint of+>         Left xhr -> performXhrRequests xhr (requests :: Event t (RequesterData CatApi))+>         Right ws -> performWebSocketRequests ws (requests :: Event t (RequesterData CatApi)) >   pure () >   where  ``` + Our `start` widget has the type `Catnet t m ()`, so it (and its child widgets) can potentially issue `CatApi` requests.  The actual widget code here isn't important to the way that `RequesterT` works, nor is this meant to be production-grade application. Nevertheless, there are a few interesting bits that we'll point out.@@ -177,7 +180,7 @@  ``` -If you're building your frontend in a context where the user interface needs to be susceptible to server-side rendering (for example, if you're using Obelisk's "prerendering" functionality to serve static pages that are "hydrated" once the JS loads), you'll need to wrap any code relying on Javascript (e.g., your XHR requests) in a `prerender`. The function below does this for us.+If you're building your frontend in a context where the user interface needs to be susceptible to server-side rendering (for example, if you're using [obelisk](https://github.com/obsidiansystems/obelisk)'s "prerendering" functionality to serve static pages that are "hydrated" once the JS loads), you'll need to wrap any code relying on Javascript (e.g., your XHR requests) in a `prerender`. The function below does this for us.  ```haskell 

@@ -1,8 +1,9 @@ reflex-gadt-api ===============-[![travis-ci](https://api.travis-ci.org/reflex-frp/reflex-gadt-api.svg?branch=develop)](https://travis-ci.org/reflex-frp/reflex-gadt-api)+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex-gadt-api.svg)](https://hackage.haskell.org/package/reflex-gadt-api) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex-gadt-api/badge)](https://matrix.hackage.haskell.org/#/package/reflex-gadt-api) [![Travis CI](https://api.travis-ci.org/reflex-frp/reflex-gadt-api.svg?branch=develop)](https://travis-ci.org/reflex-frp/reflex-gadt-api) [![Github CI](https://github.com/reflex-frp/reflex-gadt-api/workflows/Haskell%20CI/badge.svg)](https://github.com/reflex-frp/reflex-gadt-api/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex-gadt-api/blob/master/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).@@ -41,7 +42,7 @@ > import Data.Time (UTCTime, Day) > import GHC.Generics (Generic) > import Reflex.Dom.Core-> import Reflex.Dom.GadtApi (ApiEndpoint, performXhrRequests)+> import Reflex.Dom.GadtApi >  ```@@ -126,9 +127,9 @@ >      , Has FromJSON CatApi >      , forall a. ToJSON (CatApi a) >      )->   => ApiEndpoint+>   => Either ApiEndpoint WebSocketEndpoint >   -> m ()-> startCatnet apiUrl = do+> startCatnet endpoint = do  ``` `runRequesterT` expects us to provide some reflex widget as its first argument (here `start`). The reflex widget is able to issue API requests, and one of the results of `runRequesterT` is an `Event` of those requests.@@ -138,20 +139,22 @@  ```haskell ->   rec (_, requests) <- runRequesterT start $ switchPromptlyDyn responses+>   rec (_, requests) <- runRequesterT start responses  ``` -The `Event` of responses comes, in this case, from `Reflex.Dom.GadtApi.performXhrRequests`, which will take the requests emitted on the previous line and fetch responses (using XHR requests) to those requests. It produces an `Event` of responses.-+The `Event` of responses comes, in this case, from a functoin 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. ```haskell ->       responses <- performXhrRequests apiUrl (requests :: Event t (RequesterData CatApi))+>       responses <- case endpoint of+>         Left xhr -> performXhrRequests xhr (requests :: Event t (RequesterData CatApi))+>         Right ws -> performWebSocketRequests ws (requests :: Event t (RequesterData CatApi)) >   pure () >   where  ``` + Our `start` widget has the type `Catnet t m ()`, so it (and its child widgets) can potentially issue `CatApi` requests.  The actual widget code here isn't important to the way that `RequesterT` works, nor is this meant to be production-grade application. Nevertheless, there are a few interesting bits that we'll point out.@@ -177,7 +180,7 @@  ``` -If you're building your frontend in a context where the user interface needs to be susceptible to server-side rendering (for example, if you're using Obelisk's "prerendering" functionality to serve static pages that are "hydrated" once the JS loads), you'll need to wrap any code relying on Javascript (e.g., your XHR requests) in a `prerender`. The function below does this for us.+If you're building your frontend in a context where the user interface needs to be susceptible to server-side rendering (for example, if you're using [obelisk](https://github.com/obsidiansystems/obelisk)'s "prerendering" functionality to serve static pages that are "hydrated" once the JS loads), you'll need to wrap any code relying on Javascript (e.g., your XHR requests) in a `prerender`. The function below does this for us.  ```haskell 

@@ -1,9 +1,7 @@ cabal-version:      >=1.10 name:               reflex-gadt-api-version:            0.1.0.0-synopsis:-  Interact with a GADT API in your reflex-dom application.-+version:            0.2.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. @@ -30,12 +28,20 @@     , bytestring          >=0.10.8 && <0.11     , constraints         >=0.10.1 && <0.11     , constraints-extras  >=0.3.0  && <0.4+    , containers          >=0.6    && <0.7+    , data-default        >=0.6    && <0.8+    , dependent-sum       >=0.6.2  && <0.7     , jsaddle             >=0.9.7  && <0.10+    , reflex              >=0.7    && <0.8     , reflex-dom-core     >=0.6.0  && <0.7     , text                >=1.2    && <1.3     , time                >=1.6.0  && <2 -  exposed-modules:  Reflex.Dom.GadtApi+  exposed-modules:+    Reflex.Dom.GadtApi+    Reflex.Dom.GadtApi.WebSocket+    Reflex.Dom.GadtApi.XHR+   default-language: Haskell2010   ghc-options:      -Wall 

@@ -1,74 +1,6 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-module Reflex.Dom.GadtApi where--import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Aeson-import qualified Data.ByteString.Lazy as LBS-import Data.Constraint.Extras (Has, has)-import Data.Text (Text)-import qualified Data.Text.Encoding as T-import Language.Javascript.JSaddle (MonadJSM)-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:------ @--- rec (appResult, requests) <- runRequesterT myApplication $---       switchPromptlyDyn responses---     responses <- performXhrRequests myApiEndpoint requests--- @----performXhrRequests-  :: forall t m api js.-     ( Has FromJSON api-     , forall a. ToJSON (api a)-     , Prerender js t m-     , Applicative m-     )-  => ApiEndpoint-  -> Event t (RequesterData api)-  -> m (Dynamic t (Event t (RequesterData (Either Text))))-performXhrRequests apiUrl req = prerender (pure never) $-  performEventAsync $ ffor req $ \r yield ->-    liftIO . yield =<< apiRequestXhr apiUrl r+module Reflex.Dom.GadtApi +  ( module X+  ) where --- | Encodes an API request as JSON and issues an 'XhrRequest',--- and attempts to decode the response.-apiRequestXhr-  :: forall api m.-     ( MonadIO m-     , HasJSContext m-     , MonadJSM m-     , Has FromJSON api-     , forall a. ToJSON (api a)-     )-  => ApiEndpoint-  -> RequesterData api-  -> m (RequesterData (Either Text))-apiRequestXhr apiUrl = traverseRequesterData $ \x ->-  has @FromJSON @api x $ mkRequest x-  where-    mkRequest-      :: (HasJSContext m, MonadJSM m, FromJSON b)-      => api b-      -> m (Either Text b)-    mkRequest req = do-      response <- liftIO newEmptyMVar-      _ <- newXMLHttpRequest (postJson apiUrl req) $-        liftIO . putMVar response-      xhrResp <- liftIO $ takeMVar response-      case decodeXhrResponse xhrResp of-        Nothing -> pure $ Left $-          "Response could not be decoded for request: " <>-            T.decodeUtf8 (LBS.toStrict $ encode req)-        Just r -> pure $ Right r+import Reflex.Dom.GadtApi.WebSocket as X+import Reflex.Dom.GadtApi.XHR as X

@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Reflex.Dom.GadtApi.WebSocket+  ( performWebSocketRequests+  , TaggedRequest+  , TaggedResponse+  , mkTaggedResponse+  , WebSocketEndpoint+  , tagRequests+  ) where++import Control.Monad.Fix (MonadFix)+import Data.Constraint.Extras+import Data.Constraint.Forall+import Data.Aeson+import Data.Default+import qualified Data.Text as T+import Data.Typeable+import GHC.Generics+import qualified Data.Map as Map+import Data.Some+import Data.Text (Text)++import Reflex+import Reflex.Dom.Core (Prerender, prerender)+import Reflex.Dom.WebSocket++-- | A request tagged with an identifier+data TaggedRequest = TaggedRequest Int Value+  deriving (Typeable, Generic)++instance FromJSON TaggedRequest+instance ToJSON TaggedRequest++-- | A response tagged with an identifier matching the one in the 'TaggedRequest'. The identifier is the first argument.+data TaggedResponse = TaggedResponse Int Value+  deriving (Typeable, Generic)++instance FromJSON TaggedResponse+instance ToJSON TaggedResponse++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:+--+-- @+-- rec (appResult, requests) <- runRequesterT myApplication responses+--     responses <- performWebSocketRequests myEndpoint requests+-- @+--+performWebSocketRequests+  :: forall req js t m.+     ( Prerender js t m, Applicative m+     , FromJSON (Some req)+     , forall a. ToJSON (req a)+     , ForallF ToJSON req+     , Has FromJSON req+     )+  => WebSocketEndpoint+  -> 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+        }+      let rsp = fmapMaybe decodeStrict $ _webSocket_recv w+      (reqs, rsps) <- tagRequests req rsp+  pure rsps++-- | Constructs a response for a given request, and handles the+-- decoding/encoding and tagging steps internal to TaggedRequest and+-- TaggedResponse.+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++-- | 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.+--+-- @+--   requests  --> |-------------| --> tagged requests+--     /           |             |                 \+-- Client          | tagRequests |                Server+--     \           |             |                 /+--   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.+--+tagRequests+  :: forall req t m.+     ( Applicative m+     , FromJSON (Some req)+     , forall a. ToJSON (req a)+     , ForallF ToJSON req+     , Has FromJSON req+     , Monad m+     , MonadFix m+     , Reflex t+     , MonadHold t m+     )+  => Event t (RequesterData req)+  -> Event t TaggedResponse+  -> m ( Event t [TaggedRequest]+       , Event t (RequesterData (Either Text))+       )+tagRequests req rsp = do+  rec (matchedReq, matchedRsp) <- matchResponsesWithRequests enc req $+        ffor rsp $ \(TaggedResponse t v) -> (t, v)+      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)+  where+    enc :: forall a. req a -> (Value, Value -> Either Text a)+    enc r =+      ( whichever @ToJSON @req @a $ toJSON r+      , \x -> case has @FromJSON r $ fromJSON x of+        Success s-> Right s+        Error e -> Left $ T.pack e+      )

@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Reflex.Dom.GadtApi.XHR where++import Control.Concurrent (newEmptyMVar, putMVar, takeMVar)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson+import qualified Data.ByteString.Lazy as LBS+import Data.Constraint.Extras (Has, has)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Language.Javascript.JSaddle (MonadJSM)+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:+--+-- @+-- rec (appResult, requests) <- runRequesterT myApplication responses+--     responses <- performXhrRequests myApiEndpoint requests+-- @+--+performXhrRequests+  :: forall t m api js.+     ( Has FromJSON api+     , forall a. ToJSON (api a)+     , Prerender js t m+     , Applicative m+     )+  => ApiEndpoint+  -> Event t (RequesterData api)+  -> m (Event t (RequesterData (Either Text)))+performXhrRequests apiUrl req = fmap switchPromptlyDyn $ prerender (pure never) $+  performEventAsync $ ffor req $ \r yield ->+    liftIO . yield =<< apiRequestXhr apiUrl r++-- | Encodes an API request as JSON and issues an 'XhrRequest',+-- and attempts to decode the response.+apiRequestXhr+  :: forall api m.+     ( MonadIO m+     , HasJSContext m+     , MonadJSM m+     , Has FromJSON api+     , forall a. ToJSON (api a)+     )+  => ApiEndpoint+  -> RequesterData api+  -> m (RequesterData (Either Text))+apiRequestXhr apiUrl = traverseRequesterData $ \x ->+  has @FromJSON @api x $ mkRequest x+  where+    mkRequest+      :: (HasJSContext m, MonadJSM m, FromJSON b)+      => api b+      -> m (Either Text b)+    mkRequest req = do+      response <- liftIO newEmptyMVar+      _ <- newXMLHttpRequest (postJson apiUrl req) $+        liftIO . putMVar response+      xhrResp <- liftIO $ takeMVar response+      case decodeXhrResponse xhrResp of+        Nothing -> pure $ Left $+          "Response could not be decoded for request: " <>+            T.decodeUtf8 (LBS.toStrict $ encode req)+        Just r -> pure $ Right r