Merge pull request #20 from reflex-frp/aa/better-xhr-error

Provide more informative xhr errors

Author: ali-abrar

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

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
+>
 
 ```
 

example/.obelisk/impl/github.json

@@ -3,6 +3,6 @@
   "repo": "obelisk",
   "branch": "develop",
   "private": false,
-  "rev": "3b618ec6e42af4a6fffe87e8b424387ca06c767f",
-  "sha256": "17cvazh0fcb74hrqsh8zh0siyr4sjm39dkrmdj07c0ng8v4ri82w"
+  "rev": "d420659bf7b81094921519f1f9243f7f11cc3fc2",
+  "sha256": "1irwjc783cr8s52vcfsz21zh17p61qp6kabaxn2qpkqfy7n2g71c"
 }

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:         [email protected]
@@ -17,15 +17,14 @@ 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, .
   build-depends:
       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

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