{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Browser Fetch transport for GHC's JavaScript backend. Same-origin cookies
-- are the default. Supply CSRF headers explicitly for unsafe cookie-authenticated
-- endpoints. Cross-origin calls require the server's CORS policy and, for
-- cross-origin cookies, IncludeCredentials. Redirects are rejected.
module Web.Spock.Api.Client.Browser (browserClient) where

import Data.Aeson (encode, object, (.=))
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GHC.JS.Prim
import Web.Spock.Api.Client

-- | Create a client with an AbortController timeout and a streaming response
-- limit. Network failures, timeout, response size, HTTP status and JSON errors
-- are distinct ClientError values. No response data or credentials are logged.
browserClient :: ClientConfig -> Either ClientError Client
browserClient :: ClientConfig -> Either ClientError Client
browserClient ClientConfig
cfg = ClientConfig -> Transport -> Either ClientError Client
newClient ClientConfig
cfg Transport
browserTransport

browserTransport :: Transport
browserTransport :: Transport
browserTransport Request
request = do
  let configuration :: Value
configuration = [Pair] -> Value
object
        [ Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Request -> Text
rq_method Request
request, Key
"url" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Request -> Text
rq_url Request
request,
          Key
"headers" Key -> [(Text, Text)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(ByteString -> Text
T.decodeLatin1 ByteString
n, ByteString -> Text
T.decodeLatin1 ByteString
v) | (ByteString
n, ByteString
v) <- Request -> [(ByteString, ByteString)]
rq_headers Request
request],
          Key
"body" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 (Request -> Maybe ByteString
rq_body Request
request),
          Key
"credentials" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Credentials -> Text
credentials (Request -> Credentials
rq_credentials Request
request),
          Key
"timeout" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Request -> Int
rq_timeoutMilliseconds Request
request,
          Key
"maxBytes" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Request -> Int
rq_maxResponseBytes Request
request ]
      argument :: JSVal
argument = String -> JSVal
toJSString (String -> JSVal) -> String -> JSVal
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encode Value
configuration
  result <- JSVal -> IO JSVal
js_fetch JSVal
argument
  errorCode <- fromJSString <$> getProp result "error"
  case errorCode of
    String
"timeout" -> Either ClientError Response -> IO (Either ClientError Response)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError Response -> IO (Either ClientError Response))
-> Either ClientError Response -> IO (Either ClientError Response)
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError Response
forall a b. a -> Either a b
Left ClientError
RequestTimedOut
    String
"large" -> Either ClientError Response -> IO (Either ClientError Response)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError Response -> IO (Either ClientError Response))
-> Either ClientError Response -> IO (Either ClientError Response)
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError Response
forall a b. a -> Either a b
Left ClientError
ResponseTooLarge
    String
"decode" -> Either ClientError Response -> IO (Either ClientError Response)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError Response -> IO (Either ClientError Response))
-> Either ClientError Response -> IO (Either ClientError Response)
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError Response
forall a b. a -> Either a b
Left ClientError
DecodeFailure
    String
"" -> do
      status <- JSVal -> Int
fromJSInt (JSVal -> Int) -> IO JSVal -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSVal -> String -> IO JSVal
getProp JSVal
result String
"status"
      body <- fromJSString <$> getProp result "body"
      pure $ Right $ Response status (T.encodeUtf8 $ T.pack body)
    String
_ -> Either ClientError Response -> IO (Either ClientError Response)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ClientError Response -> IO (Either ClientError Response))
-> Either ClientError Response -> IO (Either ClientError Response)
forall a b. (a -> b) -> a -> b
$ ClientError -> Either ClientError Response
forall a b. a -> Either a b
Left ClientError
NetworkFailure
  where
    credentials :: Credentials -> T.Text
    credentials :: Credentials -> Text
credentials Credentials
SameOrigin = Text
"same-origin"
    credentials Credentials
OmitCredentials = Text
"omit"
    credentials Credentials
IncludeCredentials = Text
"include"

foreign import javascript interruptible "h$spock_fetch"
  js_fetch :: JSVal -> IO JSVal