diff --git a/ChangeLog.md b/ChangeLog.md index 416544c..23be7e6 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for reflex-gadt-api +## 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`. + ## 0.2.2.3 * Support GHC 9.12 diff --git a/Readme.md b/Readme.md index e56ef69..621d68b 100644 --- a/Readme.md +++ b/Readme.md @@ -150,10 +150,17 @@ The `Event` of responses comes, in this case, from a function that will take the ```haskell > responses <- case endpoint of -> Left xhr -> performXhrRequests xhr (requests :: Event t (RequesterData CatApi)) +> Left xhr -> do +> r <- performXhrRequests xhr (requests :: Event t (RequesterData CatApi)) +> performEvent $ ffor r $ traverseRequesterData $ \x -> +> pure $ mapLeft xhrErrorToText x > Right ws -> performWebSocketRequests ws (requests :: Event t (RequesterData CatApi)) > pure () > where +> mapLeft f = \case +> Right a -> Right a +> Left x -> Left $ f x +> ``` diff --git a/example/.obelisk/impl/github.json b/example/.obelisk/impl/github.json index cd98f24..34decc4 100644 --- a/example/.obelisk/impl/github.json +++ b/example/.obelisk/impl/github.json @@ -3,6 +3,6 @@ "repo": "obelisk", "branch": "develop", "private": false, - "rev": "3b618ec6e42af4a6fffe87e8b424387ca06c767f", - "sha256": "17cvazh0fcb74hrqsh8zh0siyr4sjm39dkrmdj07c0ng8v4ri82w" + "rev": "d420659bf7b81094921519f1f9243f7f11cc3fc2", + "sha256": "1irwjc783cr8s52vcfsz21zh17p61qp6kabaxn2qpkqfy7n2g71c" } diff --git a/reflex-gadt-api.cabal b/reflex-gadt-api.cabal index aabe712..68ae2ec 100644 --- a/reflex-gadt-api.cabal +++ b/reflex-gadt-api.cabal @@ -1,12 +1,12 @@ -cabal-version: >=1.10 +cabal-version: 3.0 name: reflex-gadt-api -version: 0.2.2.3 +version: 0.3.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. bug-reports: https://github.com/reflex-frp/reflex-gadt-api/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Obsidian Systems maintainer: maintainer@obsidian.systems @@ -17,7 +17,7 @@ extra-source-files: ChangeLog.md Readme.md -tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.8.2 || ==9.10.1 || ==9.12.1 +tested-with: GHC ==8.10.7 || ==9.10 || ==9.12 library hs-source-dirs: src, . @@ -25,7 +25,6 @@ library aeson >=1.4.4 && <2.3 , aeson-gadt-th >=0.2.4 && <0.3 , base >=4.12 && <4.22 - , bytestring >=0.10.8 && <0.13 , constraints-extras >=0.3.0 && <0.5 , containers >=0.6 && <0.8 , data-default >=0.6 && <0.9 diff --git a/src/Reflex/Dom/GadtApi/XHR.hs b/src/Reflex/Dom/GadtApi/XHR.hs index 0ee92a3..fe64522 100644 --- a/src/Reflex/Dom/GadtApi/XHR.hs +++ b/src/Reflex/Dom/GadtApi/XHR.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,11 +10,10 @@ module Reflex.Dom.GadtApi.XHR where import Control.Concurrent (forkIO, 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.Functor (void) import Data.Text (Text) -import qualified Data.Text.Encoding as T +import GHC.Generics import Language.Javascript.JSaddle (MonadJSM) import Language.Javascript.JSaddle.Monad (runJSM, askJSM) import Reflex.Dom.Core @@ -38,13 +38,28 @@ performXhrRequests ) => ApiEndpoint -> Event t (RequesterData api) - -> m (Event t (RequesterData (Either Text))) + -> m (Event t (RequesterData (Either XhrError))) performXhrRequests apiUrl 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 +data XhrError = XhrError + { _xhrError_request :: XhrRequest Text + , _xhrError_response :: 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 + -- | Encodes an API request as JSON and issues an 'XhrRequest', -- and attempts to decode the response. apiRequestXhr @@ -56,21 +71,19 @@ apiRequestXhr ) => ApiEndpoint -> RequesterData api - -> m (RequesterData (Either Text)) + -> m (RequesterData (Either XhrError)) apiRequestXhr apiUrl = traverseRequesterData $ \x -> has @FromJSON @api x $ mkRequest x where mkRequest :: (MonadJSM m, FromJSON b) => api b - -> m (Either Text b) + -> m (Either XhrError b) mkRequest req = do response <- liftIO newEmptyMVar - _ <- newXMLHttpRequest (postJson apiUrl req) $ - liftIO . putMVar response + let request = postJson apiUrl req + _ <- newXMLHttpRequest request $ 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) + Nothing -> pure $ Left $ XhrError request xhrResp Just r -> pure $ Right r