Merge pull request #7 from sambnt/master

Update for new GHC JS backend

servant-jsaddle.cabal

@@ -1,5 +1,5 @@
 name: servant-jsaddle
-version: 0.16
+version: 0.17
 synopsis:
  automatic derivation of querying functions for servant webservices for jsaddle
 
@@ -46,29 +46,29 @@ library
  -- Bundled with GHC: Lower bound to not force re-installs
  -- text and mtl are bundled starting with GHC-8.4
  build-depends:
- base >=4.9 && <4.14
- , bytestring >=0.10.8.1 && <0.11
+ base >=4.9 && <5
+ , bytestring >=0.10.8.1 && <0.13
  , containers >=0.5.7.1 && <0.7
- , mtl >=2.2.2 && <2.3
- , text >=1.2.3.0 && <1.3
- , transformers >=0.5.2.0 && <0.6
+ , mtl >=2.2.2 && <2.4
+ , text >=1.2.3.0 && <2.2
+ , transformers >=0.5.2.0 && <0.7
 
- if impl(ghcjs -any)
+ if impl(ghcjs -any) || arch(javascript)
  build-depends: ghcjs-base
 
  -- Servant dependencies.
  -- Strict dependency on `servant-client-core` as we re-export things.
- build-depends: servant-client-core >=0.16 && <0.16.1
+ build-depends: servant-client-core >=0.16 && <0.21
  build-depends:
- base-compat >=0.10.5  && <0.12
+ base-compat >=0.10.5 && <=0.13.1
  , case-insensitive >=1.2.0.0 && <1.3
  , exceptions >=0.10.0 && <0.11
  , ghcjs-dom >=0.9.4.0 && <0.10
  , http-media >=0.7.1.3 && <0.9
  , http-types >=0.12.2 && <0.13
  , jsaddle >=0.9.6.0 && <0.10
  , monad-control >=1.0.2.3 && <1.1
- , semigroupoids >=5.3.1 && <5.4
+ , semigroupoids >=5.3.1 && <6.1
  , string-conversions >=0.3 && <0.5
  , transformers-base >=0.4.4 && <0.5
 
@@ -82,7 +82,7 @@ test-suite spec
  hs-source-dirs: test
  main-is: Spec.hs
 
- if impl(ghcjs -any)
+ if impl(ghcjs -any) || arch(javascript)
  build-depends:
  base
  , servant-jsaddle

src/Servant/Client/Internal/JSaddleXhrClient.hs

@@ -48,6 +48,8 @@ import Data.Foldable
  (toList)
 import Data.Functor.Alt
  (Alt (..))
+import Data.Maybe
+ (fromMaybe)
 import Data.Proxy
  (Proxy (..))
 import qualified Data.Sequence as Seq
@@ -70,7 +72,7 @@ import qualified Language.Javascript.JSaddle.Types as JSaddle
 import Network.HTTP.Media
  (renderHeader)
 import Network.HTTP.Types
- (ResponseHeaders, http11, mkStatus, renderQuery, statusCode)
+ (ResponseHeaders, Status, http11, mkStatus, renderQuery, statusCode)
 import System.IO
  (hPutStrLn, stderr)
 
@@ -120,9 +122,15 @@ instance Alt ClientM where
 
 instance RunClient ClientM where
  throwClientError = throwError
+#if MIN_VERSION_servant_client_core(0,18,1)
+ runRequestAcceptStatus acceptStatuses r = do
+ d <- ClientM askDOM
+ performRequest (fromMaybe [] acceptStatuses) d r
+#else
  runRequest r = do
  d <- ClientM askDOM
- performRequest d r
+ performRequest [] d r
+#endif
 
 runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a)
 runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm
@@ -156,16 +164,16 @@ getDefaultBaseUrl = do
 
  pure (BaseUrl protocol hostname port "")
 
-performRequest :: DOMContext -> Request -> ClientM Response
-performRequest domc req = do
+performRequest :: [Status] -> DOMContext -> Request -> ClientM Response
+performRequest acceptStatuses domc req = do
  xhr <- JS.newXMLHttpRequest `runDOM` domc
  burl <- asks baseUrl
  fixUp <- asks fixUpXhr
  performXhr xhr burl req fixUp `runDOM` domc
  resp <- toResponse domc xhr
 
  let status = statusCode (responseStatusCode resp)
- unless (status >= 200 && status < 300) $
+ unless ((status >= 200 && status < 300) || status `elem` (statusCode <$> acceptStatuses)) $
  throwError $ mkFailureResponse burl req resp
 
  pure resp