diff --git a/API-STATUS.md b/API-STATUS.md index dc69b60cd1..ea5fceaed9 100644 --- a/API-STATUS.md +++ b/API-STATUS.md @@ -19,7 +19,7 @@ This document lists standard JavaScript/Web APIs and their support status in js_ | JSON | Yes | Yes | `Json` · Brr: `Brr.Json` | | Date | Yes | No | `Js` (Js.date) | | Math | Yes | No | `Js` (Js.math) | -| Promise | Partial | Yes | `Js.Promise` / lwt bindings — [#2031](https://github.com/ocsigen/js_of_ocaml/issues/2031) · Brr: `Jv.Promise`, `Fut` | +| Promise | Yes | Yes | `Promise` · Brr: `Jv.Promise`, `Fut` | | Console | Yes | Yes | `Console` · Brr: `Brr.Console` | ## DOM @@ -44,7 +44,7 @@ This document lists standard JavaScript/Web APIs and their support status in js_ | API | jsoo | Brr | jsoo Module / Notes | |-----|------|-----|---------------------| | XMLHttpRequest | Yes | No | `XmlHttpRequest` | -| Fetch API | No | Yes | [#596](https://github.com/ocsigen/js_of_ocaml/issues/596) · Brr: `Brr_io.Fetch` | +| Fetch API | Yes | Yes | `Fetch` · Brr: `Brr_io.Fetch` | | MessageChannel / MessagePort | No | Yes | [#1464](https://github.com/ocsigen/js_of_ocaml/issues/1464) · Brr: `Brr_io.Message` | | WebSocket | Yes | Yes | `WebSockets` · Brr: `Brr_io.Websocket` | | Server-Sent Events (EventSource) | Yes | No | `EventSource` | @@ -111,9 +111,9 @@ This document lists standard JavaScript/Web APIs and their support status in js_ | Wheel Events | Yes | Yes | `Dom_html` · Brr: `Brr.Ev.Wheel` | | Drag and Drop Events | Yes | Yes | `Dom_html` · Brr: `Brr.Ev.Drag` | | Clipboard API | No | Yes | Brr: `Brr_io.Clipboard` | -| Fullscreen API | Partial | Yes | `Dom_html` (element/document fullscreen — `requestFullscreen_`/`exitFullscreen_` returns Promise, not yet typed) · Brr: `Brr.El.request_fullscreen`, `Brr.Document.exit_fullscreen` | +| Fullscreen API | Yes | Yes | `Dom_html` (`requestFullscreen` / `exitFullscreen`) · Brr: `Brr.El.request_fullscreen`, `Brr.Document.exit_fullscreen` | | Gamepad API | No | No | | -| Pointer Lock API | Partial | Yes | `Dom_html` (element/document pointer lock — `requestPointerLock_` returns Promise, not yet typed) · Brr: `Brr.El.request_pointer_lock` | +| Pointer Lock API | Yes | Yes | `Dom_html` (`requestPointerLock`) · Brr: `Brr.El.request_pointer_lock` | | Selection API | Yes | No | `Dom_html` (`selection`, `range`) | ## Observers @@ -151,12 +151,12 @@ This document lists standard JavaScript/Web APIs and their support status in js_ |-----|------|-----|---------------------| | requestAnimationFrame | Yes | Yes | `Dom_html` (window) · Brr: `Brr.G.request_animation_frame` | | Performance API (now, mark, measure, entries) | Yes | Partial | `Performance` · Brr: `Brr.Performance` | -| Web Animations API | Yes | No | `Dom_html` (`animate`, `getAnimations`; `animation`, `animationEffect`, `keyframeEffect`, `computedKeyframe`, `animationTimeline`, `documentTimeline`, `optionalEffectTiming`, `computedEffectTiming`, `keyframeAnimationOptions`, `animationPlaybackEvent`); `Animation.finished`/`ready` Promise getters omitted — use `onfinish` event and `pending` property | +| Web Animations API | Yes | No | `Dom_html` (`animate`, `getAnimations`; `animation`, `animationEffect`, `keyframeEffect`, `computedKeyframe`, `animationTimeline`, `documentTimeline`, `optionalEffectTiming`, `computedEffectTiming`, `keyframeAnimationOptions`, `animationPlaybackEvent`) | | Web Components (Custom Elements, Shadow DOM) | Partial | No | `Dom_html` (Shadow DOM — `attachShadow`, `shadowRoot`, `assignedSlot`, `slot`); Custom Elements not bound | | Web Crypto API | No | Yes | Brr: `Brr_webcrypto` | | Notifications API | No | Yes | Brr: `Brr_io.Notification` | | Broadcast Channel API | No | Yes | Brr: `Brr_io.Message.Broadcast_channel` | -| AbortController / AbortSignal | No | Yes | Brr: `Brr.Abort` | +| AbortController / AbortSignal | Yes | Yes | `Abort` · Brr: `Brr.Abort` | --- @@ -167,17 +167,7 @@ widely used the API is in modern web development, whether an open issue exists, whether Brr already provides it (proving OCaml ecosystem demand), and whether other APIs depend on it. -### Tier 1 — Critical - -These form a dependency chain and should be tackled together. - -| API | Issue | In Brr | Why | -|-----|-------|--------|-----| -| Promise (upgrade to full) | [#2031](https://github.com/ocsigen/js_of_ocaml/issues/2031) | Yes | Core async primitive of JavaScript. Prerequisite for idiomatic Fetch, Web Crypto, and most modern APIs. | -| AbortController / AbortSignal | — | Yes | Required for cancelling Fetch requests, event listeners, and streams. Foundational primitive that Fetch and Streams depend on. | -| Fetch API | [#596](https://github.com/ocsigen/js_of_ocaml/issues/596) | Yes | The standard replacement for XHR. Virtually every modern web app uses it. The single most impactful missing binding. | - -### Tier 2 — High +### Tier 1 — High | API | Issue | In Brr | Why | |-----|-------|--------|-----| @@ -188,11 +178,10 @@ These form a dependency chain and should be tackled together. | MessageChannel / MessagePort | [#1464](https://github.com/ocsigen/js_of_ocaml/issues/1464) | Yes | Structured communication between Workers, iframes, and windows. Needed for non-trivial Worker usage. | | Notifications API | — | Yes | Common engagement feature in web apps. Small API surface. | -### Tier 3 — Medium +### Tier 2 — Medium | API | Issue | In Brr | Why | |-----|-------|--------|-----| -| Fullscreen API (upgrade) | — | Yes | Media players, presentations, games. Element/Document surface is bound; `requestFullscreen`/`exitFullscreen` need a typed Promise return (currently `requestFullscreen_`/`exitFullscreen_` return `unit`). | | Broadcast Channel API | — | Yes | Cross-tab communication (sync auth state, shared data). Simple API. | | Web Audio API | — | Yes | Audio processing, games, music apps. Large API surface but well-defined. | | Media Capture (getUserMedia) | — | Yes | Video calls, camera/mic access. Growing use with remote work tooling. | @@ -202,9 +191,8 @@ These form a dependency chain and should be tackled together. | Streams API | — | No | Modern data processing. Fetch response bodies are ReadableStreams. Increasingly foundational. | | History API (upgrade to full) | — | Yes | SPA routing depends on pushState/replaceState. Current binding is limited. | | HTMLMediaElement (upgrade to full) | — | Yes | Better audio/video control. Current binding only covers basic element types. | -| Pointer Lock API (upgrade) | — | Yes | 3D/game applications. Element/Document surface is bound; `requestPointerLock` needs a typed Promise return. | -### Tier 4 — Lower priority +### Tier 3 — Lower priority | API | Issue | In Brr | Why | |-----|-------|--------|-----| @@ -220,17 +208,9 @@ These form a dependency chain and should be tackled together. ### Suggested implementation order -1. **Promise (full) + AbortController + Fetch API** — as a single effort, since - they are interdependent. Closes the largest gap and addresses the oldest open - feature request ([#596](https://github.com/ocsigen/js_of_ocaml/issues/596), from 2017). -2. **Web Crypto API** — security-critical, no safe workaround. -3. **Clipboard API** — small surface, high user-facing value. -4. **Service Workers + Cache API** — enables PWAs, the main class of apps jsoo +1. **Web Crypto API** — security-critical, no safe workaround. +2. **Clipboard API** — small surface, high user-facing value. +3. **Service Workers + Cache API** — enables PWAs, the main class of apps jsoo cannot fully support today. -5. **MessageChannel / Notifications / Broadcast Channel** — small APIs that fill +4. **MessageChannel / Notifications / Broadcast Channel** — small APIs that fill out the remaining communication gaps. -6. **Promise-typed Fullscreen / Pointer Lock / Animation** — once - Promise is upgraded, replace the placeholder `requestFullscreen_` / - `requestPointerLock_` / `exitFullscreen_` methods with proper typed - bindings, and add `Animation.finished` / `Animation.ready` (currently - omitted because their only purpose is to be awaited). diff --git a/CHANGES.md b/CHANGES.md index 41c4aeeb9b..a74c69b6ea 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -14,6 +14,16 @@ * Lib: add `Performance` module (#2221) * Put more values into global variables (#2211) * Runtime: intial support for quickjs-ng +* Lib: add `Promise` module — bindings to JavaScript promises that + preserve type safety in the presence of `'a Promise.t Promise.t` (#2031) +* Lib: add Lwt interop for `Promise` in `Js_of_ocaml_lwt.Promise` + (`to_lwt` / `of_lwt`) +* Lib: add Promise-typed `Dom_html` bindings — `requestFullscreen`, + `requestPointerLock`, `exitFullscreen`, `mediaElement.play`, and + `Animation.{finished,ready}`. Existing fire-and-forget forms are kept + under the `_`-suffixed names +* Lib: add `Fetch` and `Abort` modules — Fetch API binding with a typed + `AbortController`/`AbortSignal` primitive for cancellation (#596) ## Bug fixes * Compiler: fix reference unboxing (#2210) @@ -33,6 +43,13 @@ * Lib: defer `Intl.{Collator,DateTimeFormat,...}` member lookups so the `Intl` module no longer throws at load time on hosts where `globalThis.Intl` is undefined +* Lib: fix method-name mangling on a few bindings where the OCaml name + resolved to the wrong JavaScript identifier: + `Typed_array._BYTES_PER_ELEMENT` (called `BYTES_PER`), + `WebGL._MAX_RENDERBUFFER_SIZE` (called `MAX_RENDERBUFFER`), and + `canvasElement.toDataURL_type_compression` (called `toDataURL_type`). + Renamed to `_BYTES_PER_ELEMENT_`, `_MAX_RENDERBUFFER_SIZE_`, and + `toDataURL_compression` respectively # 6.3.2 (2026-02-15) - Lille diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a00d5d752c..f288a31171 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -29,3 +29,59 @@ opam install odoc lwt_log yojson ocp-indent graphics higlo ### Running the tests Run `make tests`. + +## Library binding conventions + +When adding new bindings under `lib/js_of_ocaml/`, follow these rules so +that the role of an underscore in a method name is unambiguous. + +### Underscores in method names + +- **Leading `_`** — pure name mangling. Use it when the JavaScript + identifier is an OCaml keyword (`type`, `method`, `open`, `match`, + `end`, `as`, `effect`, `class`, `for`, `assert`, …) or starts with an + uppercase letter (which OCaml method names cannot). The `ppx_js_internal` + preprocessor strips the leading underscore in the generated JS, so + `method _type` reads `.type` on the JS side. Examples: `_method`, + `_type`, `_open`, `_URL`, `_PI`, `_HORIZONTAL_AXIS`. + +- **Trailing `_`** — *not* mangling. Reserved for a deliberate alternate + form of a method that already exists under the unsuffixed name: + + - **Argument-overload variant.** Same JS method, different OCaml + signature (e.g. extra optional flag, different result type). + Existing examples: `getInt16_` / `setInt16_` (DataView, take a + little-endian boolean), `bindBuffer_` / `bindFramebuffer_` / + `bindTexture_` (WebGL, accept an `opt` binding). + + - **Legacy fire-and-forget kept beside a Promise-typed version.** + When a JS API was previously bound as `foo : unit Js.meth` (ignoring + the returned `Promise`), and you are adding the proper + `foo : unit Promise.t Js.meth`, rename the legacy method to `foo_` + and put the Promise version on the unsuffixed `foo`. Document the + legacy form as fire-and-forget. Existing examples: + `requestFullscreen_`, `exitFullscreen_`, `requestPointerLock_`, + `play_` (HTMLMediaElement). + +Older code mixes these roles (`open_`, `type_`, `method_`, `assert_`, +`effect_` use trailing `_` for keyword escape rather than leading); +those are grandfathered. New code should follow the split above. + +### Multi-underscore names + +The mangler strips at most one leading `_` and then drops the last `_` +and everything after it. So a name with more than one non-leading +underscore resolves to something shorter than you might expect: + +| OCaml method | Calls JS identifier | +| ----------------------- | ------------------- | +| `abort_with_reason` | `abort_with` | +| `_BYTES_PER_ELEMENT` | `BYTES_PER` | +| `toDataURL_type_quality`| `toDataURL_type` | + +If the underlying JS identifier itself contains underscores (e.g. a +WebGL constant like `MAX_RENDERBUFFER_SIZE`), terminate the OCaml name +with a trailing `_` to anchor the rindex on the very end: +`_MAX_RENDERBUFFER_SIZE_`. If you want a single overload disambiguator +on a method like `toDataURL`, give the OCaml name exactly one trailing +`_` (e.g. `toDataURL_quality`, not `toDataURL_type_quality`). diff --git a/compiler/lib-runtime-files/js_of_ocaml_compiler_runtime_files.ml b/compiler/lib-runtime-files/js_of_ocaml_compiler_runtime_files.ml index abeec1a665..8cb9815ec5 100644 --- a/compiler/lib-runtime-files/js_of_ocaml_compiler_runtime_files.ml +++ b/compiler/lib-runtime-files/js_of_ocaml_compiler_runtime_files.ml @@ -46,6 +46,7 @@ let runtime = ; nat ; obj ; parsing + ; promise ; stdlib ; sys ; str diff --git a/compiler/lib-runtime-files/tests/all.ml b/compiler/lib-runtime-files/tests/all.ml index bfce56de33..db51141780 100644 --- a/compiler/lib-runtime-files/tests/all.ml +++ b/compiler/lib-runtime-files/tests/all.ml @@ -44,6 +44,7 @@ let%expect_test _ = +obj.js +parsing.js +prng.js + +promise.js +runtime_events.js +stdlib.js +str.js @@ -88,6 +89,7 @@ let%expect_test _ = +obj.js +parsing.js +prng.js + +promise.js +runtime_events.js +stdlib.js +str.js diff --git a/compiler/tests-jsoo/dune b/compiler/tests-jsoo/dune index f46b5d401c..596c6ea6d6 100644 --- a/compiler/tests-jsoo/dune +++ b/compiler/tests-jsoo/dune @@ -77,6 +77,8 @@ test_custom_name test_text_codec_fallback test_unix + test_promise + test_lwt_promise calc_parser calc_lexer)) (libraries unix compiler-libs.common js_of_ocaml-compiler) @@ -120,6 +122,23 @@ (javascript_files custom.js custom.wat)) (modes js wasm)) +(test + (name test_promise) + (modules test_promise) + (libraries js_of_ocaml) + (modes js wasm) + (preprocess + (pps ppx_js_internal))) + +(test + (name test_lwt_promise) + (package js_of_ocaml-lwt) + (modules test_lwt_promise) + (libraries js_of_ocaml js_of_ocaml-lwt lwt) + (modes js wasm) + (preprocess + (pps ppx_js_internal))) + (library (name test_custom_name) (modules test_custom_name) diff --git a/compiler/tests-jsoo/test_lwt_promise.expected b/compiler/tests-jsoo/test_lwt_promise.expected new file mode 100644 index 0000000000..313cf9bf3a --- /dev/null +++ b/compiler/tests-jsoo/test_lwt_promise.expected @@ -0,0 +1,6 @@ +start +to_lwt resolved 11 +to_lwt rejected with boom +of_lwt round-trip 22 +of_lwt failure round-trip +done diff --git a/compiler/tests-jsoo/test_lwt_promise.ml b/compiler/tests-jsoo/test_lwt_promise.ml new file mode 100644 index 0000000000..7c709bcde1 --- /dev/null +++ b/compiler/tests-jsoo/test_lwt_promise.ml @@ -0,0 +1,65 @@ +(* Js_of_ocaml + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(* Round-trip Promise <-> Lwt conversions. *) + +open Js_of_ocaml +open Js_of_ocaml_lwt + +let log s = print_endline s + +let ( let* ) = Lwt.bind + +let main : unit Lwt.t = + log "start"; + (* Promise -> Lwt: resolved value flows through *) + let* n = Promise.to_lwt (Promise.resolve 11) in + log (Printf.sprintf "to_lwt resolved %d" n); + (* Promise -> Lwt: rejection becomes Promise.Rejected *) + let* () = + Lwt.catch + (fun () -> + let* () = + Promise.to_lwt + (Promise.reject (Promise.error_of_any (Js.Unsafe.inject (Js.string "boom")))) + in + log "to_lwt rejection NOT caught"; + Lwt.return ()) + (function + | Promise.Rejected e -> + let s : Js.js_string Js.t = Js.Unsafe.coerce (Promise.error_to_any e) in + log (Printf.sprintf "to_lwt rejected with %s" (Js.to_string s)); + Lwt.return () + | exn -> + log (Printf.sprintf "unexpected exn %s" (Printexc.to_string exn)); + Lwt.return ()) + in + (* Lwt -> Promise: returned value flows through *) + let* n = Promise.to_lwt (Promise.of_lwt (Lwt.return 22)) in + log (Printf.sprintf "of_lwt round-trip %d" n); + (* Lwt -> Promise: failed thread rejects, then to_lwt re-raises *) + let* () = + Lwt.catch + (fun () -> + let* () = Promise.to_lwt (Promise.of_lwt (Lwt.fail (Failure "lwt-boom"))) in + log "of_lwt failure NOT caught"; + Lwt.return ()) + (fun _ -> + log "of_lwt failure round-trip"; + Lwt.return ()) + in + log "done"; + Lwt.return () + +let () = Lwt.async (fun () -> main) diff --git a/compiler/tests-jsoo/test_promise.expected b/compiler/tests-jsoo/test_promise.expected new file mode 100644 index 0000000000..8beb3bfa70 --- /dev/null +++ b/compiler/tests-jsoo/test_promise.expected @@ -0,0 +1,13 @@ +start +scheduled +then_/map got 2 +make got hello +caught boom +finally ok +finally err +all got [10; 20; 30] +race got 42 +nested got 7 +of_any got 99 +reject-with-promise got 555 +done diff --git a/compiler/tests-jsoo/test_promise.ml b/compiler/tests-jsoo/test_promise.ml new file mode 100644 index 0000000000..3321986b7c --- /dev/null +++ b/compiler/tests-jsoo/test_promise.ml @@ -0,0 +1,121 @@ +(* Js_of_ocaml + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +(* Exercises Promise chaining end-to-end. Output is captured by node after + the microtask queue drains, so both synchronous and asynchronous prints + end up in the .expected file. To keep ordering deterministic we run + every step inside a single chain rather than several independent ones. *) + +open Js_of_ocaml + +let log s = print_endline s + +let ( >>= ) p f = Promise.then_ f p + +let return = Promise.resolve + +let test_resolve_then_map () = + return 1 + |> Promise.map (fun x -> x + 1) + >>= fun x -> + log (Printf.sprintf "then_/map got %d" x); + return () + +let test_make () = + Promise.make (fun ~resolve ~reject:_ -> resolve "hello") + >>= fun s -> + log (Printf.sprintf "make got %s" s); + return () + +let test_catch () = + let p = Promise.reject (Promise.error_of_any (Js.Unsafe.inject (Js.string "boom"))) in + Promise.catch + (fun e -> + let s : Js.js_string Js.t = Js.Unsafe.coerce (Promise.error_to_any e) in + log (Printf.sprintf "caught %s" (Js.to_string s)); + return ()) + p + +let test_finally_ok () = return () |> Promise.finally (fun () -> log "finally ok") + +let test_finally_err () = + Promise.reject (Promise.error_of_any (Js.Unsafe.inject (Js.string "x"))) + |> Promise.finally (fun () -> log "finally err") + |> Promise.catch (fun _ -> return ()) + +let test_all () = + Promise.all [ return 10; return 20; return 30 ] + >>= fun xs -> + log (Printf.sprintf "all got [%s]" (String.concat "; " (List.map string_of_int xs))); + return () + +let test_race () = + Promise.race [ return 42; return 99 ] + >>= fun x -> + log (Printf.sprintf "race got %d" x); + return () + +let test_no_flatten () = + let inner : int Promise.t = return 7 in + (return inner : int Promise.t Promise.t) + >>= fun (p : int Promise.t) -> + p + >>= fun n -> + log (Printf.sprintf "nested got %d" n); + return () + +let test_of_any_foreign () = + (* A foreign JS promise whose resolved value was never wrapped by us. + [then_] must pass it through unchanged rather than reading [.wrapped]. *) + let foreign : Js.Unsafe.any = + Js.Unsafe.meth_call Js.Unsafe.global##._Promise "resolve" [| Js.Unsafe.inject 99 |] + in + Promise.of_any foreign + >>= fun (n : int) -> + log (Printf.sprintf "of_any got %d" n); + return () + +let test_reject_with_promise () = + (* JS [Promise.reject] does not auto-follow thenables (only [resolve] + does), so a promise as the rejection reason should reach [catch] + intact and be recoverable via [of_any]. *) + let inner : int Promise.t = return 555 in + let p : unit Promise.t = Promise.reject (Promise.error_of_any (Promise.to_any inner)) in + Promise.catch + (fun e -> + let recovered : int Promise.t = Promise.of_any (Promise.error_to_any e) in + recovered + >>= fun n -> + log (Printf.sprintf "reject-with-promise got %d" n); + return ()) + p + +let () = + log "start"; + let _ : unit Promise.t = + test_resolve_then_map () + >>= test_make + >>= test_catch + >>= test_finally_ok + >>= test_finally_err + >>= test_all + >>= test_race + >>= test_no_flatten + >>= test_of_any_foreign + >>= test_reject_with_promise + >>= fun () -> + log "done"; + return () + in + log "scheduled" diff --git a/lib/js_of_ocaml/abort.ml b/lib/js_of_ocaml/abort.ml new file mode 100644 index 0000000000..bdc85027b5 --- /dev/null +++ b/lib/js_of_ocaml/abort.ml @@ -0,0 +1,39 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open! Import + +class type signal = object ('self) + method aborted : bool Js.t Js.readonly_prop + + method reason : Js.Unsafe.any Js.readonly_prop + + method onabort : ('self Js.t, 'self Dom.event Js.t) Dom.event_listener Js.writeonly_prop + + method throwIfAborted : unit Js.meth +end + +class type controller = object + method signal : signal Js.t Js.readonly_prop + + method abort : unit Js.meth + + method abort_reason : Js.Unsafe.any -> unit Js.meth +end + +let controller : controller Js.t Js.constr = Js.Unsafe.global##._AbortController diff --git a/lib/js_of_ocaml/abort.mli b/lib/js_of_ocaml/abort.mli new file mode 100644 index 0000000000..7b2e766823 --- /dev/null +++ b/lib/js_of_ocaml/abort.mli @@ -0,0 +1,47 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(** AbortController / AbortSignal. + + A general-purpose cancellation primitive used by {!Fetch}, event + listener registration, [Streams], and custom asynchronous code. + + @see + @see *) + +open Js + +class type signal = object ('self) + method aborted : bool t readonly_prop + + method reason : Unsafe.any readonly_prop + + method onabort : ('self t, 'self Dom.event t) Dom.event_listener writeonly_prop + + method throwIfAborted : unit meth +end + +class type controller = object + method signal : signal t readonly_prop + + method abort : unit meth + + method abort_reason : Unsafe.any -> unit meth +end + +val controller : controller t constr diff --git a/lib/js_of_ocaml/dom_html.ml b/lib/js_of_ocaml/dom_html.ml index 879df4b868..5ca6d8c1b9 100644 --- a/lib/js_of_ocaml/dom_html.ml +++ b/lib/js_of_ocaml/dom_html.ml @@ -1143,6 +1143,10 @@ and animation = object method updatePlaybackRate : number_t -> unit meth + method finished : animation t Promise.t readonly_prop + + method ready : animation t Promise.t readonly_prop + method oncancel : (animation t, animationPlaybackEvent t) event_listener writeonly_prop method onfinish : (animation t, animationPlaybackEvent t) event_listener writeonly_prop @@ -1403,8 +1407,12 @@ and element = object method requestFullscreen_ : unit meth + method requestFullscreen : unit Promise.t meth + method requestPointerLock_ : unit meth + method requestPointerLock : unit Promise.t meth + method animate : 'a 'b. 'a -> 'b -> animation t meth method animate_keyframes : 'a. 'a -> animation t meth @@ -2737,7 +2745,9 @@ class type mediaElement = object method load : unit meth - method play : unit meth + method play_ : unit meth + + method play : unit Promise.t meth method pause : unit meth @@ -2859,7 +2869,7 @@ class type canvasElement = object method toDataURL_type : js_string t -> js_string t meth - method toDataURL_type_compression : js_string t -> number_t -> js_string t meth + method toDataURL_compression : js_string t -> number_t -> js_string t meth method getContext : js_string t -> canvasRenderingContext2D t meth end @@ -3315,6 +3325,8 @@ class type document = object method exitFullscreen_ : unit meth + method exitFullscreen : unit Promise.t meth + method exitPointerLock : unit meth method onreadystatechange : (document t, event t) event_listener writeonly_prop diff --git a/lib/js_of_ocaml/dom_html.mli b/lib/js_of_ocaml/dom_html.mli index 2e92b3ee56..b2d7a99b76 100644 --- a/lib/js_of_ocaml/dom_html.mli +++ b/lib/js_of_ocaml/dom_html.mli @@ -1163,6 +1163,14 @@ and animation = object method updatePlaybackRate : number_t -> unit meth + method finished : animation t Promise.t readonly_prop + (** Resolves when the animation reaches its end, or rejects when it is + cancelled. *) + + method ready : animation t Promise.t readonly_prop + (** Resolves when the animation is ready to play (i.e. the user agent + has finished any pending changes to its state). *) + method oncancel : (animation t, animationPlaybackEvent t) event_listener writeonly_prop method onfinish : (animation t, animationPlaybackEvent t) event_listener writeonly_prop @@ -1427,13 +1435,16 @@ and element = object method blur : unit meth method requestFullscreen_ : unit meth - (** Returns a [Promise] in JavaScript. Bound as [unit meth] to avoid pulling - in a Promise type; the proper version can later be added under - [requestFullscreen]. *) + (** Fire-and-forget binding. See {!requestFullscreen} for the version that + exposes the returned [Promise]. *) + + method requestFullscreen : unit Promise.t meth method requestPointerLock_ : unit meth - (** Returns a [Promise] in JavaScript (since 2024). Bound as [unit meth]; - the proper version can later be added under [requestPointerLock]. *) + (** Fire-and-forget binding. See {!requestPointerLock} for the version that + exposes the returned [Promise] (available since 2024). *) + + method requestPointerLock : unit Promise.t meth method animate : 'a 'b. 'a -> 'b -> animation t meth @@ -2555,7 +2566,12 @@ class type mediaElement = object method load : unit meth - method play : unit meth + method play_ : unit meth + (** Fire-and-forget binding. See {!play} for the version that exposes + the returned [Promise], which is what you need to detect autoplay + rejections (e.g. [NotAllowedError]). *) + + method play : unit Promise.t meth method pause : unit meth @@ -2679,7 +2695,7 @@ class type canvasElement = object method toDataURL_type : js_string t -> js_string t meth - method toDataURL_type_compression : js_string t -> number_t -> js_string t meth + method toDataURL_compression : js_string t -> number_t -> js_string t meth method getContext : context -> canvasRenderingContext2D t meth end @@ -3140,8 +3156,10 @@ class type document = object method timeline : documentTimeline t readonly_prop method exitFullscreen_ : unit meth - (** Returns a [Promise] in JavaScript. Bound as [unit meth]; the proper - version can later be added under [exitFullscreen]. *) + (** Fire-and-forget binding. See {!exitFullscreen} for the version that + exposes the returned [Promise]. *) + + method exitFullscreen : unit Promise.t meth method exitPointerLock : unit meth diff --git a/lib/js_of_ocaml/fetch.ml b/lib/js_of_ocaml/fetch.ml new file mode 100644 index 0000000000..b6aa8e8f0c --- /dev/null +++ b/lib/js_of_ocaml/fetch.ml @@ -0,0 +1,174 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open! Import + +class type headers = object + method append : Js.js_string Js.t -> Js.js_string Js.t -> unit Js.meth + + method delete : Js.js_string Js.t -> unit Js.meth + + method get : Js.js_string Js.t -> Js.js_string Js.t Js.opt Js.meth + + method has : Js.js_string Js.t -> bool Js.t Js.meth + + method set : Js.js_string Js.t -> Js.js_string Js.t -> unit Js.meth + + method forEach : + (Js.js_string Js.t -> Js.js_string Js.t -> headers Js.t -> unit) Js.callback + -> unit Js.meth +end + +let headers : headers Js.t Js.constr = Js.Unsafe.global##._Headers + +let headers_of_list (l : (string * string) list) : headers Js.t = + let h : headers Js.t = + Js.Unsafe.new_obj (Js.Unsafe.global##._Headers : _ Js.constr) [||] + in + List.iter (fun (k, v) -> h##append (Js.string k) (Js.string v)) l; + h + +class type body = object + method bodyUsed : bool Js.t Js.readonly_prop + + method arrayBuffer : Typed_array.arrayBuffer Js.t Promise.t Js.meth + + method blob : File.blob Js.t Promise.t Js.meth + + method json : Js.Unsafe.any Promise.t Js.meth + + method text : Js.js_string Js.t Promise.t Js.meth + + method formData : Form.formData Js.t Promise.t Js.meth +end + +class type requestInit = object + method _method : Js.js_string Js.t Js.writeonly_prop + + method headers : headers Js.t Js.writeonly_prop + + method body : Js.Unsafe.any Js.writeonly_prop + + method mode : Js.js_string Js.t Js.writeonly_prop + + method credentials : Js.js_string Js.t Js.writeonly_prop + + method cache : Js.js_string Js.t Js.writeonly_prop + + method redirect : Js.js_string Js.t Js.writeonly_prop + + method referrer : Js.js_string Js.t Js.writeonly_prop + + method referrerPolicy : Js.js_string Js.t Js.writeonly_prop + + method integrity : Js.js_string Js.t Js.writeonly_prop + + method keepalive : bool Js.t Js.writeonly_prop + + method signal : Abort.signal Js.t Js.writeonly_prop +end + +let empty_request_init () : requestInit Js.t = Js.Unsafe.obj [||] + +class type request = object + inherit body + + method url : Js.js_string Js.t Js.readonly_prop + + method _method : Js.js_string Js.t Js.readonly_prop + + method headers : headers Js.t Js.readonly_prop + + method destination : Js.js_string Js.t Js.readonly_prop + + method referrer : Js.js_string Js.t Js.readonly_prop + + method referrerPolicy : Js.js_string Js.t Js.readonly_prop + + method mode : Js.js_string Js.t Js.readonly_prop + + method credentials : Js.js_string Js.t Js.readonly_prop + + method cache : Js.js_string Js.t Js.readonly_prop + + method redirect : Js.js_string Js.t Js.readonly_prop + + method integrity : Js.js_string Js.t Js.readonly_prop + + method keepalive : bool Js.t Js.readonly_prop + + method signal : Abort.signal Js.t Js.readonly_prop + + method clone : request Js.t Js.meth +end + +let request : (Js.js_string Js.t -> request Js.t) Js.constr = Js.Unsafe.global##._Request + +let request_with_init : (Js.js_string Js.t -> requestInit Js.t -> request Js.t) Js.constr + = + Js.Unsafe.global##._Request + +class type responseInit = object + method status : int Js.writeonly_prop + + method statusText : Js.js_string Js.t Js.writeonly_prop + + method headers : headers Js.t Js.writeonly_prop +end + +let empty_response_init () : responseInit Js.t = Js.Unsafe.obj [||] + +class type response = object + inherit body + + method headers : headers Js.t Js.readonly_prop + + method ok : bool Js.t Js.readonly_prop + + method redirected : bool Js.t Js.readonly_prop + + method status : int Js.readonly_prop + + method statusText : Js.js_string Js.t Js.readonly_prop + + method _type : Js.js_string Js.t Js.readonly_prop + + method url : Js.js_string Js.t Js.readonly_prop + + method clone : response Js.t Js.meth +end + +let response : (Js.Unsafe.any -> response Js.t) Js.constr = Js.Unsafe.global##._Response + +let response_with_init : (Js.Unsafe.any -> responseInit Js.t -> response Js.t) Js.constr = + Js.Unsafe.global##._Response + +let fetch_global = Js.Unsafe.global##.fetch + +let is_supported () = Js.Optdef.test fetch_global + +let fetch (url : Js.js_string Js.t) : response Js.t Promise.t = + Promise.of_any (Js.Unsafe.fun_call fetch_global [| Js.Unsafe.inject url |]) + +let fetch_with_init (url : Js.js_string Js.t) (init : requestInit Js.t) : + response Js.t Promise.t = + Promise.of_any + (Js.Unsafe.fun_call fetch_global [| Js.Unsafe.inject url; Js.Unsafe.inject init |]) + +let fetch_request (req : request Js.t) : response Js.t Promise.t = + Promise.of_any (Js.Unsafe.fun_call fetch_global [| Js.Unsafe.inject req |]) diff --git a/lib/js_of_ocaml/fetch.mli b/lib/js_of_ocaml/fetch.mli new file mode 100644 index 0000000000..8bf5a586cb --- /dev/null +++ b/lib/js_of_ocaml/fetch.mli @@ -0,0 +1,177 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(** Fetch API. + + @see + @see *) + +open Js + +(** {1 Headers} *) + +class type headers = object + method append : js_string t -> js_string t -> unit meth + + method delete : js_string t -> unit meth + + method get : js_string t -> js_string t opt meth + + method has : js_string t -> bool t meth + + method set : js_string t -> js_string t -> unit meth + + method forEach : + (js_string t -> js_string t -> headers t -> unit) Js.callback -> unit meth +end + +val headers : headers t constr + +val headers_of_list : (string * string) list -> headers Js.t +(** Build a [headers] object from a list of [(name, value)] pairs. *) + +(** {1 Request} *) + +(** The body-reader methods are Promise-typed — see {!Promise}. *) +class type body = object + method bodyUsed : bool t readonly_prop + + method arrayBuffer : Typed_array.arrayBuffer t Promise.t meth + + method blob : File.blob t Promise.t meth + + method json : Unsafe.any Promise.t meth + + method text : js_string t Promise.t meth + + method formData : Form.formData t Promise.t meth +end + +(** Initializer for {!request} (and {!fetch_with_init}). All fields are + optional; create an empty record with {!empty_request_init} and + populate the ones you need. *) +class type requestInit = object + method _method : js_string t writeonly_prop + + method headers : headers t writeonly_prop + + method body : Unsafe.any writeonly_prop + + method mode : js_string t writeonly_prop + + method credentials : js_string t writeonly_prop + + method cache : js_string t writeonly_prop + + method redirect : js_string t writeonly_prop + + method referrer : js_string t writeonly_prop + + method referrerPolicy : js_string t writeonly_prop + + method integrity : js_string t writeonly_prop + + method keepalive : bool t writeonly_prop + + method signal : Abort.signal t writeonly_prop +end + +val empty_request_init : unit -> requestInit t + +class type request = object + inherit body + + method url : js_string t readonly_prop + + method _method : js_string t readonly_prop + + method headers : headers t readonly_prop + + method destination : js_string t readonly_prop + + method referrer : js_string t readonly_prop + + method referrerPolicy : js_string t readonly_prop + + method mode : js_string t readonly_prop + + method credentials : js_string t readonly_prop + + method cache : js_string t readonly_prop + + method redirect : js_string t readonly_prop + + method integrity : js_string t readonly_prop + + method keepalive : bool t readonly_prop + + method signal : Abort.signal t readonly_prop + + method clone : request t meth +end + +val request : (js_string t -> request t) constr + +val request_with_init : (js_string t -> requestInit t -> request t) constr + +(** {1 Response} *) + +class type responseInit = object + method status : int writeonly_prop + + method statusText : js_string t writeonly_prop + + method headers : headers t writeonly_prop +end + +val empty_response_init : unit -> responseInit t + +class type response = object + inherit body + + method headers : headers t readonly_prop + + method ok : bool t readonly_prop + + method redirected : bool t readonly_prop + + method status : int readonly_prop + + method statusText : js_string t readonly_prop + + method _type : js_string t readonly_prop + + method url : js_string t readonly_prop + + method clone : response t meth +end + +val response : (Unsafe.any -> response t) constr + +val response_with_init : (Unsafe.any -> responseInit t -> response t) constr + +(** {1 fetch} *) + +val fetch : js_string t -> response t Promise.t + +val fetch_with_init : js_string t -> requestInit t -> response t Promise.t + +val fetch_request : request t -> response t Promise.t + +val is_supported : unit -> bool +(** Whether the [fetch] global is available in the current environment. *) diff --git a/lib/js_of_ocaml/js_of_ocaml.ml b/lib/js_of_ocaml/js_of_ocaml.ml index fb071339a8..2c3679b030 100644 --- a/lib/js_of_ocaml/js_of_ocaml.ml +++ b/lib/js_of_ocaml/js_of_ocaml.ml @@ -17,6 +17,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +module Abort = Abort module CSS = CSS module Console = Console module Dom = Dom @@ -25,6 +26,7 @@ module Dom_html = Dom_html module Dom_svg = Dom_svg module Effect_js = Effect_js module EventSource = EventSource +module Fetch = Fetch module File = File module Firebug = Console [@@ocaml.deprecated "[since 6.0] Use Js_of_ocaml.Console instead."] @@ -39,6 +41,7 @@ module Jstable = Jstable module MutationObserver = MutationObserver module Performance = Performance module PerformanceObserver = PerformanceObserver +module Promise = Promise module ResizeObserver = ResizeObserver module Regexp = Regexp module Sys_js = Sys_js diff --git a/lib/js_of_ocaml/promise.ml b/lib/js_of_ocaml/promise.ml new file mode 100644 index 0000000000..71613b185b --- /dev/null +++ b/lib/js_of_ocaml/promise.ml @@ -0,0 +1,100 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open! Import + +type +'a t = Js.Unsafe.any + +type error = Js.Unsafe.any + +(* The wrap/unwrap helpers live in [runtime/js/promise.js] (with a Wasm + counterpart in [runtime/wasm/promise.wat]) and are also exposed as + OCaml externals from [Jsoo_runtime.Promise]. Wrapping is conditional + on the value being thenable, so non-thenable resolves pay no + allocation and foreign promises handed in via [of_any] pass through + unchanged. *) + +external wrap : 'a -> Js.Unsafe.any = "caml_jsoo_promise_wrap" + +external unwrap : Js.Unsafe.any -> 'a = "caml_jsoo_promise_unwrap" + +let promise_global = Js.Unsafe.global##._Promise + +let is_supported () = Js.Optdef.test promise_global + +let resolve (x : 'a) : 'a t = Js.Unsafe.meth_call promise_global "resolve" [| wrap x |] + +let reject (e : error) : 'a t = + Js.Unsafe.meth_call promise_global "reject" [| Js.Unsafe.inject e |] + +let make (f : resolve:('a -> unit) -> reject:(error -> unit) -> unit) : 'a t = + let body = + Js.wrap_callback (fun resolve_js reject_js -> + let resolve x = + ignore (Js.Unsafe.fun_call resolve_js [| wrap x |] : Js.Unsafe.any) + in + let reject e = + ignore (Js.Unsafe.fun_call reject_js [| Js.Unsafe.inject e |] : Js.Unsafe.any) + in + f ~resolve ~reject) + in + Js.Unsafe.new_obj promise_global [| Js.Unsafe.inject body |] + +let then_ ?on_error (f : 'a -> 'b t) (p : 'a t) : 'b t = + let cb = Js.wrap_callback (fun (w : Js.Unsafe.any) -> f (unwrap w)) in + match on_error with + | None -> Js.Unsafe.meth_call p "then" [| Js.Unsafe.inject cb |] + | Some g -> + let cb_err = Js.wrap_callback g in + Js.Unsafe.meth_call p "then" [| Js.Unsafe.inject cb; Js.Unsafe.inject cb_err |] + +let catch (f : error -> 'a t) (p : 'a t) : 'a t = + let cb = Js.wrap_callback f in + Js.Unsafe.meth_call p "catch" [| Js.Unsafe.inject cb |] + +let finally (f : unit -> unit) (p : 'a t) : 'a t = + let cb = Js.wrap_callback f in + Js.Unsafe.meth_call p "finally" [| Js.Unsafe.inject cb |] + +let map (f : 'a -> 'b) (p : 'a t) : 'b t = then_ (fun x -> resolve (f x)) p + +let bind f p = then_ f p + +let all (ps : 'a t list) : 'a list t = + let arr = Js.array (Array.of_list ps) in + let raw = Js.Unsafe.meth_call promise_global "all" [| Js.Unsafe.inject arr |] in + let cb = + Js.wrap_callback (fun (a : Js.Unsafe.any Js.js_array Js.t) -> + let lst = List.map unwrap (Array.to_list (Js.to_array a)) in + resolve lst) + in + Js.Unsafe.meth_call raw "then" [| Js.Unsafe.inject cb |] + +let race (ps : 'a t list) : 'a t = + let arr = Js.array (Array.of_list ps) in + Js.Unsafe.meth_call promise_global "race" [| Js.Unsafe.inject arr |] + +let error_of_any (x : Js.Unsafe.any) : error = x + +let error_to_any (e : error) : Js.Unsafe.any = e + +let error_of_exn (e : exn) : error = Js.Unsafe.inject e + +let to_any (p : 'a t) : Js.Unsafe.any = p + +let of_any (x : Js.Unsafe.any) : 'a t = x diff --git a/lib/js_of_ocaml/promise.mli b/lib/js_of_ocaml/promise.mli new file mode 100644 index 0000000000..6cb17d124b --- /dev/null +++ b/lib/js_of_ocaml/promise.mli @@ -0,0 +1,125 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(** Bindings to the JavaScript [Promise] API. + + A value of type ['a t] represents a JavaScript promise that, when + fulfilled, resolves with a value of OCaml type ['a]. + + {2 Type safety} + + Native JavaScript promises automatically flatten any thenable returned + from a handler or passed to [Promise.resolve]. That means a JavaScript + [Promise] can never resolve with another [Promise] as its value, which + is unsound at the OCaml type level for, say, ['a t t]. + + These bindings work around that by wrapping every value in a small + container before resolving and unwrapping it on the way out. As a + result, ['a t] values always resolve with a value of OCaml type ['a], + even when ['a] is itself ['_ t]. + + {2 Interop with raw JavaScript promises} + + Use {!of_any} / {!to_any} to interoperate with promises coming from + outside this module. A ['a t] obtained via {!of_any} from a foreign + promise will not be wrapped, so it is up to the caller to ensure the + types line up. *) + +type +'a t + +type error +(** The reason a promise was rejected. JavaScript allows rejecting with any + value (not necessarily an [Error]), so {!error} is opaque; use + {!error_to_any} to inspect it and {!error_of_any} to construct one. *) + +(** {1 Errors} *) + +val error_of_any : Js.Unsafe.any -> error + +val error_to_any : error -> Js.Unsafe.any + +val error_of_exn : exn -> error +(** Use an OCaml exception as a rejection reason. *) + +(** {1 Building promises} *) + +val resolve : 'a -> 'a t +(** A promise already fulfilled with the given value. *) + +val reject : error -> 'a t +(** A promise already rejected with the given reason. *) + +val make : (resolve:('a -> unit) -> reject:(error -> unit) -> unit) -> 'a t +(** [make f] runs [f] synchronously with two callbacks; [f] is expected to + eventually invoke either [resolve] or [reject] to settle the promise. *) + +(** {1 Chaining} *) + +val then_ : ?on_error:(error -> 'b t) -> ('a -> 'b t) -> 'a t -> 'b t +(** [then_ f p] returns a new promise that, when [p] fulfills with [x], + fulfills (or rejects) like [f x]. If [p] is rejected, the rejection + is propagated. + + If [~on_error] is supplied, this is the two-callback form of + [.then(f, g)] in JavaScript: [on_error] only fires for rejections of + [p] itself. If [f] returns a rejected promise, [on_error] does {e + not} catch it; chain a {!catch} afterwards if you need that. *) + +val catch : (error -> 'a t) -> 'a t -> 'a t +(** [catch f p] returns a new promise that, when [p] is rejected with + reason [e], fulfills (or rejects) like [f e]. If [p] is fulfilled, + its value is propagated. *) + +val finally : (unit -> unit) -> 'a t -> 'a t +(** [finally f p] returns a new promise that settles the same way as [p], + after invoking [f] for its side effect. *) + +val map : ('a -> 'b) -> 'a t -> 'b t +(** [map f p] is [then_ (fun x -> resolve (f x)) p]. *) + +val bind : ('a -> 'b t) -> 'a t -> 'b t +(** Alias for {!then_}. *) + +(** {1 Combinators} *) + +val all : 'a t list -> 'a list t +(** [all ps] resolves with the values of all promises in [ps], in order, + or rejects with the reason of the first promise to reject. *) + +val race : 'a t list -> 'a t +(** [race ps] settles like the first promise in [ps] to settle, fulfilled + or rejected. *) + +(** {1 Unsafe interop} *) + +val to_any : 'a t -> Js.Unsafe.any +(** Expose the underlying JavaScript promise. The resolved value may be the + internal wrapper rather than the raw payload; consumers that observe + the value should chain a [.then] that unwraps via {!of_any} → {!then_} + rather than reading [.then] directly from the foreign side. *) + +val of_any : Js.Unsafe.any -> 'a t +(** Treat a foreign JavaScript promise as a ['a t]. The returned value is + only sound if the underlying promise actually resolves with a value of + type ['a]; raw foreign values are passed through {!then_} unchanged. *) + +(** {1 Capability detection} *) + +val is_supported : unit -> bool +(** Whether the JavaScript [Promise] global is available in the current + environment. *) diff --git a/lib/js_of_ocaml/typed_array.ml b/lib/js_of_ocaml/typed_array.ml index e29be12828..e7b5bcd5d7 100644 --- a/lib/js_of_ocaml/typed_array.ml +++ b/lib/js_of_ocaml/typed_array.ml @@ -41,7 +41,7 @@ end class type ['a, 'b, 'c] typedArray = object inherit arrayBufferView - method _BYTES_PER_ELEMENT : int readonly_prop + method _BYTES_PER_ELEMENT_ : int readonly_prop method length : int readonly_prop diff --git a/lib/js_of_ocaml/typed_array.mli b/lib/js_of_ocaml/typed_array.mli index e3a004b5b5..8674f02274 100644 --- a/lib/js_of_ocaml/typed_array.mli +++ b/lib/js_of_ocaml/typed_array.mli @@ -43,7 +43,7 @@ end class type ['a, 'b, 'c] typedArray = object inherit arrayBufferView - method _BYTES_PER_ELEMENT : int readonly_prop + method _BYTES_PER_ELEMENT_ : int readonly_prop method length : int readonly_prop diff --git a/lib/js_of_ocaml/webGL.ml b/lib/js_of_ocaml/webGL.ml index 15f3a9d411..b87d67fd80 100644 --- a/lib/js_of_ocaml/webGL.ml +++ b/lib/js_of_ocaml/webGL.ml @@ -1050,7 +1050,7 @@ class type renderingContext = object method _RENDERBUFFER_BINDING_ : renderbuffer t opt parameter readonly_prop - method _MAX_RENDERBUFFER_SIZE : int parameter readonly_prop + method _MAX_RENDERBUFFER_SIZE_ : int parameter readonly_prop method _NEVER : depthFunction readonly_prop diff --git a/lib/js_of_ocaml/webGL.mli b/lib/js_of_ocaml/webGL.mli index 5d84d6b713..76392cc46d 100644 --- a/lib/js_of_ocaml/webGL.mli +++ b/lib/js_of_ocaml/webGL.mli @@ -1040,7 +1040,7 @@ class type renderingContext = object method _RENDERBUFFER_BINDING_ : renderbuffer t opt parameter readonly_prop - method _MAX_RENDERBUFFER_SIZE : int parameter readonly_prop + method _MAX_RENDERBUFFER_SIZE_ : int parameter readonly_prop method _NEVER : depthFunction readonly_prop diff --git a/lib/lwt/js_of_ocaml_lwt.ml b/lib/lwt/js_of_ocaml_lwt.ml index 29ebf088ae..e19b77f5b9 100644 --- a/lib/lwt/js_of_ocaml_lwt.ml +++ b/lib/lwt/js_of_ocaml_lwt.ml @@ -27,6 +27,11 @@ module File = struct include Lwt_file end +module Promise = struct + include Js_of_ocaml.Promise + include Lwt_promise +end + module Jsonp = Lwt_jsonp module Lwt_js = Lwt_js module Lwt_js_events = Lwt_js_events diff --git a/lib/lwt/lwt_promise.ml b/lib/lwt/lwt_promise.ml new file mode 100644 index 0000000000..5f99b7f66d --- /dev/null +++ b/lib/lwt/lwt_promise.ml @@ -0,0 +1,39 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Js_of_ocaml + +exception Rejected of Promise.error + +let to_lwt (p : 'a Promise.t) : 'a Lwt.t = + let t, w = Lwt.task () in + let _ : unit Promise.t = + Promise.then_ + (fun x -> + Lwt.wakeup_later w x; + Promise.resolve ()) + p + |> Promise.catch (fun e -> + Lwt.wakeup_later_exn w (Rejected e); + Promise.resolve ()) + in + t + +let of_lwt (t : 'a Lwt.t) : 'a Promise.t = + Promise.make (fun ~resolve ~reject -> + Lwt.on_any t resolve (fun exn -> reject (Promise.error_of_exn exn))) diff --git a/lib/lwt/lwt_promise.mli b/lib/lwt/lwt_promise.mli new file mode 100644 index 0000000000..a6fda1f41b --- /dev/null +++ b/lib/lwt/lwt_promise.mli @@ -0,0 +1,35 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(** Conversions between {!Js_of_ocaml.Promise} and {!Lwt}. *) + +open Js_of_ocaml + +exception Rejected of Promise.error +(** Raised by the [Lwt.t] returned by {!to_lwt} when the underlying + [Promise] rejects. The rejection reason is wrapped unchanged — even + when it is an OCaml exception (e.g. produced via + {!Promise.error_of_exn}), use {!Promise.error_to_any} to inspect it. *) + +val to_lwt : 'a Promise.t -> 'a Lwt.t +(** [to_lwt p] is an Lwt thread that fulfils with the value [p] resolves + with, or fails with {!Rejected} if [p] is rejected. *) + +val of_lwt : 'a Lwt.t -> 'a Promise.t +(** [of_lwt t] is a [Promise] that resolves with the value [t] returns, + or rejects with [Promise.error_of_exn exn] if [t] fails. *) diff --git a/lib/runtime/js_of_ocaml_runtime_stubs.c b/lib/runtime/js_of_ocaml_runtime_stubs.c index 858cdee782..e7792073df 100644 --- a/lib/runtime/js_of_ocaml_runtime_stubs.c +++ b/lib/runtime/js_of_ocaml_runtime_stubs.c @@ -220,6 +220,14 @@ void caml_jsoo_flags_use_js_string () { caml_fatal_error("Unimplemented Javascript primitive caml_jsoo_flags_use_js_string!"); } +void caml_jsoo_promise_unwrap () { + caml_fatal_error("Unimplemented Javascript primitive caml_jsoo_promise_unwrap!"); +} + +void caml_jsoo_promise_wrap () { + caml_fatal_error("Unimplemented Javascript primitive caml_jsoo_promise_wrap!"); +} + void caml_jsoo_runtime_value () { caml_fatal_error("Unimplemented Javascript primitive caml_jsoo_runtime_value!"); } diff --git a/lib/runtime/jsoo_runtime.ml b/lib/runtime/jsoo_runtime.ml index d4e1868c5f..6612b94998 100644 --- a/lib/runtime/jsoo_runtime.ml +++ b/lib/runtime/jsoo_runtime.ml @@ -291,3 +291,14 @@ module Effect : sig end = struct external assume_no_perform : (unit -> 'a) -> 'a = "caml_assume_no_perform" end + +module Promise = struct + (** Low-level wrap/unwrap helpers for the [Js_of_ocaml.Promise] binding. + Implemented in [runtime/{js,wasm}/promise.{js,wat}]. Wrapping is + conditional on the value being thenable, so non-thenable values are + passed through unchanged. *) + + external wrap : 'a -> Js.t = "caml_jsoo_promise_wrap" + + external unwrap : Js.t -> 'a = "caml_jsoo_promise_unwrap" +end diff --git a/lib/tests-browser/dune b/lib/tests-browser/dune index 7ed9d919eb..64ba4001a2 100644 --- a/lib/tests-browser/dune +++ b/lib/tests-browser/dune @@ -1,5 +1,5 @@ (executables - (names test_beforeunload test_wheel) + (names test_beforeunload test_wheel test_fetch) (libraries js_of_ocaml) (modes js wasm) (preprocess @@ -12,7 +12,9 @@ test_beforeunload.bc.js test_beforeunload.html test_wheel.bc.js - test_wheel.html)) + test_wheel.html + test_fetch.bc.js + test_fetch.html)) (alias (name default) @@ -21,4 +23,6 @@ test_beforeunload.bc.wasm.js test_beforeunload.html test_wheel.bc.wasm.js - test_wheel.html)) + test_wheel.html + test_fetch.bc.wasm.js + test_fetch.html)) diff --git a/lib/tests-browser/index.html b/lib/tests-browser/index.html index 1e2bf31039..8b6f981dca 100644 --- a/lib/tests-browser/index.html +++ b/lib/tests-browser/index.html @@ -20,6 +20,10 @@

Browser tests

test_wheel (wasm) +
  • + test_fetch + (wasm) +
    • diff --git a/lib/tests-browser/test_fetch.html b/lib/tests-browser/test_fetch.html new file mode 100644 index 0000000000..47baa7e37d --- /dev/null +++ b/lib/tests-browser/test_fetch.html @@ -0,0 +1,91 @@ + + + + + + test_fetch + + + + + +

    Fetch API test

    +

    Exercises the async Promise round-trip through Fetch.fetch, + fetch_with_init, fetch_request, and a rejection path.

    +

    + Mode: + — +

    +
    +
    + + + diff --git a/lib/tests-browser/test_fetch.ml b/lib/tests-browser/test_fetch.ml new file mode 100644 index 0000000000..36dc22d49d --- /dev/null +++ b/lib/tests-browser/test_fetch.ml @@ -0,0 +1,258 @@ +open Js_of_ocaml + +let pass_count = ref 0 + +let fail_count = ref 0 + +let log_row status label detail = + let el = Dom_html.document##getElementById (Js.string "log") in + Js.Opt.iter el (fun el -> + let row = Dom_html.document##createElement (Js.string "div") in + row##.className := Js.string ("row " ^ status); + let mark = Dom_html.document##createElement (Js.string "span") in + mark##.className := Js.string ("mark " ^ status); + mark##.textContent := + Js.some + (Js.string + (if String.equal status "pass" then "\xe2\x9c\x93" else "\xe2\x9c\x97")); + let txt = Dom_html.document##createElement (Js.string "span") in + txt##.className := Js.string "label"; + txt##.textContent := Js.some (Js.string label); + let det = Dom_html.document##createElement (Js.string "span") in + det##.className := Js.string "detail"; + det##.textContent := Js.some (Js.string detail); + Dom.appendChild row mark; + Dom.appendChild row txt; + Dom.appendChild row det; + Dom.appendChild el row) + +let check label cond detail = + if cond + then ( + incr pass_count; + log_row "pass" label detail) + else ( + incr fail_count; + log_row "fail" label detail) + +let summarize () = + let el = Dom_html.document##getElementById (Js.string "summary") in + Js.Opt.iter el (fun el -> + let status = if !fail_count = 0 then "pass" else "fail" in + el##.className := Js.string ("summary " ^ status); + el##.textContent := + Js.some + (Js.string (Printf.sprintf "%d passed, %d failed" !pass_count !fail_count))) + +let ( >>= ) p f = Promise.then_ f p + +let return = Promise.resolve + +let stringify any = Js.to_string (Js.Unsafe.fun_call Js.Unsafe.global##._String [| any |]) + +(* Wrap any value in a [Response] so we can exercise [body.*] methods. *) +let response_of_string s : Fetch.response Js.t = + new%js Fetch.response (Js.Unsafe.inject (Js.string s)) + +let starts_with s ~prefix = + String.length s >= String.length prefix + && String.sub s 0 (String.length prefix) = prefix + +let test_supported_and_self_fetch self_url = + check "Fetch.is_supported ()" (Fetch.is_supported ()) "fetch global available"; + Fetch.fetch self_url + >>= fun resp -> + check + "fetch self -> 200 OK" + (resp##.status = 200 && Js.to_bool resp##.ok) + (Printf.sprintf "status=%d ok=%b" resp##.status (Js.to_bool resp##.ok)); + let ct = + Js.Opt.case + (resp##.headers##get (Js.string "content-type")) + (fun () -> "") + Js.to_string + in + check + "response content-type is text/html" + (starts_with ct ~prefix:"text/html") + (Printf.sprintf "content-type=%s" ct); + check "response.url is set" (Js.to_string resp##.url <> "") (Js.to_string resp##.url); + check + "response._type is basic for same-origin" + (Js.to_string resp##._type = "basic") + (Js.to_string resp##._type); + check + "response.redirected is false" + (not (Js.to_bool resp##.redirected)) + (string_of_bool (Js.to_bool resp##.redirected)); + check + "bodyUsed false before read" + (not (Js.to_bool resp##.bodyUsed)) + (string_of_bool (Js.to_bool resp##.bodyUsed)); + resp##text + >>= fun body -> + let n = String.length (Js.to_string body) in + check "response.text resolves with body" (n > 0) (Printf.sprintf "body length=%d" n); + check + "bodyUsed true after read" + (Js.to_bool resp##.bodyUsed) + (string_of_bool (Js.to_bool resp##.bodyUsed)); + return () + +let test_fetch_with_init self_url = + let init = Fetch.empty_request_init () in + init##.headers := Fetch.headers_of_list [ "x-trace", "browser-test" ]; + Fetch.fetch_with_init self_url init + >>= fun resp -> + check + "fetch_with_init -> 200" + (resp##.status = 200) + (Printf.sprintf "status=%d" resp##.status); + return () + +let test_fetch_request self_url = + let init = Fetch.empty_request_init () in + init##._method := Js.string "GET"; + let req = new%js Fetch.request_with_init self_url init in + check + "Request.url round-trips" + (Js.to_string req##.url = Js.to_string self_url) + (Js.to_string req##.url); + check + "Request.method round-trips" + (Js.to_string req##._method = "GET") + (Js.to_string req##._method); + let cloned = req##clone in + check + "Request.clone is a distinct object with same URL" + (req != cloned && Js.to_string cloned##.url = Js.to_string self_url) + (Js.to_string cloned##.url); + Fetch.fetch_request req + >>= fun resp -> + check + "fetch_request -> 200" + (resp##.status = 200) + (Printf.sprintf "status=%d" resp##.status); + return () + +let test_text () = + let resp = response_of_string "hello world" in + resp##text + >>= fun s -> + check + "Response#text resolves with the body" + (Js.to_string s = "hello world") + (Js.to_string s); + return () + +let test_json () = + let resp = response_of_string {|{"a":1,"b":"two"}|} in + resp##json + >>= fun any -> + let obj : < a : int Js.readonly_prop ; b : Js.js_string Js.t Js.readonly_prop > Js.t = + Js.Unsafe.coerce any + in + check + "Response#json parses JSON" + (obj##.a = 1 && Js.to_string obj##.b = "two") + (Printf.sprintf "{a=%d; b=%s}" obj##.a (Js.to_string obj##.b)); + return () + +let test_array_buffer () = + let resp = response_of_string "abc" in + resp##arrayBuffer + >>= fun buf -> + let n = buf##.byteLength in + check + "Response#arrayBuffer byteLength matches" + (n = 3) + (Printf.sprintf "byteLength=%d" n); + return () + +let test_blob () = + let resp = response_of_string "abcdef" in + resp##blob + >>= fun blob -> + let size : int = (Js.Unsafe.coerce blob)##.size in + check "Response#blob.size matches" (size = 6) (Printf.sprintf "size=%d" size); + return () + +let test_clone_double_read () = + let resp = response_of_string "twice" in + let twin = resp##clone in + resp##text + >>= fun a -> + twin##text + >>= fun b -> + check + "Response#clone allows reading body twice" + (Js.to_string a = "twice" && Js.to_string b = "twice") + (Printf.sprintf "orig=%s clone=%s" (Js.to_string a) (Js.to_string b)); + return () + +let test_rejection_invalid_host () = + let bogus = Js.string "http://nonexistent.invalid./" in + Promise.catch + (fun e -> + let reason = stringify (Promise.error_to_any e) in + check + "fetch invalid host rejects with TypeError" + (starts_with reason ~prefix:"TypeError") + reason; + return ()) + (Fetch.fetch bogus + >>= fun resp -> + check + "fetch invalid host rejects with TypeError" + false + (Printf.sprintf "unexpectedly resolved status=%d" resp##.status); + return ()) + +let test_abort_signal self_url = + let controller = new%js Abort.controller in + let init = Fetch.empty_request_init () in + init##.signal := controller##.signal; + let p = Fetch.fetch_with_init self_url init in + controller##abort; + check + "AbortSignal.aborted true after controller.abort" + (Js.to_bool controller##.signal##.aborted) + ""; + Promise.catch + (fun e -> + let reason = stringify (Promise.error_to_any e) in + check + "aborted fetch rejects" + (starts_with reason ~prefix:"AbortError" + || starts_with reason ~prefix:"DOMException" + || starts_with reason ~prefix:"Error") + reason; + return ()) + (p + >>= fun resp -> + check + "aborted fetch rejects" + false + (Printf.sprintf "unexpectedly resolved status=%d" resp##.status); + return ()) + +let run () = + let self_url = Dom_html.window##.location##.href in + let _ : unit Promise.t = + test_supported_and_self_fetch self_url + >>= (fun () -> test_fetch_with_init self_url) + >>= (fun () -> test_fetch_request self_url) + >>= test_text + >>= test_json + >>= test_array_buffer + >>= test_blob + >>= test_clone_double_read + >>= test_rejection_invalid_host + >>= (fun () -> test_abort_signal self_url) + >>= fun () -> + summarize (); + return () + in + () + +let () = run () diff --git a/lib/tests/dune.inc b/lib/tests/dune.inc index 9f3324c463..6d9c29ecb3 100644 --- a/lib/tests/dune.inc +++ b/lib/tests/dune.inc @@ -35,6 +35,16 @@ (preprocess (pps ppx_js_internal ppx_expect))) +(library + ;; lib/tests/test_fetch.ml + (name test_fetch_75) + (enabled_if (<> %{profile} quickjs)) + (modules test_fetch) + (libraries js_of_ocaml unix) + (inline_tests (modes js wasm)) + (preprocess + (pps ppx_js_internal ppx_expect))) + (library ;; lib/tests/test_fun_call.ml (name test_fun_call_75) @@ -99,6 +109,15 @@ (preprocess (pps ppx_js_internal ppx_expect))) +(library + ;; lib/tests/test_promise.ml + (name test_promise_75) + (modules test_promise) + (libraries js_of_ocaml unix) + (inline_tests (modes js wasm)) + (preprocess + (pps ppx_js_internal ppx_expect))) + (library ;; lib/tests/test_regexp.ml (name test_regexp_75) diff --git a/lib/tests/gen-rules/gen.ml b/lib/tests/gen-rules/gen.ml index 2899edb21e..b07cdb5ab7 100644 --- a/lib/tests/gen-rules/gen.ml +++ b/lib/tests/gen-rules/gen.ml @@ -50,11 +50,13 @@ let prefix : string = type enabled_if = | GE5 | No_effects + | Not_quickjs | Any let enabled_if = function | "test_sys" -> GE5 | "test_fun_call" -> No_effects + | "test_fetch" -> Not_quickjs | _ -> Any let run_wasm = function @@ -87,7 +89,8 @@ let () = (match enabled_if basename with | Any -> "" | GE5 -> "\n (enabled_if (>= %{ocaml_version} 5))" - | No_effects -> "\n (enabled_if (<> %{profile} with-effects))") + | No_effects -> "\n (enabled_if (<> %{profile} with-effects))" + | Not_quickjs -> "\n (enabled_if (<> %{profile} quickjs))") basename (match run_wasm basename with | true -> "js wasm" diff --git a/lib/tests/test_fetch.ml b/lib/tests/test_fetch.ml new file mode 100644 index 0000000000..f0d705ca16 --- /dev/null +++ b/lib/tests/test_fetch.ml @@ -0,0 +1,236 @@ +(* Js_of_ocaml + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Js_of_ocaml + +let is_promise any = + Js.instanceof + (Js.Unsafe.coerce any : _ Js.t) + (Js.Unsafe.global##._Promise : _ Js.constr) + +let get_or_none o = Js.Opt.case o (fun () -> "") Js.to_string + +let%expect_test "is_supported" = + print_endline (if Fetch.is_supported () then "PASSED" else "FAILED"); + [%expect {| PASSED |}] + +(* {1 Headers} *) + +let%expect_test "headers constructor (no arg) starts empty" = + let h = new%js Fetch.headers in + print_endline (string_of_bool (Js.to_bool (h##has (Js.string "x")))); + h##append (Js.string "x") (Js.string "1"); + print_endline (get_or_none (h##get (Js.string "x"))); + [%expect {| + false + 1 + |}] + +let%expect_test "headers_of_list round-trips pairs" = + let h = Fetch.headers_of_list [ "content-type", "text/plain"; "x-trace", "abc" ] in + print_endline (get_or_none (h##get (Js.string "content-type"))); + print_endline (get_or_none (h##get (Js.string "x-trace"))); + print_endline (string_of_bool (Js.to_bool (h##has (Js.string "x-missing")))); + [%expect {| + text/plain + abc + false + |}] + +let%expect_test "headers append/set/delete and forEach" = + let h = Fetch.headers_of_list [ "x-a", "1" ] in + h##set (Js.string "x-a") (Js.string "2"); + print_endline (get_or_none (h##get (Js.string "x-a"))); + h##append (Js.string "x-a") (Js.string "3"); + print_endline (get_or_none (h##get (Js.string "x-a"))); + h##delete (Js.string "x-a"); + print_endline (string_of_bool (Js.to_bool (h##has (Js.string "x-a")))); + let h = Fetch.headers_of_list [ "x-a", "1"; "x-b", "2" ] in + let names = ref [] in + h##forEach (Js.wrap_callback (fun _v k _ -> names := Js.to_string k :: !names)); + print_endline (String.concat ", " (List.sort compare !names)); + [%expect {| + 2 + 2, 3 + false + x-a, x-b + |}] + +(* {1 Request} *) + +let%expect_test "request constructor (no init) defaults to GET" = + let req = new%js Fetch.request (Js.string "https://example.invalid/x") in + print_endline (Js.to_string req##.url); + print_endline (Js.to_string req##._method); + [%expect {| + https://example.invalid/x + GET + |}] + +let%expect_test "requestInit fields round-trip through Request" = + let init = Fetch.empty_request_init () in + init##._method := Js.string "POST"; + init##.body := Js.Unsafe.inject (Js.string "hello"); + init##.headers := Fetch.headers_of_list [ "x-trace", "abc" ]; + init##.mode := Js.string "cors"; + init##.credentials := Js.string "include"; + init##.cache := Js.string "no-store"; + init##.redirect := Js.string "manual"; + init##.referrer := Js.string ""; + init##.referrerPolicy := Js.string "no-referrer"; + init##.integrity := Js.string ""; + init##.keepalive := Js._true; + let controller = new%js Abort.controller in + init##.signal := controller##.signal; + let req = new%js Fetch.request_with_init (Js.string "https://example.invalid/x") init in + print_endline (Js.to_string req##._method); + print_endline (Js.to_string req##.mode); + print_endline (Js.to_string req##.credentials); + print_endline (Js.to_string req##.cache); + print_endline (Js.to_string req##.redirect); + print_endline (Js.to_string req##.referrer); + print_endline (Js.to_string req##.referrerPolicy); + print_endline (string_of_bool (Js.to_bool req##.keepalive)); + print_endline (get_or_none (req##.headers##get (Js.string "x-trace"))); + print_endline (string_of_bool (Js.to_bool req##.signal##.aborted)); + [%expect + {| + POST + cors + include + no-store + manual + + no-referrer + true + abc + false + |}] + +let%expect_test "request other readonly fields are accessible" = + let req = new%js Fetch.request (Js.string "https://example.invalid/x") in + (* [destination] is the empty string for a Request not driven by a + resource fetch (e.g. a non-script-initiated subresource). *) + print_endline ("destination=" ^ Js.to_string req##.destination); + print_endline ("integrity=" ^ Js.to_string req##.integrity); + print_endline ("bodyUsed=" ^ string_of_bool (Js.to_bool req##.bodyUsed)); + print_endline + ("signal is AbortSignal: " + ^ string_of_bool + (Js.instanceof req##.signal (Js.Unsafe.global##._AbortSignal : _ Js.constr))); + [%expect + {| + destination= + integrity= + bodyUsed=false + signal is AbortSignal: true + |}] + +let%expect_test "request.clone returns a distinct Request" = + let req = new%js Fetch.request (Js.string "https://example.invalid/x") in + let cloned = req##clone in + print_endline (Js.to_string cloned##.url); + print_endline (string_of_bool (req != cloned)); + [%expect {| + https://example.invalid/x + true + |}] + +(* {1 Response} *) + +let%expect_test "response constructor exposes defaults" = + let resp = new%js Fetch.response (Js.Unsafe.inject (Js.string "hello")) in + print_endline ("status=" ^ string_of_int resp##.status); + print_endline ("ok=" ^ string_of_bool (Js.to_bool resp##.ok)); + print_endline ("statusText=" ^ Js.to_string resp##.statusText); + print_endline ("type=" ^ Js.to_string resp##._type); + print_endline ("redirected=" ^ string_of_bool (Js.to_bool resp##.redirected)); + print_endline ("url=" ^ Js.to_string resp##.url); + print_endline ("bodyUsed=" ^ string_of_bool (Js.to_bool resp##.bodyUsed)); + [%expect + {| + status=200 + ok=true + statusText= + type=default + redirected=false + url= + bodyUsed=false + |}] + +let%expect_test "response_with_init applies status/statusText/headers" = + let init = Fetch.empty_response_init () in + init##.status := 201; + init##.statusText := Js.string "Created"; + init##.headers := Fetch.headers_of_list [ "x-from-init", "v" ]; + let resp = new%js Fetch.response_with_init (Js.Unsafe.inject (Js.string "hi")) init in + print_endline ("status=" ^ string_of_int resp##.status); + print_endline ("ok=" ^ string_of_bool (Js.to_bool resp##.ok)); + print_endline ("statusText=" ^ Js.to_string resp##.statusText); + print_endline + ("x-from-init=" ^ get_or_none (resp##.headers##get (Js.string "x-from-init"))); + [%expect {| + status=201 + ok=true + statusText=Created + x-from-init=v + |}] + +let%expect_test "response status outside 2xx flips ok" = + let init = Fetch.empty_response_init () in + init##.status := 404; + let resp = new%js Fetch.response_with_init (Js.Unsafe.inject (Js.string "")) init in + print_endline (string_of_int resp##.status); + print_endline (string_of_bool (Js.to_bool resp##.ok)); + [%expect {| + 404 + false + |}] + +let%expect_test "response.clone returns a distinct Response" = + let resp = new%js Fetch.response (Js.Unsafe.inject (Js.string "hi")) in + let cloned = resp##clone in + print_endline (string_of_int cloned##.status); + print_endline (string_of_bool (resp != cloned)); + [%expect {| + 200 + true + |}] + +(* {1 Body methods (sync shape — async behavior covered in tests-browser)} *) + +let%expect_test "all body methods return Promise instances" = + let resp = new%js Fetch.response (Js.Unsafe.inject (Js.string "hello")) in + print_endline (string_of_bool (is_promise (Promise.to_any resp##text))); + let resp = new%js Fetch.response (Js.Unsafe.inject (Js.string "hello")) in + print_endline (string_of_bool (is_promise (Promise.to_any resp##arrayBuffer))); + let resp = new%js Fetch.response (Js.Unsafe.inject (Js.string "hello")) in + print_endline (string_of_bool (is_promise (Promise.to_any resp##blob))); + let resp = new%js Fetch.response (Js.Unsafe.inject (Js.string "null")) in + print_endline (string_of_bool (is_promise (Promise.to_any resp##json))); + [%expect {| + true + true + true + true + |}] + +(* [formData] is not universally implemented on synthetic Responses, so + we only assert that the binding exists and returns *something* (which + will be a [Promise] in all conforming environments). *) +let%expect_test "body.formData is callable" = + let resp = new%js Fetch.response (Js.Unsafe.inject (Js.string "")) in + let p = Promise.to_any resp##formData in + print_endline (string_of_bool (is_promise p)); + [%expect {| true |}] diff --git a/lib/tests/test_promise.ml b/lib/tests/test_promise.ml new file mode 100644 index 0000000000..ddcbdfc1e3 --- /dev/null +++ b/lib/tests/test_promise.ml @@ -0,0 +1,68 @@ +(* Js_of_ocaml + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + *) + +open Js_of_ocaml + +let%expect_test "is_supported" = + print_endline (if Promise.is_supported () then "PASSED" else "FAILED"); + [%expect {| PASSED |}] + +let%expect_test "to_any returns a Promise instance" = + let p = Promise.resolve 42 in + let any = Promise.to_any p in + let is_promise = + Js.instanceof + (Js.Unsafe.coerce any : _ Js.t) + (Js.Unsafe.global##._Promise : _ Js.constr) + in + print_endline (if is_promise then "PASSED" else "FAILED"); + [%expect {| PASSED |}] + +let%expect_test "make invokes the body synchronously" = + let called = ref false in + let _p = Promise.make (fun ~resolve:_ ~reject:_ -> called := true) in + print_endline (if !called then "PASSED" else "FAILED"); + [%expect {| PASSED |}] + +let%expect_test "reject is a Promise" = + let p : unit Promise.t = + Promise.reject (Promise.error_of_any (Js.Unsafe.inject (Js.string "boom"))) + in + let any = Promise.to_any p in + let is_promise = + Js.instanceof + (Js.Unsafe.coerce any : _ Js.t) + (Js.Unsafe.global##._Promise : _ Js.constr) + in + (* Suppress the unhandled-rejection warning by attaching a noop catch. *) + let _ = Promise.catch (fun _ -> Promise.resolve ()) p in + print_endline (if is_promise then "PASSED" else "FAILED"); + [%expect {| PASSED |}] + +let%expect_test "all/race build Promises without blowing up" = + let p1 = Promise.resolve 1 in + let p2 = Promise.resolve 2 in + let pa = Promise.all [ p1; p2 ] in + let pr = Promise.race [ p1; p2 ] in + let is_promise any = + Js.instanceof + (Js.Unsafe.coerce any : _ Js.t) + (Js.Unsafe.global##._Promise : _ Js.constr) + in + print_endline (if is_promise (Promise.to_any pa) then "all OK" else "all KO"); + print_endline (if is_promise (Promise.to_any pr) then "race OK" else "race KO"); + [%expect {| + all OK + race OK + |}] diff --git a/runtime/js/dune b/runtime/js/dune index e534902c0a..9a8a127d07 100644 --- a/runtime/js/dune +++ b/runtime/js/dune @@ -23,6 +23,7 @@ mlBytes.js nat.js parsing.js + promise.js stdlib.js toplevel.js unix.js diff --git a/runtime/js/promise.js b/runtime/js/promise.js new file mode 100644 index 0000000000..b5534fe1d4 --- /dev/null +++ b/runtime/js/promise.js @@ -0,0 +1,45 @@ +// Js_of_ocaml runtime support +// http://www.ocsigen.org/js_of_ocaml/ +// +// This program is free software; you can redistribute it and/or modify +// it under the terms of the GNU Lesser General Public License as published by +// the Free Software Foundation, with linking exception; +// either version 2.1 of the License, or (at your option) any later version. +// +// This program is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU Lesser General Public License for more details. +// +// You should have received a copy of the GNU Lesser General Public License +// along with this program; if not, write to the Free Software +// Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +// Helpers for the [Js_of_ocaml.Promise] binding. +// +// The JS Promise constructor automatically follows any thenable returned +// from a handler or passed to [Promise.resolve]. To preserve type safety +// for ['a Promise.t Promise.t] we wrap thenable values in a dedicated +// container before resolving and unwrap them on the way back. Non-thenable +// values pass through untouched, which avoids per-call allocation in the +// common case and lets foreign promises (handed in via [Promise.of_any]) +// flow through transparently. + +//Provides: caml_jsoo_promise_wrapper +function caml_jsoo_promise_wrapper(x) { + this.wrapped = x; +} + +//Provides: caml_jsoo_promise_wrap +//Requires: caml_jsoo_promise_wrapper +function caml_jsoo_promise_wrap(x) { + return x != null && typeof x.then === "function" + ? new caml_jsoo_promise_wrapper(x) + : x; +} + +//Provides: caml_jsoo_promise_unwrap +//Requires: caml_jsoo_promise_wrapper +function caml_jsoo_promise_unwrap(x) { + return x instanceof caml_jsoo_promise_wrapper ? x.wrapped : x; +} diff --git a/runtime/wasm/promise.wat b/runtime/wasm/promise.wat new file mode 100644 index 0000000000..b2a051494a --- /dev/null +++ b/runtime/wasm/promise.wat @@ -0,0 +1,37 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU Lesser General Public License as published by +;; the Free Software Foundation, with linking exception; +;; either version 2.1 of the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +;; Helpers for the [Js_of_ocaml.Promise] binding. Implementations live in +;; runtime/js/promise.js — the Wasm side just bridges between OCaml's +;; (ref eq) representation and the JS [anyref] world. + +(module + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "js" "caml_jsoo_promise_wrap" + (func $caml_jsoo_promise_wrap_js (param anyref) (result anyref))) + (import "js" "caml_jsoo_promise_unwrap" + (func $caml_jsoo_promise_unwrap_js (param anyref) (result anyref))) + + (func (export "caml_jsoo_promise_wrap") (param (ref eq)) (result (ref eq)) + (return_call $wrap + (call $caml_jsoo_promise_wrap_js (call $unwrap (local.get 0))))) + + (func (export "caml_jsoo_promise_unwrap") (param (ref eq)) (result (ref eq)) + (return_call $wrap + (call $caml_jsoo_promise_unwrap_js (call $unwrap (local.get 0))))) +)