fix: request api sucks less now

src/HTTP.js

@@ -1,3 +1,13 @@
-/** @type {(_: string) => (_: string) => (_: Record<string, string>) => (_: null | string | FormData) => () => Promise<Response>} */
-export const fetchImpl = url => method => headers => body => () =>
-  fetch(url, { redirect: 'manual', body, method, headers })
+/**
+ * @typedef {{
+ *   body: string | ArrayBuffer | Blob | FormData | null,
+ *   headers: Record<string, string>,
+ *   credentials: RequestCredentials,
+ *   method: string,
+ *   url: string,
+ * }} RequestInit
+ */
+
+/** @type {(o: RequestInit) => () => Promise<Response>} */
+export const fetchImpl = o => () =>
+  fetch(o.url, {...o, redirect: 'manual'})

src/HTTP.purs

@@ -4,30 +4,72 @@ import Prelude
 
 import Control.Promise (Promise)
 import Control.Promise as Promise
+import Data.Newtype (unwrap)
 import Data.Nullable (Nullable)
 import Data.Nullable as Nullable
 import Data.URL (URL)
+import Data.URL as URL
 import Effect (Effect)
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Foreign.Object (Object)
 import Foreign.Object as Object
-import HTTP.Header (Headers(..))
+import HTTP.Header (Headers)
 import HTTP.Header (headers) as X
-import HTTP.Request (bodyToRaw)
-import HTTP.Request (class Request, Method(..)) as X
+import HTTP.Request (Body(..), Credentials(..), Method, RawBody, bodyHeaders, bodyToRaw)
+import HTTP.Request (Method(..)) as X
 import HTTP.Request as Req
 import HTTP.Response (Response)
+import Prim.Row (class Nub, class Union)
+import Record as Record
+import Type.Prelude (Proxy(..))
 
-foreign import fetchImpl :: URL -> String -> Object String -> Nullable Req.RawRequestBody -> Effect (Promise Response)
+foreign import fetchImpl
+  :: forall r
+   . Record
+       ( body :: Nullable RawBody
+       , headers :: Object String
+       , credentials :: String
+       , method :: String
+       , url :: String
+       | r
+       )
+  -> Effect (Promise Response)
 
-fetch :: forall m a. MonadAff m => Req.Request a => a -> m Response
-fetch req = do
-  url <- Req.requestUrl req
-  method <- Req.requestMethod req
-  body <- Req.requestBody req
-  bodyRaw <- bodyToRaw body
-  Headers headers <- Req.requestHeaders req
+type OptionalFields =
+  ( body :: Body
+  , headers :: Headers
+  , credentials :: Credentials
+  )
 
+makeOptionalFields
+  :: forall @x xm o
+   . Nub o OptionalFields
+  => Union x OptionalFields o
+  => Union x xm OptionalFields
+  => {|x}
+  -> Record OptionalFields
+makeOptionalFields x =
+  let
+    default :: Record OptionalFields
+    default =
+      { body: BodyEmpty
+      , headers: mempty
+      , credentials: SameSiteCredentials
+      }
+  in
+    Record.merge x default
+
+fetch
+  :: forall x xm m o
+   . MonadAff m
+  => Nub o OptionalFields
+  => Union x OptionalFields o
+  => Union x xm OptionalFields
+  => URL
+  -> Method
+  -> {|x}
+  -> m Response
+fetch url method x = do
   let
     methodStr = case method of
       Req.GET -> "GET"
@@ -36,6 +78,25 @@ fetch req = do
       Req.PATCH -> "PATCH"
       Req.DELETE -> "DELETE"
       Req.HEAD -> "HEAD"
-    headers' = Object.fromFoldableWithIndex headers
 
-  liftAff $ Promise.toAffE $ fetchImpl url methodStr headers' $ Nullable.toNullable bodyRaw
+    credsStr = case _ of
+      SameSiteCredentials -> "same-origin"
+      OmitCredentials -> "omit"
+      IncludeCredentials -> "include"
+
+    fields =
+      Record.modify (Proxy @"credentials") credsStr
+      $ Record.modify (Proxy @"headers") (Object.fromFoldableWithIndex <<< unwrap)
+      $ Record.insert (Proxy @"method") methodStr
+      $ Record.insert (Proxy @"url") (URL.toString url)
+      $ makeOptionalFields @x x
+
+  bodyHeaders' <- (Object.fromFoldableWithIndex <<< unwrap) <$> bodyHeaders fields.body
+  bodyRaw <- Nullable.toNullable <$> bodyToRaw fields.body
+  let
+    fields' =
+      Record.modify (Proxy @"headers") (Object.union bodyHeaders')
+      $ Record.set (Proxy @"body") bodyRaw
+      $ fields
+
+  liftAff $ Promise.toAffE $ fetchImpl fields'

src/HTTP/Node.js

@@ -1,19 +0,0 @@
-import { fetch, ProxyAgent } from 'undici'
-import { socksDispatcher } from 'fetch-socks'
-
-/** @type {(_: URL) => (_: URL) => (_: string) => (_: Record<string, string>) => (_: null | string | FormData) => () => Promise<import('undici').Response>} */
-export const fetchImpl = proxyURL => url => method => headers => body => () => {
-  const dispatcher = proxyURL.protocol.startsWith('https')
-    ? new ProxyAgent(proxyURL.host)
-    : proxyURL.protocol.startsWith('socks')
-    ? socksDispatcher({
-        type: 5,
-        host: proxyURL.hostname,
-        port: parseInt(proxyURL.port, 10),
-      })
-    : (() => {
-        throw new Error(`unsupported proxy scheme ${proxyURL.protocol}`)
-      })()
-
-  return fetch(url, { dispatcher })
-}

src/HTTP/Node.purs

@@ -1,41 +0,0 @@
-module HTTP.Node (fetchProxy, module X) where
-
-import Prelude
-
-import Control.Promise (Promise)
-import Control.Promise as Promise
-import Data.Nullable (Nullable)
-import Data.Nullable as Nullable
-import Data.URL (URL)
-import Effect (Effect)
-import Effect.Aff.Class (class MonadAff, liftAff)
-import Foreign.Object (Object)
-import Foreign.Object as Object
-import HTTP.Header (Headers(..))
-import HTTP.Header (headers) as X
-import HTTP.Request (bodyToRaw)
-import HTTP.Request (class Request, Method(..)) as X
-import HTTP.Request as Req
-import HTTP.Response (Response)
-
-foreign import fetchImpl :: URL -> URL -> String -> Object String -> Nullable Req.RawRequestBody -> Effect (Promise Response)
-
-fetchProxy :: forall m a. MonadAff m => Req.Request a => URL -> a -> m Response
-fetchProxy pxy req = do
-  url <- Req.requestUrl req
-  method <- Req.requestMethod req
-  body <- Req.requestBody req
-  bodyRaw <- bodyToRaw body
-  Headers headers <- Req.requestHeaders req
-
-  let
-    methodStr = case method of
-      Req.GET -> "GET"
-      Req.PUT -> "PUT"
-      Req.POST -> "POST"
-      Req.PATCH -> "PATCH"
-      Req.DELETE -> "DELETE"
-      Req.HEAD -> "HEAD"
-    headers' = Object.fromFoldableWithIndex headers
-
-  liftAff $ Promise.toAffE $ fetchImpl pxy url methodStr headers' $ Nullable.toNullable bodyRaw

src/HTTP/Request.purs

@@ -1,18 +1,15 @@
 module HTTP.Request
-  ( class Request
+  ( Credentials(..)
   , Body(..)
-  , RawRequestBody
+  , RawBody
   , Method(..)
+  , bodyHeaders
   , bodyToRaw
   , json
   , form
   , blob
   , arrayBuffer
-  , requestBody
-  , requestHeaders
-  , requestUrl
-  , requestMethod
-  , rawRequestBodySize
+  , rawBodySize
   ) where
 
 import Prelude
@@ -24,11 +21,7 @@ import Data.Eq.Generic (genericEq)
 import Data.Generic.Rep (class Generic)
 import Data.Maybe (Maybe(..))
 import Data.Newtype (unwrap)
-import Data.Nullable as Nullable
 import Data.Show.Generic (genericShow)
-import Data.Tuple.Containing (extract)
-import Data.Tuple.Nested (type (/\))
-import Data.URL (URL)
 import Effect (Effect)
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Class (class MonadEffect, liftEffect)
@@ -43,25 +36,27 @@ import Unsafe.Coerce (unsafeCoerce)
 import Web.File.Blob (Blob)
 import Web.File.Blob as Blob
 
-foreign import data RawRequestBody :: Type
+foreign import data RawBody :: Type
 
 foreign import blobArrayBufferImpl :: Blob -> Effect (Promise ArrayBuffer)
-foreign import rawRequestBodySize :: RawRequestBody -> Effect Int
+foreign import rawBodySize :: RawBody -> Effect Int
 
-unsafeEmptyRawRequestBody :: RawRequestBody
-unsafeEmptyRawRequestBody = unsafeCoerce Nullable.null
+unsafeStringRawBody :: String -> RawBody
+unsafeStringRawBody = unsafeCoerce
 
-unsafeStringRawRequestBody :: String -> RawRequestBody
-unsafeStringRawRequestBody = unsafeCoerce
+unsafeFormDataToRawBody :: RawFormData -> RawBody
+unsafeFormDataToRawBody = unsafeCoerce
 
-unsafeFormDataToRawRequestBody :: RawFormData -> RawRequestBody
-unsafeFormDataToRawRequestBody = unsafeCoerce
+unsafeArrayBufferToRawBody :: ArrayBuffer -> RawBody
+unsafeArrayBufferToRawBody = unsafeCoerce
 
-unsafeArrayBufferToRawRequestBody :: ArrayBuffer -> RawRequestBody
-unsafeArrayBufferToRawRequestBody = unsafeCoerce
+unsafeBlobToRawBody :: forall m. MonadAff m => Blob -> m RawBody
+unsafeBlobToRawBody = map unsafeArrayBufferToRawBody <<< liftAff <<< Promise.toAffE <<< blobArrayBufferImpl
 
-unsafeBlobToRawRequestBody :: forall m. MonadAff m => Blob -> m RawRequestBody
-unsafeBlobToRawRequestBody = map unsafeArrayBufferToRawRequestBody <<< liftAff <<< Promise.toAffE <<< blobArrayBufferImpl
+data Credentials
+  = IncludeCredentials
+  | OmitCredentials
+  | SameSiteCredentials
 
 data Body
   = BodyString String (Maybe ContentType)
@@ -89,11 +84,11 @@ bodyHeaders (BodyString _ ct) = liftEffect $ Header.headers ct
 bodyHeaders (BodyArrayBuffer _ ct) = liftEffect $ Header.headers ct
 bodyHeaders (BodyBlob b) = liftEffect $ Header.headers <<< map (ContentType <<< MIME.fromString <<< unwrap) $ Blob.type_ b
 
-bodyToRaw :: forall m. MonadAff m => Body -> m (Maybe RawRequestBody)
-bodyToRaw (BodyString body _) = pure $ Just $ unsafeStringRawRequestBody body
-bodyToRaw (BodyArrayBuffer body _) = pure $ Just $ unsafeArrayBufferToRawRequestBody body
-bodyToRaw (BodyForm form') = map Just $ map unsafeFormDataToRawRequestBody $ Form.toRawFormData form'
-bodyToRaw (BodyBlob body) = map Just $ unsafeBlobToRawRequestBody body
+bodyToRaw :: forall m. MonadAff m => Body -> m (Maybe RawBody)
+bodyToRaw (BodyString body _) = pure $ Just $ unsafeStringRawBody body
+bodyToRaw (BodyArrayBuffer body _) = pure $ Just $ unsafeArrayBufferToRawBody body
+bodyToRaw (BodyForm form') = map Just $ map unsafeFormDataToRawBody $ Form.toRawFormData form'
+bodyToRaw (BodyBlob body) = map Just $ unsafeBlobToRawBody body
 bodyToRaw BodyEmpty = pure Nothing
 
 data Method
@@ -111,57 +106,3 @@ instance Eq Method where
 instance Show Method where
   show = genericShow
 
-class Request :: Type -> Constraint
-class Request a where
-  requestUrl :: forall m. MonadAff m => a -> m URL
-  requestMethod :: forall m. MonadAff m => a -> m Method
-  requestBody :: forall m. MonadAff m => a -> m Body
-  requestHeaders :: forall m. MonadAff m => a -> m Headers
-
-instance Request (Method /\ URL /\ Body /\ Effect Headers) where
-  requestUrl = pure <<< extract
-  requestMethod = pure <<< extract
-  requestBody = pure <<< extract
-  requestHeaders req = do
-    hs <- liftEffect $ extract req
-    bodyHs <- bodyHeaders $ extract req
-    pure $ hs <> bodyHs
-
-instance Request (Method /\ URL /\ Body /\ Headers) where
-  requestUrl = pure <<< extract
-  requestMethod = pure <<< extract
-  requestBody = pure <<< extract
-  requestHeaders req = do
-    let hs = extract req
-    bodyHs <- bodyHeaders $ extract req
-    pure $ hs <> bodyHs
-
-instance Request (Method /\ URL /\ Body) where
-  requestUrl = pure <<< extract
-  requestMethod = pure <<< extract
-  requestBody = pure <<< extract
-  requestHeaders _ = pure mempty
-
-instance Request (Method /\ URL /\ Headers) where
-  requestUrl = pure <<< extract
-  requestMethod = pure <<< extract
-  requestBody _ = pure BodyEmpty
-  requestHeaders = pure <<< extract
-
-instance Request (Method /\ URL /\ Effect Headers) where
-  requestUrl = pure <<< extract
-  requestMethod = pure <<< extract
-  requestBody _ = pure BodyEmpty
-  requestHeaders = liftEffect <<< extract @(Effect Headers)
-
-instance Request (Method /\ URL) where
-  requestUrl = pure <<< extract
-  requestMethod = pure <<< extract
-  requestBody _ = pure BodyEmpty
-  requestHeaders _ = pure mempty
-
-instance Request URL where
-  requestUrl = pure
-  requestMethod _ = pure GET
-  requestBody _ = pure BodyEmpty
-  requestHeaders _ = pure mempty