diff --git a/spago.yaml b/spago.yaml index a8c16f6..49bca1e 100644 --- a/spago.yaml +++ b/spago.yaml @@ -1,19 +1,24 @@ package: dependencies: - - prelude - aff + - aff-promise + - arraybuffer + - console - effect - either - - maybe - foldable-traversable - - console + - maybe - newtype + - node-buffer + - prelude + - simple-json - strings - stringutils - transformers - tuples - typelevel-prelude - name: project + - web-file + name: fetch workspace: extra_packages: {} package_set: diff --git a/src/HTTP.js b/src/HTTP.js new file mode 100644 index 0000000..8f17ca5 --- /dev/null +++ b/src/HTTP.js @@ -0,0 +1,3 @@ +/** @type {(_: string) => (_: string) => (_: Record) => (_: null | string | FormData) => () => Promise} */ +export const fetchImpl = url => method => headers => body => () => + fetch(url, { redirect: 'manual', body, method, headers }) diff --git a/src/HTTP.purs b/src/HTTP.purs new file mode 100644 index 0000000..e925f2b --- /dev/null +++ b/src/HTTP.purs @@ -0,0 +1,37 @@ +module HTTP (fetch, module X) where + +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 Effect (Effect) +import Effect.Aff.Class (class MonadAff, liftAff) +import Foreign.Object (Object) +import Foreign.Object as Object +import HTTP.Header (headers) as X +import HTTP.Request (class Request, Method(..)) as X +import HTTP.Request as Req +import HTTP.Response (Response) + +foreign import fetchImpl :: String -> String -> Object String -> Nullable Req.RawRequestBody -> 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 + headers <- Req.requestHeaders req + + let + methodStr = case method of + Req.GET -> "GET" + Req.PUT -> "PUT" + Req.POST -> "POST" + Req.PATCH -> "PATCH" + Req.DELETE -> "DELETE" + headers' = Object.fromFoldableWithIndex headers + + liftAff $ Promise.toAffE $ fetchImpl (unwrap url) methodStr headers' $ Nullable.toNullable body diff --git a/src/HTTP/Form.js b/src/HTTP/Form.js new file mode 100644 index 0000000..93220d6 --- /dev/null +++ b/src/HTTP/Form.js @@ -0,0 +1,56 @@ +/** @type {(_: Record>) => () => FormData} */ +export const unsafeMakeFormData = o => () => { + const form = new FormData() + + Object.entries(o).forEach(([k, vs]) => { + vs.forEach(v => { + form.append(k, v) + }) + }) + + return form +} + +/** @typedef {{filename: string | null, mime: string, buf: ArrayBuffer}} FileRecord */ + +/** @type {(_: FileRecord) => () => Blob} */ +export const unsafeMakeBlob = + ({ mime, buf }) => + () => + new Blob([buf], { type: mime }) + +/** @type {(_: FormData) => () => Promise>>} */ +export const unsafeUnmakeFormData = fd => async () => { + /** @type {Record>} */ + const rec = {} + for (const [k, ent_] of fd.entries()) { + /** @type {File | Blob | string} */ + const ent = ent_ + + /** @type {string | FileRecord} */ + let append = '' + if (ent instanceof File) { + append = { + filename: ent.name, + buf: await ent.arrayBuffer(), + mime: ent.type, + } + } else if (ent instanceof Blob) { + append = { filename: null, buf: await ent.arrayBuffer(), mime: ent.type } + } else { + append = ent + } + + if (!append) { + continue + } + + if (rec[k]) { + rec[k].push(append) + } else { + rec[k] = [append] + } + } + + return rec +} diff --git a/src/HTTP/Form.purs b/src/HTTP/Form.purs new file mode 100644 index 0000000..e9365bc --- /dev/null +++ b/src/HTTP/Form.purs @@ -0,0 +1,109 @@ +module HTTP.Form where + +import Prelude + +import Control.Monad.Error.Class (liftMaybe, try) +import Control.Monad.Except (runExcept) +import Control.Promise (Promise) +import Control.Promise as Promise +import Data.ArrayBuffer.ArrayBuffer as ArrayBuffer +import Data.ArrayBuffer.Types (ArrayBuffer) +import Data.Either (hush) +import Data.Foldable (foldl) +import Data.FoldableWithIndex (foldlWithIndex) +import Data.Generic.Rep (class Generic) +import Data.Map (Map) +import Data.Map as Map +import Data.Maybe (Maybe(..)) +import Data.Newtype (class Newtype, unwrap, wrap) +import Data.Nullable (Nullable) +import Data.Nullable as Nullable +import Data.Show.Generic (genericShow) +import Data.Traversable (for) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Aff (Aff) +import Effect.Aff.Class (class MonadAff, liftAff) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Exception (error) +import Foreign (Foreign, unsafeReadTagged, unsafeToForeign) +import Foreign.Object (Object) +import Foreign.Object as Object +import HTTP.Header as Header +import HTTP.MIME (MIME) +import HTTP.MIME as MIME +import Node.Buffer.Immutable (ImmutableBuffer) +import Simple.JSON (readImpl, unsafeStringify) +import Unsafe.Coerce (unsafeCoerce) +import Web.File.Blob (Blob) + +type FileRecord = { filename :: Nullable String, mime :: String, buf :: ArrayBuffer } + +foreign import data RawFormData :: Type +foreign import unsafeMakeBlob :: FileRecord -> Effect Blob +foreign import unsafeMakeFormData :: Object (Array Foreign) -> Effect RawFormData +foreign import unsafeUnmakeFormData :: RawFormData -> Effect (Promise (Object (Array Foreign))) + +newtype Filename = Filename String + +derive instance Generic Filename _ +derive instance Newtype Filename _ +instance Show Filename where + show = genericShow + +derive newtype instance Eq Filename +derive newtype instance Ord Filename + +data Value + = ValueString String + | ValueFile (Maybe Filename) ArrayBuffer MIME + +valueForeign :: Value -> Effect Foreign +valueForeign (ValueString s) = pure $ unsafeToForeign s +valueForeign (ValueFile filename buf mime) = unsafeToForeign <$> unsafeMakeBlob { filename: Nullable.toNullable $ unwrap <$> filename, buf, mime: MIME.toString mime } + +valueFromForeign :: Foreign -> Effect Value +valueFromForeign f = do + let + file :: Maybe { filename :: Nullable String, buf :: Foreign, mime :: String } + file = hush $ runExcept $ readImpl f + string = hush $ runExcept $ unsafeReadTagged "String" f + + case file of + Just { filename, buf, mime } -> + let + buf' :: ArrayBuffer + buf' = unsafeCoerce buf + in + pure $ ValueFile (wrap <$> Nullable.toMaybe filename) buf' (MIME.fromString mime) + Nothing -> do + s <- liftMaybe (error $ "invalid form value " <> unsafeStringify f) string + pure $ ValueString s + +derive instance Generic Value _ +instance Show Value where + show (ValueString s) = "(ValueString " <> show s <> ")" + show (ValueFile filename _ mime) = "(ValueFile (" <> show filename <> ") (" <> show mime <> "))" + +newtype Form = Form (Map String (Array Value)) + +derive instance Newtype Form _ +derive newtype instance Show Form + +fromRaw :: forall m. MonadAff m => RawFormData -> m Form +fromRaw f = do + obj <- liftAff $ Promise.toAffE $ unsafeUnmakeFormData f + let + formMap = Map.fromFoldableWithIndex obj + map' <- liftEffect $ for formMap (\vs -> for vs valueFromForeign) + pure $ Form map' + +toRawFormData :: forall m. MonadEffect m => Form -> m RawFormData +toRawFormData = + let + collect k o vs = do + o' <- o + vs' <- for vs valueForeign + pure $ Object.insert k vs' o' + in + liftEffect <<< flip bind unsafeMakeFormData <<< foldlWithIndex collect (pure Object.empty) <<< unwrap diff --git a/src/HTTP/Header.purs b/src/HTTP/Header.purs new file mode 100644 index 0000000..4f4a640 --- /dev/null +++ b/src/HTTP/Header.purs @@ -0,0 +1,94 @@ +module HTTP.Header where + +import Prelude + +import Data.Eq.Generic (genericEq) +import Data.Generic.Rep (class Generic) +import Data.Map (Map) +import Data.Map as Map +import Data.Maybe (Maybe, maybe) +import Data.Newtype (class Newtype, unwrap, wrap) +import Data.Show.Generic (genericShow) +import Data.Tuple (Tuple(..)) +import Effect (Effect) +import Effect.Class (class MonadEffect, liftEffect) +import HTTP.MIME (MIME) +import HTTP.MIME as MIME +import Node.Buffer as Buffer +import Node.Encoding (Encoding(..)) + +newtype ContentType = ContentType MIME + +derive instance Newtype ContentType _ +derive newtype instance Show ContentType +derive newtype instance Eq ContentType + +newtype Accept = Accept MIME + +derive instance Newtype Accept _ +derive newtype instance Show Accept +derive newtype instance Eq Accept + +newtype AuthScheme = AuthScheme String + +derive instance Newtype AuthScheme _ +derive newtype instance Show AuthScheme +derive newtype instance Eq AuthScheme +derive newtype instance Ord AuthScheme + +data Authorization + = AuthBasic { username :: String, password :: String } + | AuthBearer String + | AuthCustom AuthScheme String + +derive instance Generic Authorization _ +instance Show Authorization where + show = genericShow + +instance Eq Authorization where + eq = genericEq + +authorizationValue :: forall m. MonadEffect m => Authorization -> m String +authorizationValue (AuthBasic { username, password }) = do + buf <- liftEffect $ Buffer.fromString (username <> ":" <> password) UTF8 + val <- liftEffect $ Buffer.toString Base64 buf + authorizationValue $ AuthCustom (wrap "Basic") val +authorizationValue (AuthBearer val) = authorizationValue $ AuthCustom (wrap "Bearer") val +authorizationValue (AuthCustom (AuthScheme scheme) val) = pure $ scheme <> " " <> val + +newtype Headers = Headers (Map String String) + +derive instance Newtype Headers _ +derive newtype instance Eq Headers +derive newtype instance Ord Headers +derive newtype instance Show Headers +instance Semigroup Headers where + append (Headers amap) (Headers bmap) = wrap $ Map.union amap bmap + +instance Monoid Headers where + mempty = wrap $ Map.empty + +class IntoHeaders a where + headers :: forall m. MonadEffect m => a -> m Headers + +instance IntoHeaders Headers where + headers = pure +else instance IntoHeaders (Map String String) where + headers = pure <<< wrap +else instance IntoHeaders (Tuple String String) where + headers (Tuple k v) = headers $ Map.singleton k v +else instance IntoHeaders Unit where + headers _ = pure $ wrap Map.empty +else instance IntoHeaders ContentType where + headers = headers <<< Map.singleton "Content-Type" <<< MIME.toString <<< unwrap +else instance IntoHeaders Accept where + headers = headers <<< Map.singleton "Accept" <<< MIME.toString <<< unwrap +else instance IntoHeaders Authorization where + headers = map wrap <<< map (Map.singleton "Authorization") <<< authorizationValue +else instance (IntoHeaders a, IntoHeaders b) => IntoHeaders (Tuple a b) where + headers (Tuple a b) = do + a' <- unwrap <$> headers a + b' <- unwrap <$> headers b + headers $ Map.union a' b' +else instance IntoHeaders a => IntoHeaders (Maybe a) where + headers = maybe (pure mempty) headers diff --git a/src/HTTP/MIME.purs b/src/HTTP/MIME.purs new file mode 100644 index 0000000..4276348 --- /dev/null +++ b/src/HTTP/MIME.purs @@ -0,0 +1,166 @@ +module HTTP.MIME where + +import Prelude + +import Data.Eq.Generic (genericEq) +import Data.Generic.Rep (class Generic) +import Data.Show.Generic (genericShow) + +data MIME = Other String | Aac | Abw | Arc | Avif | Avi | Azw | Bin | Bmp | Bz | Bz2 | Cda | Csh | Css | Csv | Doc | Docx | Eot | Epub | Gz | Gif | Html | Ico | Ics | Jar | Jpeg | Js | Json | Jsonld | Midi | Mjs | Mp3 | Mp4 | Mpeg | Mpkg | Odp | Ods | Odt | Oga | Ogv | Ogx | Opus | Otf | Png | Pdf | Php | Ppt | Pptx | Rar | Rtf | Sh | Svg | Tar | Tif | Ts | Ttf | Txt | Vsd | Wav | Weba | Webm | Webp | Woff | Woff2 | Xhtml | Xls | Xlsx | Xml | Xul | Zip | Video3gp | Video3g2 | Archive7z + +derive instance Generic MIME _ +instance Show MIME where + show = genericShow + +instance Eq MIME where + eq = genericEq + +toString :: MIME -> String +toString (Other s) = s +toString Aac = "audio/aac" +toString Abw = "application/x-abiword" +toString Arc = "application/x-freearc" +toString Avif = "image/avif" +toString Avi = "video/x-msvideo" +toString Azw = "application/vnd.amazon.ebook" +toString Bin = "application/octet-stream" +toString Bmp = "OS/2 Bitmap Graphics image/bmp" +toString Bz = "application/x-bzip" +toString Bz2 = "application/x-bzip2" +toString Cda = "application/x-cdf" +toString Csh = "application/x-csh" +toString Css = "text/css" +toString Csv = "text/csv" +toString Doc = "application/msword" +toString Docx = "application/vnd.openxmlformats-officedocument.wordprocessingml.document" +toString Eot = "application/vnd.ms-fontobject" +toString Epub = "application/epub+zip" +toString Gz = "application/gzip" +toString Gif = "image/gif" +toString Html = "text/html" +toString Ico = "image/vnd.microsoft.icon" +toString Ics = "text/calendar" +toString Jar = "application/java-archive" +toString Jpeg = "image/jpeg" +toString Js = "text/javascript (Specifications: HTML and RFC 9239)" +toString Json = "application/json" +toString Jsonld = "application/ld+json" +toString Midi = "audio/midi" +toString Mjs = "text/javascript" +toString Mp3 = "audio/mpeg" +toString Mp4 = "video/mp4" +toString Mpeg = "video/mpeg" +toString Mpkg = "application/vnd.apple.installer+xml" +toString Odp = "application/vnd.oasis.opendocument.presentation" +toString Ods = "application/vnd.oasis.opendocument.spreadsheet" +toString Odt = "application/vnd.oasis.opendocument.text" +toString Oga = "audio/ogg" +toString Ogv = "video/ogg" +toString Ogx = "application/ogg" +toString Opus = "audio/opus" +toString Otf = "font/otf" +toString Png = "image/png" +toString Pdf = "application/pdf" +toString Php = "application/x-httpd-php" +toString Ppt = "application/vnd.ms-powerpoint" +toString Pptx = "application/vnd.openxmlformats-officedocument.presentationml.presentation" +toString Rar = "application/vnd.rar" +toString Rtf = "application/rtf" +toString Sh = "application/x-sh" +toString Svg = "image/svg+xml" +toString Tar = "application/x-tar" +toString Tif = "image/tiff" +toString Ts = "video/mp2t" +toString Ttf = "font/ttf" +toString Txt = "text/plain" +toString Vsd = "application/vnd.visio" +toString Wav = "audio/wav" +toString Weba = "audio/webm" +toString Webm = "video/webm" +toString Webp = "image/webp" +toString Woff = "font/woff" +toString Woff2 = "font/woff2" +toString Xhtml = "application/xhtml+xml" +toString Xls = "application/vnd.ms-excel" +toString Xlsx = "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet" +toString Xml = "application/xml" +toString Xul = "application/vnd.mozilla.xul+xml" +toString Zip = "application/zip" +toString Video3gp = "video/3gpp" +toString Video3g2 = "video/3gpp2" +toString Archive7z = "application/x-7z-compressed" + +fromString :: String -> MIME +fromString "audio/aac" = Aac +fromString "application/x-abiword" = Abw +fromString "application/x-freearc" = Arc +fromString "image/avif" = Avif +fromString "video/x-msvideo" = Avi +fromString "application/vnd.amazon.ebook" = Azw +fromString "application/octet-stream" = Bin +fromString "OS/2 Bitmap Graphics image/bmp" = Bmp +fromString "application/x-bzip" = Bz +fromString "application/x-bzip2" = Bz2 +fromString "application/x-cdf" = Cda +fromString "application/x-csh" = Csh +fromString "text/css" = Css +fromString "text/csv" = Csv +fromString "application/msword" = Doc +fromString "application/vnd.openxmlformats-officedocument.wordprocessingml.document" = Docx +fromString "application/vnd.ms-fontobject" = Eot +fromString "application/epub+zip" = Epub +fromString "application/gzip" = Gz +fromString "image/gif" = Gif +fromString "text/html" = Html +fromString "image/vnd.microsoft.icon" = Ico +fromString "text/calendar" = Ics +fromString "application/java-archive" = Jar +fromString "image/jpeg" = Jpeg +fromString "text/javascript (Specifications: HTML and RFC 9239)" = Js +fromString "application/json" = Json +fromString "application/ld+json" = Jsonld +fromString "audio/midi" = Midi +fromString "text/javascript" = Mjs +fromString "audio/mpeg" = Mp3 +fromString "video/mp4" = Mp4 +fromString "video/mpeg" = Mpeg +fromString "application/vnd.apple.installer+xml" = Mpkg +fromString "application/vnd.oasis.opendocument.presentation" = Odp +fromString "application/vnd.oasis.opendocument.spreadsheet" = Ods +fromString "application/vnd.oasis.opendocument.text" = Odt +fromString "audio/ogg" = Oga +fromString "video/ogg" = Ogv +fromString "application/ogg" = Ogx +fromString "audio/opus" = Opus +fromString "font/otf" = Otf +fromString "image/png" = Png +fromString "application/pdf" = Pdf +fromString "application/x-httpd-php" = Php +fromString "application/vnd.ms-powerpoint" = Ppt +fromString "application/vnd.openxmlformats-officedocument.presentationml.presentation" = Pptx +fromString "application/vnd.rar" = Rar +fromString "application/rtf" = Rtf +fromString "application/x-sh" = Sh +fromString "image/svg+xml" = Svg +fromString "application/x-tar" = Tar +fromString "image/tiff" = Tif +fromString "video/mp2t" = Ts +fromString "font/ttf" = Ttf +fromString "text/plain" = Txt +fromString "application/vnd.visio" = Vsd +fromString "audio/wav" = Wav +fromString "audio/webm" = Weba +fromString "video/webm" = Webm +fromString "image/webp" = Webp +fromString "font/woff" = Woff +fromString "font/woff2" = Woff2 +fromString "application/xhtml+xml" = Xhtml +fromString "application/vnd.ms-excel" = Xls +fromString "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet" = Xlsx +fromString "application/xml" = Xml +fromString "application/vnd.mozilla.xul+xml" = Xul +fromString "application/zip" = Zip +fromString "video/3gpp" = Video3gp +fromString "video/3gpp2" = Video3g2 +fromString "application/x-7z-compressed" = Archive7z +fromString s = Other s diff --git a/src/HTTP/Request.js b/src/HTTP/Request.js new file mode 100644 index 0000000..1ce9e68 --- /dev/null +++ b/src/HTTP/Request.js @@ -0,0 +1,2 @@ +/** @type {(_: Blob) => () => Promise} */ +export const blobArrayBufferImpl = b => () => b.arrayBuffer() diff --git a/src/HTTP/Request.purs b/src/HTTP/Request.purs new file mode 100644 index 0000000..583074d --- /dev/null +++ b/src/HTTP/Request.purs @@ -0,0 +1,177 @@ +module HTTP.Request + ( class Request + , Body + , RawRequestBody + , Method(..) + , json + , form + , blob + , buffer + , arrayBuffer + , requestBody + , requestHeaders + , requestUrl + , requestMethod + ) where + +import Prelude + +import Control.Promise (Promise) +import Control.Promise as Promise +import Data.ArrayBuffer.ArrayBuffer as ArrayBuffer +import Data.ArrayBuffer.Types (ArrayBuffer) +import Data.Map (Map) +import Data.Map as Map +import Data.Maybe (Maybe(..)) +import Data.Newtype (unwrap) +import Data.Tuple (Tuple, fst, snd) +import Data.Tuple.Nested ((/\)) +import Effect (Effect) +import Effect.Aff.Class (class MonadAff, liftAff) +import Effect.Class (class MonadEffect, liftEffect) +import HTTP.Form (Form, RawFormData) +import HTTP.Form as Form +import HTTP.Header (ContentType(..), Headers(..)) +import HTTP.Header as Header +import HTTP.MIME (MIME) +import HTTP.MIME as MIME +import HTTP.URL (URL) +import Node.Buffer (Buffer) +import Node.Buffer as Buffer +import Node.Encoding (Encoding(..)) +import Simple.JSON (class WriteForeign, writeJSON) +import Unsafe.Coerce (unsafeCoerce) +import Web.File.Blob (Blob) +import Web.File.Blob as Blob + +foreign import blobArrayBufferImpl :: Blob -> Effect (Promise ArrayBuffer) +foreign import data RawRequestBody :: Type + +unsafeFormDataToRawRequestBody :: RawFormData -> RawRequestBody +unsafeFormDataToRawRequestBody = unsafeCoerce + +unsafeArrayBufferToRawRequestBody :: ArrayBuffer -> RawRequestBody +unsafeArrayBufferToRawRequestBody = unsafeCoerce + +unsafeBlobToRawRequestBody :: forall m. MonadAff m => Blob -> m RawRequestBody +unsafeBlobToRawRequestBody = map unsafeArrayBufferToRawRequestBody <<< liftAff <<< Promise.toAffE <<< blobArrayBufferImpl + +data Body + = BodyString String (Maybe ContentType) + | BodyArrayBuffer ArrayBuffer (Maybe ContentType) + | BodyBuffer Buffer (Maybe ContentType) + | BodyBlob Blob + | BodyForm Form + | BodyEmpty + +json :: forall a. WriteForeign a => a -> Body +json = flip BodyString (Just $ ContentType MIME.Json) <<< writeJSON + +form :: Form -> Body +form = BodyForm + +blob :: Blob -> Body +blob = BodyBlob + +buffer :: MIME -> Buffer -> Body +buffer mime buf = BodyBuffer buf $ Just $ ContentType mime + +arrayBuffer :: MIME -> ArrayBuffer -> Body +arrayBuffer mime buf = BodyArrayBuffer buf $ Just $ ContentType mime + +bodyHeaders :: forall m. MonadEffect m => Body -> m Headers +bodyHeaders (BodyForm _) = pure mempty +bodyHeaders (BodyEmpty) = pure mempty +bodyHeaders (BodyString _ ct) = liftEffect $ Header.headers ct +bodyHeaders (BodyBuffer _ ct) = liftEffect $ Header.headers ct +bodyHeaders (BodyArrayBuffer _ ct) = liftEffect $ Header.headers ct +bodyHeaders (BodyBlob b) = Header.headers <<< map (ContentType <<< MIME.fromString <<< unwrap) $ Blob.type_ b + +bodyToRaw :: forall m. MonadAff m => Body -> m RawRequestBody +bodyToRaw (BodyString body ct) = flip bind bodyToRaw $ liftEffect $ map (flip BodyBuffer ct) $ Buffer.fromString body UTF8 +bodyToRaw (BodyBuffer body ct) = flip bind bodyToRaw $ liftEffect $ map (flip BodyArrayBuffer ct) $ Buffer.toArrayBuffer body +bodyToRaw (BodyArrayBuffer body _) = pure $ unsafeArrayBufferToRawRequestBody body +bodyToRaw (BodyForm form') = map unsafeFormDataToRawRequestBody $ Form.toRawFormData form' +bodyToRaw (BodyBlob body) = unsafeBlobToRawRequestBody body +bodyToRaw BodyEmpty = liftEffect $ map unsafeArrayBufferToRawRequestBody $ ArrayBuffer.empty 0 + +data Method + = GET + | PUT + | POST + | DELETE + | PATCH + +-- | given a tuple of any size with at least 1 value +-- | of type `a`, `extract` the first occurence of `a` +-- | from the tuple +class TupleContaining a tup where + extract :: tup -> a + +instance TupleContaining a a where + extract = identity +else instance TupleContaining a (Tuple a b) where + extract = fst +else instance TupleContaining b (Tuple a b) where + extract = snd +else instance TupleContaining a tail => TupleContaining a (Tuple head tail) where + extract (_ /\ tail) = extract tail + +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 (Maybe RawRequestBody) + requestHeaders :: forall m. MonadAff m => a -> m (Map String String) + +instance + ( TupleContaining Body a + , TupleContaining URL a + , TupleContaining Method a + , TupleContaining Headers a + ) => + Request a where + requestUrl = pure <<< extract + requestMethod = pure <<< extract + requestBody = map Just <<< bodyToRaw <<< extract + requestHeaders req = do + let (Headers hs) = extract req + (Headers bodyHs) <- bodyHeaders $ extract req + pure $ Map.union hs bodyHs +else instance + ( TupleContaining Body a + , TupleContaining URL a + , TupleContaining Method a + ) => + Request a where + requestUrl = pure <<< extract + requestMethod = pure <<< extract + requestBody = map Just <<< bodyToRaw <<< extract + requestHeaders _ = pure Map.empty +else instance + ( TupleContaining Headers a + , TupleContaining URL a + , TupleContaining Method a + ) => + Request a where + requestUrl = pure <<< extract + requestMethod = pure <<< extract + requestBody _ = Just <$> bodyToRaw BodyEmpty + requestHeaders = (\(Headers h) -> pure h) <<< extract +else instance + ( TupleContaining URL a + , TupleContaining Method a + ) => + Request a where + requestUrl = pure <<< extract + requestMethod = pure <<< extract + requestBody _ = Just <$> bodyToRaw BodyEmpty + requestHeaders _ = pure Map.empty +else instance + ( TupleContaining URL a + ) => + Request a where + requestUrl = pure <<< extract + requestMethod _ = pure GET + requestBody _ = Just <$> bodyToRaw BodyEmpty + requestHeaders _ = pure Map.empty diff --git a/src/HTTP/Response.js b/src/HTTP/Response.js new file mode 100644 index 0000000..54cf4ee --- /dev/null +++ b/src/HTTP/Response.js @@ -0,0 +1,34 @@ +/// + +/** @type {(_: Response) => () => Promise} */ +export const jsonImpl = rep => () => rep.json() + +/** @type {(_: Response) => () => Promise} */ +export const textImpl = rep => () => rep.text() + +/** @type {(_: Response) => () => Promise} */ +export const abImpl = rep => () => rep.arrayBuffer() + +/** @type {(_: Response) => () => Promise} */ +export const blobImpl = rep => () => rep.blob() + +/** @type {(_: Response) => () => Promise} */ +export const formImpl = rep => () => rep.formData() + +/** @type {(_: Response) => () => number} */ +export const statusImpl = rep => () => rep.status + +/** @type {(_: Response) => () => string} */ +export const statusTextImpl = rep => () => rep.statusText + +/** @type {(_: Response) => () => Record} */ +export const headersImpl = rep => () => { + /** @type {Record} */ + const hs = {} + + Array.from(rep.headers.entries()).forEach(([k, v]) => { + hs[k] = v + }) + + return hs +} diff --git a/src/HTTP/Response.purs b/src/HTTP/Response.purs new file mode 100644 index 0000000..9ce0964 --- /dev/null +++ b/src/HTTP/Response.purs @@ -0,0 +1,79 @@ +module HTTP.Response + ( Response(..) + , json + , text + , blob + , arrayBuffer + , formData + , headers + , status + , statusText + , guardStatusOk + ) where + +import Prelude + +import Control.Monad.Error.Class (class MonadThrow, liftEither, throwError) +import Control.Monad.Except (runExcept) +import Control.Promise (Promise) +import Control.Promise as Promise +import Data.ArrayBuffer.Types (ArrayBuffer) +import Data.Bifunctor (lmap) +import Data.Int as Int +import Data.Map (Map) +import Data.Map as Map +import Data.Number ((%)) +import Effect (Effect) +import Effect.Aff.Class (class MonadAff, liftAff) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Exception (Error, error) +import Foreign (Foreign) +import Foreign.Object (Object) +import HTTP.Form (Form, RawFormData) +import HTTP.Form as Form +import Simple.JSON (class ReadForeign, readImpl) +import Web.File.Blob (Blob) + +foreign import data Response :: Type + +foreign import statusImpl :: Response -> Effect Int +foreign import statusTextImpl :: Response -> Effect String +foreign import headersImpl :: Response -> Effect (Object String) +foreign import jsonImpl :: Response -> Effect (Promise Foreign) +foreign import textImpl :: Response -> Effect (Promise String) +foreign import abImpl :: Response -> Effect (Promise ArrayBuffer) +foreign import blobImpl :: Response -> Effect (Promise Blob) +foreign import formImpl :: Response -> Effect (Promise RawFormData) + +guardStatusOk :: forall m. MonadAff m => MonadThrow Error m => Response -> m Unit +guardStatusOk rep = do + status' <- status rep + statusText' <- statusText rep + if Int.toNumber status' % 200.0 > 100.0 then + throwError $ error $ "status not OK: " <> show status' <> " " <> statusText' + else + pure unit + +json :: forall m @a. MonadAff m => ReadForeign a => Response -> m a +json = liftAff <<< flip bind (liftEither <<< lmap (error <<< show) <<< runExcept <<< readImpl) <<< Promise.toAffE <<< jsonImpl + +text :: forall m. MonadAff m => Response -> m String +text = liftAff <<< Promise.toAffE <<< textImpl + +blob :: forall m. MonadAff m => Response -> m Blob +blob = liftAff <<< Promise.toAffE <<< blobImpl + +arrayBuffer :: forall m. MonadAff m => Response -> m ArrayBuffer +arrayBuffer = liftAff <<< Promise.toAffE <<< abImpl + +formData :: forall m. MonadAff m => Response -> m Form +formData = liftAff <<< flip bind Form.fromRaw <<< Promise.toAffE <<< formImpl + +headers :: forall m. MonadEffect m => Response -> m (Map String String) +headers = liftEffect <<< map Map.fromFoldableWithIndex <<< headersImpl + +status :: forall m. MonadEffect m => Response -> m Int +status = liftEffect <<< statusImpl + +statusText :: forall m. MonadEffect m => Response -> m String +statusText = liftEffect <<< statusTextImpl diff --git a/src/HTTP/URL.purs b/src/HTTP/URL.purs new file mode 100644 index 0000000..b8809a0 --- /dev/null +++ b/src/HTTP/URL.purs @@ -0,0 +1,12 @@ +module HTTP.URL where + +import Prelude + +import Data.Newtype (class Newtype) + +newtype URL = URL String + +derive instance Newtype URL _ +derive newtype instance Show URL +derive newtype instance Eq URL +derive newtype instance Ord URL