Something went wrong. Try again.
Literature downloader from academic publishers
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358open Fetchmodule Js = Js_of_ocaml.Jsmodule Typed_array = Js_of_ocaml.Typed_array
type tag = [ `Generic | `Browser ]
type t = tag Fetch.ty Eio.Resource.t
type Eio.Exn.Backend.t += Fetch_error of string
let () = Eio.Exn.Backend.register_pp (fun f -> function | Fetch_error msg -> Fmt.pf f "Fetch_error(%S)" msg; true | _ -> false )
type config = { redirect : [ `Follow | `Manual ]; credentials : [ `Omit | `Same_origin | `Include ]; max_response : int;}
(* {2 JavaScript glue}
Nothing crossing the FFI has an OCaml type, so every value here is a {!Js.Unsafe.any}. Platform functions are invoked with [meth_call] on the object owning them rather than [fun_call] on a looked-up property: a browser refuses [fetch] and [crypto.getRandomValues] called with the wrong [this]. *)
let global = Js.Unsafe.globallet inject = Js.Unsafe.injectlet jstr s = inject (Js.string s)let field o name : Js.Unsafe.any = Js.Unsafe.get o (Js.string name)let global_field name : Js.Unsafe.any = field global name
let is_nullish = Js.Unsafe.pure_js_expr "(function (x) { return x === null || x === undefined; })"
let defined (v : Js.Unsafe.any) = if Js.to_bool (Js.Unsafe.fun_call is_nullish [| inject v |]) then None else Some v
let string_of_js (v : Js.Unsafe.any) = Js.to_string (Js.Unsafe.fun_call (Js.Unsafe.pure_js_expr "String") [| inject v |])
(* Only a promise rejecting with an [Error] carries a [message], and a promise may reject with anything at all, so coerce whatever arrived. *)let error_message (v : Js.Unsafe.any) = match defined v with | None -> "rejected" | Some v -> ( match defined (field v "message") with | Some m -> string_of_js m | None -> string_of_js v)
(* A promise settling after the fiber was cancelled is inert: {!Eio_js_backend.await} resumes its fiber at most once. *)exception Rejected of Js.Unsafe.any
let await_promise ~cancel promise = Eio_js_backend.await ~setup:(fun ~resolve ~reject -> ignore ( Js.Unsafe.meth_call promise "then" [| inject (Js.wrap_callback (fun v -> resolve v)); inject (Js.wrap_callback (fun e -> reject (Rejected e))) |] : Js.Unsafe.any )) ~cancel:(fun () -> cancel ())
(* Discard a promise whose only purpose is its side effect, keeping a rejection handled so node does not fault the process. *)let drop_promise (p : Js.Unsafe.any) = ignore ( Js.Unsafe.meth_call p "catch" [| inject (Js.wrap_callback (fun _ -> ())) |] : Js.Unsafe.any )
(* {2 Errors}
fetch() reports every network, DNS, TLS and CORS failure as a bare TypeError whose message is advisory and not stable, so they all land on one {!Fetch.error} carrying the text. *)let map_exn = function | Rejected e -> err (Connection_failure (Refused (Fetch_error (error_message e)))) | Js.Js_error.Exn e -> err (Protocol_error (Js.Js_error.message e)) | ex -> ex
let reraise ex = let bt = Printexc.get_raw_backtrace () in Printexc.raise_with_backtrace (map_exn ex) bt
(* {2 Response bodies}
A [ReadableStream] hands over one chunk at a time and a chunk can be larger than the caller's buffer, so the remainder is held here. The cap counts bytes delivered to the caller, which are post-decoding ones since fetch() decompresses, so it bounds a compression bomb too. *)type response_body = { reader : Js.Unsafe.any; max_response : int; mutable held : string; mutable pos : int; mutable seen : int; mutable eof : bool;}
let cancel_reader t = drop_promise (Js.Unsafe.meth_call t.reader "cancel" [||])
let read_chunk t = let promise = Js.Unsafe.meth_call t.reader "read" [||] in let v = await_promise ~cancel:(fun () -> cancel_reader t) promise in if Js.to_bool (Js.Unsafe.get v (Js.string "done")) then None else Some (Typed_array.String.of_uint8Array (Js.Unsafe.coerce (field v "value")))
module Response_body = struct type t = response_body
let read_methods = []
let rec single_read t buf = if t.pos < String.length t.held then begin let n = min (Cstruct.length buf) (String.length t.held - t.pos) in Cstruct.blit_from_string t.held t.pos buf 0 n; t.pos <- t.pos + n; t.seen <- t.seen + n; if t.seen > t.max_response then raise (err (Protocol_error (Fmt.str "response body exceeds %d bytes" t.max_response))); n end else if t.eof then raise End_of_file else match read_chunk t with | exception ex -> reraise ex | None -> t.eof <- true; raise End_of_file | Some chunk -> t.held <- chunk; t.pos <- 0; single_read t bufend
let response_body_handler = Eio.Flow.Pi.source (module Response_body)
module Empty_body = struct type t = unit
let read_methods = [] let single_read () _ = raise End_of_fileend
let empty_body : Eio.Flow.source_ty Eio.Resource.t = Eio.Resource.T ((), Eio.Flow.Pi.source (module Empty_body))
(* {2 One exchange} *)
let redirect_mode = function `Follow -> "follow" | `Manual -> "manual"
let credentials_mode = function | `Omit -> "omit" | `Same_origin -> "same-origin" | `Include -> "include"
let js_headers hs = let h = Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "Headers") [||] in (* Append rather than set: [Http.Header.to_list] delivers repeated fields separately and each must reach the wire as it was given. *) List.iter (fun (name, value) -> ignore (Js.Unsafe.meth_call h "append" [| jstr name; jstr value |] : Js.Unsafe.any)) hs; h
let headers_of_js h = let acc = ref [] in ignore ( Js.Unsafe.meth_call h "forEach" [| inject (Js.wrap_callback (fun (value : Js.js_string Js.t) (name : Js.js_string Js.t) -> acc := (Js.to_string name, Js.to_string value) :: !acc)) |] : Js.Unsafe.any ); Http.Header.of_list (List.rev !acc)
(* A JS string would re-encode the bytes, so a body always goes out as a Uint8Array. [Bytes.of_string] copies, which is what keeps the array from aliasing an OCaml value the platform reads asynchronously. *)let js_body s = Typed_array.Bytes.to_uint8Array (Bytes.of_string s)
module Backend = struct type t = config type tag = [ `Generic | `Browser ]
let request cfg ~sw (req : Middleware.request) = let body = match req.body with | Empty -> None | String s -> Some (js_body s) | Stream { flow; _ } -> (* fetch() takes a streaming request body only where HTTP/2 and duplex requests are available, which is nowhere portably, so the flow is drained first. *) Some (js_body (Eio.Buf_read.take_all (Eio.Buf_read.of_flow ~max_size:max_int flow))) in let controller = Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "AbortController") [||] in let init = Js.Unsafe.obj [| ("method", jstr (Http.Method.to_string req.meth)); ("headers", inject (js_headers (Http.Header.to_list req.headers))); ("cache", jstr "no-store"); ("redirect", jstr (redirect_mode cfg.redirect)); ("credentials", jstr (credentials_mode cfg.credentials)); ("signal", field controller "signal") |] in Option.iter (fun b -> Js.Unsafe.set init (Js.string "body") (inject b)) body; let abort () = ignore (Js.Unsafe.meth_call controller "abort" [||] : Js.Unsafe.any) in let promise = match Js.Unsafe.meth_call global "fetch" [| jstr (Middleware.Url.to_string req.url); inject init |] with | promise -> promise | exception Js.Js_error.Exn e -> raise (err (Invalid_request (Js.Js_error.message e))) | exception Failure msg -> raise (err (Invalid_request msg)) in match await_promise ~cancel:abort promise with | exception ex -> abort (); reraise ex | response -> if cfg.redirect = `Manual && string_of_js (field response "type") = "opaqueredirect" then raise (err (Protocol_error "redirect target not observable (opaqueredirect)")); let headers = headers_of_js (field response "headers") in let headers = (* fetch() cannot be told to skip decoding, so present the decoded view, as a backend must. *) if Http.Header.mem headers "content-encoding" then Http.Header.remove (Http.Header.remove headers "content-encoding") "content-length" else headers in let url = match defined (field response "url") with | None -> req.url | Some u -> ( match Middleware.Url.of_string (string_of_js u) with | Ok url -> url | Error _ -> req.url) in let body = match defined (field response "body") with | None -> empty_body | Some stream -> let reader = Js.Unsafe.meth_call stream "getReader" [||] in let body = { reader; max_response = cfg.max_response; held = ""; pos = 0; seen = 0; eof = false } in (* {!Fetch.body} promises the flow is closed when the request's switch finishes, and an abandoned body otherwise holds the connection open. *) Eio.Switch.on_release sw (fun () -> cancel_reader body; abort ()); Eio.Resource.T (body, response_body_handler) in (* A Response says nothing about the version that carried it. *) Fetch.Middleware.Pi.response ~status:(Js.Unsafe.get response (Js.string "status")) ~headers ~version:(`Other "unknown") ~body ~url ()end
let handler = Fetch.Middleware.Pi.client (module Backend)
let v ?(redirect = `Follow) ?(browser_credentials = `Same_origin) ?(max_response = 256 * 1024 * 1024) () : t = Eio.Resource.T ({ redirect; credentials = browser_credentials; max_response }, handler)
(* {2 Clock and randomness} *)
module Mono_clock = struct type t = unit type time = Mtime.t
let now () = let ms : float = Js.Unsafe.meth_call (global_field "performance") "now" [||] in Mtime.of_uint64_ns (Int64.of_float (ms *. 1e6))
let sleep_until () time = let start = now () in if Mtime.is_later time ~than:start then begin let ms = Mtime.Span.to_float_ns (Mtime.span time start) /. 1e6 in Eio_js_backend.await ~setup:(fun ~resolve ~reject:_ -> ( Js.Unsafe.meth_call global "setTimeout" [| inject (Js.wrap_callback (fun () -> resolve ())); inject ms |] : Js.Unsafe.any )) ~cancel:(fun id -> ignore (Js.Unsafe.meth_call global "clearTimeout" [| inject id |] : Js.Unsafe.any)) endend
let mono_clock_handler = Eio.Time.Pi.clock (module Mono_clock)let mono_clock () : Eio.Time.Mono.ty Eio.Resource.t = Eio.Resource.T ((), mono_clock_handler)
module Secure_random = struct type t = unit
let read_methods = []
let single_read () buf = (* getRandomValues throws above 65536 bytes in one call. *) let n = min (Cstruct.length buf) 65536 in let arr = Js.Unsafe.new_obj (Js.Unsafe.pure_js_expr "Uint8Array") [| inject n |] in ignore ( Js.Unsafe.meth_call (global_field "crypto") "getRandomValues" [| inject arr |] : Js.Unsafe.any ); Cstruct.blit_from_string (Typed_array.String.of_uint8Array (Js.Unsafe.coerce arr)) 0 buf 0 n; nend
let secure_random_handler = Eio.Flow.Pi.source (module Secure_random)let secure_random () : Eio.Flow.source_ty Eio.Resource.t = Eio.Resource.T ((), secure_random_handler)
let std ?redirect ?retry ?(max_concurrent = 6) ?min_interval () = let clock = mono_clock () in v ?redirect () |> Fetch.with_limits ~clock ?min_interval ~max_concurrent |> Fetch.with_retry ~clock ~random:(secure_random ()) ?config:retry