fix: initial commit

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:

src/HTTP.js

@@ -0,0 +1,3 @@
+/** @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 })

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

src/HTTP/Form.js

@@ -0,0 +1,56 @@
+/** @type {(_: Record<string, Array<string | Blob>>) => () => 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<Record<string, Array<string | FileRecord>>>} */
+export const unsafeUnmakeFormData = fd => async () => {
+  /** @type {Record<string, Array<string | FileRecord>>} */
+  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
+}

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 <> ") <ArrayBuffer> (" <> 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

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

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

src/HTTP/Request.js

@@ -0,0 +1,2 @@
+/** @type {(_: Blob) => () => Promise<ArrayBuffer>} */
+export const blobArrayBufferImpl = b => () => b.arrayBuffer()

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

src/HTTP/Response.js

@@ -0,0 +1,34 @@
+/// <reference lib="dom" />
+
+/** @type {(_: Response) => () => Promise<unknown>} */
+export const jsonImpl = rep => () => rep.json()
+
+/** @type {(_: Response) => () => Promise<string>} */
+export const textImpl = rep => () => rep.text()
+
+/** @type {(_: Response) => () => Promise<ArrayBuffer>} */
+export const abImpl = rep => () => rep.arrayBuffer()
+
+/** @type {(_: Response) => () => Promise<Blob>} */
+export const blobImpl = rep => () => rep.blob()
+
+/** @type {(_: Response) => () => Promise<FormData>} */
+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<string, string>} */
+export const headersImpl = rep => () => {
+  /** @type {Record<string, string>} */
+  const hs = {}
+
+  Array.from(rep.headers.entries()).forEach(([k, v]) => {
+    hs[k] = v
+  })
+
+  return hs
+}

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

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