diff --git a/src/HTTP.js b/src/HTTP.js index 8f17ca5..5bdf471 100644 --- a/src/HTTP.js +++ b/src/HTTP.js @@ -1,3 +1,13 @@ -/** @type {(_: string) => (_: string) => (_: Record) => (_: null | string | FormData) => () => Promise} */ -export const fetchImpl = url => method => headers => body => () => - fetch(url, { redirect: 'manual', body, method, headers }) +/** + * @typedef {{ + * body: string | ArrayBuffer | Blob | FormData | null, + * headers: Record, + * credentials: RequestCredentials, + * method: string, + * url: string, + * }} RequestInit + */ + +/** @type {(o: RequestInit) => () => Promise} */ +export const fetchImpl = o => () => + fetch(o.url, {...o, redirect: 'manual'}) diff --git a/src/HTTP.purs b/src/HTTP.purs index 2ca3b62..2411688 100644 --- a/src/HTTP.purs +++ b/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' diff --git a/src/HTTP/Node.js b/src/HTTP/Node.js deleted file mode 100644 index 41a216f..0000000 --- a/src/HTTP/Node.js +++ /dev/null @@ -1,19 +0,0 @@ -import { fetch, ProxyAgent } from 'undici' -import { socksDispatcher } from 'fetch-socks' - -/** @type {(_: URL) => (_: URL) => (_: string) => (_: Record) => (_: null | string | FormData) => () => Promise} */ -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 }) -} diff --git a/src/HTTP/Node.purs b/src/HTTP/Node.purs deleted file mode 100644 index d96d44c..0000000 --- a/src/HTTP/Node.purs +++ /dev/null @@ -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 diff --git a/src/HTTP/Request.purs b/src/HTTP/Request.purs index 4f8486c..84b46cb 100644 --- a/src/HTTP/Request.purs +++ b/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