Source file http.ml

open Core
open Async_kernel
open Js_of_ocaml
module Opt = Js.Opt
module Optdef = Js.Optdef

module Response_type = struct
  type 'a t = 'a XmlHttpRequest.response =
    | ArrayBuffer : Typed_array.arrayBuffer Js.t Opt.t t
    | Blob : #File.blob Js.t Js.Opt.t t
    | Document : Dom.element Dom.document Js.t Opt.t t
    | JSON : 'a Opt.t t
    | Text : Js.js_string Js.t t
    | Default : string t
end

module Response = struct
  type 'response t =
    { code : int
    ; get_header : string -> string option
    ; content : 'response
    }
end

module Post_body = struct
  type t =
    | Blob of File.blob Js.t
    | Document of Dom.element Dom.document Js.t
    | String of string
    | Form_data of Form.formData Js.t
end

module Method_with_args = struct
  type t =
    | Get of (string * string) list
    | Post of Post_body.t option
end

type 'k with_request_args =
  ?headers:(string * string) list
  -> ?on_progress:(loaded:int -> total:int -> unit)
  -> ?on_upload_progress:(loaded:int -> total:int -> unit)
  -> url:string
  -> 'k

let has_get_args url = Option.is_some (String.index url '?')

let request
      ?(headers = [])
      ?on_progress
      ?on_upload_progress
      ~url
      (type resp)
      ~(response_type : resp Response_type.t)
      (method_with_args : Method_with_args.t)
  =
  let url, method_string =
    match method_with_args with
    | Get args ->
      url ^ (if has_get_args url then "&" else "?") ^ Url.encode_arguments args, "GET"
    | Post _body -> url, "POST"
  in
  let req = XmlHttpRequest.create () in
  req##_open (Js.string method_string) (Js.string url) Js._true;
  (let open Response_type in
   match response_type with
   | ArrayBuffer -> req##.responseType := Js.string "arraybuffer"
   | Blob -> req##.responseType := Js.string "blob"
   | Document -> req##.responseType := Js.string "document"
   | JSON -> req##.responseType := Js.string "json"
   | Text -> req##.responseType := Js.string "text"
   | Default -> req##.responseType := Js.string "");
  List.iter headers ~f:(fun (name, value) ->
    req##setRequestHeader (Js.string name) (Js.string value));
  let response : resp Response.t Or_error.t Ivar.t = Ivar.create () in
  req##.onerror
  := Dom.handler (fun _ ->
    Ivar.fill_if_empty response (Or_error.error_string "Network error");
    Js._true);
  req##.ontimeout
  := Dom.handler (fun _ ->
    Ivar.fill_if_empty response (Or_error.error_string "Timeout");
    Js._true);
  req##.onreadystatechange
  := Js.wrap_callback (fun _ ->
    match req##.readyState with
    | DONE ->
      let res =
        if req##.status >= 200 && req##.status < 300
        then (
          let%bind.Or_error content : resp Or_error.t =
            let get_text_contents_or_error () =
              Opt.case
                req##.responseText
                (fun () ->
                   (* This case should not be entered as per the specification of
                      XMLHttpRequest at MDN web docs, because if a request is successful,
                      in state [DONE] and response_type [Text] or [Default],
                      [responseText] should not be [null].
                      See https://developer.mozilla.org/en-US/docs/Web/API/XMLHttpRequest/responseText
                   *)
                   error_s
                     [%sexp
                       "No response returned despite successful request"
                     , { code = (req##.status : int)
                       ; status_text = (Js.to_string req##.statusText : string)
                       }])
                Result.return
            in
            let open Response_type in
            match response_type with
            | ArrayBuffer -> Ok (File.CoerceTo.arrayBuffer req##.response)
            | Blob -> Ok (File.CoerceTo.blob req##.response)
            | Document -> Ok (File.CoerceTo.document req##.response)
            | JSON -> Ok (File.CoerceTo.json req##.response)
            | Text -> get_text_contents_or_error ()
            | Default ->
              Or_error.map (get_text_contents_or_error ()) ~f:Js.to_string
          in
          let get_header s =
            Opt.case
              (req##getResponseHeader (Js.bytestring s))
              (fun () -> None)
              (fun v -> Some (Js.to_string v))
          in
          Ok { Response.content; code = req##.status; get_header })
        else
          Or_error.error_s
            [%sexp
              "Request failed"
            , { code = (req##.status : int)
              ; status_text = (Js.to_string req##.statusText : string)
              }]
      in
      Ivar.fill_if_empty response res
    | _ -> ());
  Option.iter on_progress ~f:(fun on_progress ->
    req##.onprogress
    := Dom.handler (fun e ->
      on_progress ~loaded:e##.loaded ~total:e##.total;
      Js._true));
  Optdef.iter req##.upload (fun upload ->
    Option.iter on_upload_progress ~f:(fun on_upload_progress ->
      upload##.onprogress
      := Dom.handler (fun e ->
        on_upload_progress ~loaded:e##.loaded ~total:e##.total;
        Js._true)));
  (match method_with_args with
   | Get _ -> req##send Js.null
   | Post body ->
     (match body with
      | None -> req##send Js.null
      | Some body ->
        (match body with
         | Blob b -> req##send_blob b
         | Document d -> req##send_document d
         | String s -> req##send (Js.some (Js.string s))
         | Form_data fd -> req##send_formData fd)));
  Ivar.read response
;;

let get ?(arguments = []) url =
  Deferred.Or_error.map
    ~f:(fun resp -> resp.content)
    (request ~url ~response_type:Default (Get arguments))
;;

let post ?body url =
  Deferred.Or_error.map
    ~f:(fun resp -> resp.content)
    (request ~url ~response_type:Default (Post body))
;;