Skip to content

Fix exception on connection errors in chrome. #761

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
mseri merged 5 commits into from
Apr 14, 2021
Merged

Fix exception on connection errors in chrome. #761

Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
22ead7a
Fix exception on connection errors in chrome.
mefyl Feb 14, 2021
048011e
Merge master into bugfix/null-response-chrome.
mefyl Apr 13, 2021
b09155c
Also fix null response bug in sync client.
mefyl Apr 13, 2021
658e67e
cohttp-lwt-jsoo: Factor body construction.
mefyl Apr 14, 2021
115173a
Add log when replacing null response with the empty string.
mefyl Apr 14, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
94 changes: 38 additions & 56 deletions cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,10 @@ let binary_string str =
let string_of_uint8array u8a offset len =
String.init len (fun i -> Char.chr (Typed_array.unsafe_get u8a (offset + i)))

module String_io = Cohttp__String_io
module IO = Cohttp_lwt__String_io
module Header_io = Cohttp__Header_io.Make (IO)

module Body_builder (P : Params) = struct
(* perform the body transfer in chunks from string. *)
let chunked_body_str text =
Expand Down Expand Up @@ -94,6 +98,32 @@ module Body_builder (P : Params) = struct
else
let u8a = new%js Typed_array.uint8Array_fromBuffer ab in
CLB.of_string (string_of_uint8array u8a 0 ab##.byteLength)

let construct_body xml =
(* construct body *)
let b =
let respText () =
Js.Opt.case xml##.responseText
(fun () -> `String (Js.string ""))
(fun s -> `String s)
in
if xhr_response_supported then
Copy link
Copy Markdown
Collaborator

@mseri mseri Apr 14, 2021 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more. 

match  xhr_response_supported with
| true when Js.Opt.return xml##.response = Js.null -> 
  Firebug.console##log (Js.string "XHR Response is null; using empty string");
  `String (Js.string "")
| true ->
  Js.Opt.case
     (File.CoerceTo.arrayBuffer xml##.response)
     (fun () -> Firebug.console##log
                (Js.string
                   "XHR Response is not an arrayBuffer; using responseText");
              respText ())
            (fun ab -> `ArrayBuffer ab)
| _ -> respText ()

This is a readability suggestion, do you think it would be better or worse than the nested ifs?

if Js.Opt.return xml##.response == Js.null then (
Firebug.console##log
(Js.string "XHR Response is null; using empty string");
`String (Js.string ""))
else
Js.Opt.case
(File.CoerceTo.arrayBuffer xml##.response)
(fun () ->
Firebug.console##log
(Js.string
"XHR Response is not an arrayBuffer; using responseText");
respText ())
(fun ab -> `ArrayBuffer ab)
else respText ()
in
get b
end

module Make_api (X : sig
Expand Down Expand Up @@ -151,10 +181,6 @@ struct
(* ??? *)
end

module String_io = Cohttp__String_io
module IO = Cohttp_lwt__String_io
module Header_io = Cohttp__Header_io.Make (IO)

module Make_client_async (P : Params) = Make_api (struct
module Response = Cohttp.Response
module Request = Cohttp.Request
Expand Down Expand Up @@ -193,43 +219,22 @@ module Make_client_async (P : Params) = Make_api (struct
match xml##.readyState with
| XmlHttpRequest.DONE -> (
try
(* construct body *)
let body =
let b =
let respText () =
Js.Opt.case xml##.responseText
(fun () -> `String (Js.string ""))
(fun s -> `String s)
in
if xhr_response_supported then
Js.Opt.case
(File.CoerceTo.arrayBuffer xml##.response)
(fun () ->
Firebug.console##log
(Js.string
"XHR Response is not an arrayBuffer; using \
responseText");
respText ())
(fun ab -> `ArrayBuffer ab)
else respText ()
in
Bb.get b
in
let body = Bb.construct_body xml in
(* Note; a type checker subversion seems to be possible here (4.01.0).
* Remove the type constraint on Lwt.task above and return any old
* guff here. It'll compile and crash in the browser! *)
(* (re-)construct the response *)
let resp_headers = Js.to_string xml##getAllResponseHeaders in
let channel = String_io.open_in resp_headers in
let response =
let resp_headers = Js.to_string xml##getAllResponseHeaders in
let channel = String_io.open_in resp_headers in
Lwt.(
Header_io.parse channel >|= fun resp_headers ->
Response.make ~version:`HTTP_1_1
Cohttp.Response.make ~version:`HTTP_1_1
~status:(C.Code.status_of_code xml##.status)
~flush:false (* ??? *)
~encoding:(CLB.transfer_encoding body)
~headers:resp_headers ())
in
(* Note; a type checker subversion seems to be possible here (4.01.0).
* Remove the type constraint on Lwt.task above and return any old
* guff here. It'll compile and crash in the browser! *)
Lwt.wakeup wake (response, body)
with
| e
Expand Down Expand Up @@ -260,7 +265,6 @@ module Make_client_async (P : Params) = Make_api (struct
Lwt.return (xml##send (Js.Opt.return (Obj.magic bs))))
>>= fun () ->
Lwt.on_cancel res (fun () -> xml##abort);

(* unwrap the response *)
Lwt.(
res >>= fun (r, b) ->
Expand Down Expand Up @@ -307,29 +311,7 @@ module Make_client_sync (P : Params) = Make_api (struct
let bs = binary_string body in
xml ## (send (Js.Opt.return (Obj.magic bs))))
>>= fun _body ->
(* TODO: FIXME: looks like an indenting or cut-and-pasto here. Check this - avsm *)
(* construct body *)
let body =
let b =
let respText () =
Js.Opt.case xml##.responseText
(fun () -> `String (Js.string ""))
(fun s -> `String s)
in
if xhr_response_supported then
Js.Opt.case
(File.CoerceTo.arrayBuffer xml##.response)
(fun () ->
Firebug.console##log
(Js.string
"XHR Response is not an arrayBuffer; using responseText");
respText ())
(fun ab -> `ArrayBuffer ab)
else respText ()
in
Bb.get b
in

let body = Bb.construct_body xml in
(* (re-)construct the response *)
let resp_headers = Js.to_string xml##getAllResponseHeaders in
Header_io.parse (String_io.open_in resp_headers) >>= fun resp_headers ->
Expand Down