HACK: vendor eio_windows

eio_windows.opam

@@ -0,0 +1,34 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Eio implementation for Windows"
+description: "An Eio implementation using OCaml's Unix.select"
+maintainer: ["[email protected]"]
+authors: ["Anil Madhavapeddy" "Thomas Leonard"]
+license: "ISC"
+homepage: "https://github.com/ocaml-multicore/eio"
+doc: "https://ocaml-multicore.github.io/eio/"
+bug-reports: "https://github.com/ocaml-multicore/eio/issues"
+depends: [
+  "dune" {>= "3.9"}
+  "eio" {= version}
+  "fmt" {>= "0.8.9"}
+  "kcas" {>= "0.3.0" & with-test}
+  "alcotest" {>= "1.7.0" & with-test}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://github.com/ocaml-multicore/eio.git"
+#available: [os = "win32"]

lib_eio_windows/domain_mgr.ml

@@ -0,0 +1,120 @@
+(*
+ * Copyright (C) 2023 Thomas Leonard
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Eio.Std
+
+[@@@alert "-unstable"]
+
+module Fd = Eio_unix.Fd
+
+let socketpair k ~sw ~domain ~ty ~protocol wrap_a wrap_b =
+  let open Effect.Deep in
+  match
+    let unix_a, unix_b = Unix.socketpair ~cloexec:true domain ty protocol in
+    let a = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_a in
+    let b = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_b in
+    Unix.set_nonblock unix_a;
+    Unix.set_nonblock unix_b;
+    (wrap_a a, wrap_b b)
+  with
+  | r -> continue k r
+  | exception Unix.Unix_error (code, name, arg) ->
+    discontinue k (Err.wrap code name arg)
+
+(* Run an event loop in the current domain, using [fn x] as the root fiber. *)
+let run_event_loop fn x =
+  Sched.with_sched @@ fun sched ->
+  let open Effect.Deep in
+  let extra_effects : _ effect_handler = {
+    effc = fun (type a) (e : a Effect.t) : ((a, Sched.exit) continuation -> Sched.exit) option ->
+      match e with
+      | Eio_unix.Private.Get_monotonic_clock -> Some (fun k -> continue k Time.mono_clock)
+      | Eio_unix.Net.Import_socket_stream (sw, close_unix, unix_fd) -> Some (fun k ->
+          let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in
+          (* TODO: On Windows, if the FD from Unix.pipe () is passed this will fail *)
+          (try Unix.set_nonblock unix_fd with Unix.Unix_error (Unix.ENOTSOCK, _, _) -> ());
+          continue k (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket)
+        )
+      | Eio_unix.Net.Import_socket_listening (sw, close_unix, unix_fd) -> Some (fun k ->
+          let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in
+          Unix.set_nonblock unix_fd;
+          continue k (Net.listening_socket ~hook:Switch.null_hook fd)
+        )
+      | Eio_unix.Net.Import_socket_datagram (sw, close_unix, unix_fd) -> Some (fun k ->
+          let fd = Fd.of_unix ~sw ~blocking:false ~close_unix unix_fd in
+          Unix.set_nonblock unix_fd;
+          continue k (Net.datagram_socket fd)
+        )
+      | Eio_unix.Net.Socketpair_stream (sw, domain, protocol) -> Some (fun k ->
+          let wrap fd = (Flow.of_fd fd :> _ Eio_unix.Net.stream_socket) in
+          socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_STREAM wrap wrap
+        )
+      | Eio_unix.Net.Socketpair_datagram (sw, domain, protocol) -> Some (fun k ->
+          let wrap fd = Net.datagram_socket fd in
+          socketpair k ~sw ~domain ~protocol ~ty:Unix.SOCK_DGRAM wrap wrap
+        )
+      | Eio_unix.Private.Pipe sw -> Some (fun k ->
+          match
+            let r, w = Low_level.pipe ~sw in
+            let source = Flow.of_fd r in
+            let sink = Flow.of_fd w in
+            (source, sink)
+          with
+          | r -> continue k r
+          | exception Unix.Unix_error (code, name, arg) ->
+            discontinue k (Err.wrap code name arg)
+        )
+      | _ -> None
+  }
+  in
+  Sched.run ~extra_effects sched fn x
+
+let wrap_backtrace fn x =
+  match fn x with
+  | x -> Ok x
+  | exception ex ->
+    let bt = Printexc.get_raw_backtrace () in
+    Error (ex, bt)
+
+let unwrap_backtrace = function
+  | Ok x -> x
+  | Error (ex, bt) -> Printexc.raise_with_backtrace ex bt
+
+module Impl = struct
+  type t = unit
+
+  let run_raw () fn =
+    let domain = ref None in
+    Eio.Private.Suspend.enter "run-domain" (fun _ctx enqueue ->
+        domain := Some (Domain.spawn (fun () -> Fun.protect (wrap_backtrace fn) ~finally:(fun () -> enqueue (Ok ()))))
+      );
+    unwrap_backtrace (Domain.join (Option.get !domain))
+
+  let run () fn =
+    let domain = ref None in
+    Eio.Private.Suspend.enter "run-domain" (fun ctx enqueue ->
+        let cancelled, set_cancelled = Promise.create () in
+        Eio.Private.Fiber_context.set_cancel_fn ctx (Promise.resolve set_cancelled);
+        domain := Some (Domain.spawn (fun () ->
+            Fun.protect (run_event_loop (wrap_backtrace (fun () -> fn ~cancelled)))
+              ~finally:(fun () -> enqueue (Ok ()))))
+      );
+    unwrap_backtrace (Domain.join (Option.get !domain))
+end
+
+let v =
+  let handler = Eio.Domain_manager.Pi.mgr (module Impl) in
+  Eio.Resource.T ((), handler)

lib_eio_windows/dune

@@ -0,0 +1,16 @@
+(library
+ (name eio_windows)
+ (public_name eio_windows)
+ (library_flags :standard -cclib -lbcrypt -cclib -lntdll)
+ (enabled_if (= %{os_type} "Win32"))
+ (foreign_stubs
+  (language c)
+  (include_dirs ../lib_eio/unix/include)
+  (names eio_windows_stubs eio_windows_cstruct_stubs))
+ (c_library_flags :standard -lbcrypt -lntdll)
+ (libraries eio eio.unix eio.utils fmt))
+
+(rule
+ (targets config.ml)
+ (enabled_if (= %{os_type} "Win32"))
+ (action (run ./include/discover.exe)))

lib_eio_windows/eio_windows.ml

@@ -0,0 +1,39 @@
+(*
+ * Copyright (C) 2023 Thomas Leonard
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+module Low_level = Low_level
+
+type stdenv = Eio_unix.Stdenv.base
+
+let run main =
+  let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> _ Eio_unix.source) in
+  let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> _ Eio_unix.sink) in
+  let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> _ Eio_unix.sink) in
+  Domain_mgr.run_event_loop main @@ object (_ : stdenv)
+    method stdin = stdin
+    method stdout = stdout
+    method stderr = stderr
+    method debug = Eio.Private.Debug.v
+    method clock = Time.clock
+    method mono_clock = Time.mono_clock
+    method net = Net.v
+    method domain_mgr = Domain_mgr.v
+    method cwd = ((Fs.cwd, "") :> Eio.Fs.dir_ty Eio.Path.t)
+    method fs = ((Fs.fs, "") :> Eio.Fs.dir_ty Eio.Path.t)
+    method process_mgr = failwith "process operations not supported on Windows yet"
+    method secure_random = Flow.secure_random
+    method backend_id = "windows"
+  end

lib_eio_windows/eio_windows.mli

@@ -0,0 +1,12 @@
+(** Fallback Eio backend for Windows using OCaml's [Unix.select]. *)
+
+type stdenv = Eio_unix.Stdenv.base
+(** An extended version of {!Eio.Stdenv.base} with some extra features available on Windows. *)
+
+val run : (stdenv -> 'a) -> 'a
+(** [run main] runs an event loop and calls [main stdenv] inside it.
+
+    For portable code, you should use {!Eio_main.run} instead, which will call this for you if appropriate. *)
+
+module Low_level = Low_level
+(** Low-level API. *)

lib_eio_windows/eio_windows_cstruct_stubs.c

@@ -0,0 +1,149 @@
+/* From mirage/ocaml-cstruct
+Copyright (c) 2012 Anil Madhavapeddy <[email protected]>
+Copyright (c) 2012 Pierre Chambart
+Copyright (c) Christiano F. Haesbaert <[email protected]>
+Copyright (c) Citrix Inc
+Copyright (c) David Sheets <[email protected]>
+Copyright (c) Drup <[email protected]>
+Copyright (c) Hannes Mehnert <[email protected]>
+Copyright (c) Jeremy Yallop <[email protected]>
+Copyright (c) Mindy Preston <[email protected]>
+Copyright (c) Nicolas Ojeda Bar <[email protected]>
+Copyright (c) Richard Mortier <[email protected]>
+Copyright (c) Rudi Grinberg <[email protected]>
+Copyright (c) Thomas Gazagnaire <[email protected]>
+Copyright (c) Thomas Leonard <[email protected]>
+Copyright (c) Vincent Bernardoff <[email protected]>
+Copyright (c) pqwy <[email protected]>
+
+Permission to use, copy, modify, and distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. */
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/custom.h>
+#include <caml/callback.h>
+#include <caml/alloc.h>
+#include <caml/unixsupport.h>
+#include <caml/bigarray.h>
+#include <caml/threads.h>
+#include <caml/fail.h>
+
+#include <stdio.h>
+#include <errno.h>
+
+CAMLprim value eio_windows_cstruct_read(value val_fd, value val_c)
+{
+  CAMLparam2(val_fd, val_c);
+  CAMLlocal3(val_buf, val_ofs, val_len);
+  uint8_t *buf;
+  size_t len;
+  ssize_t n = 0;
+  int win32err = 0;
+  SOCKET s;
+  HANDLE h;
+  DWORD numread;
+  int ok;
+
+  val_buf = Field(val_c, 0);
+  val_ofs = Field(val_c, 1);
+  val_len = Field(val_c, 2);
+
+  buf = (uint8_t *)Caml_ba_data_val(val_buf) + Long_val(val_ofs);
+  len = (size_t)Long_val(val_len);
+
+  switch (Descr_kind_val(val_fd))
+  {
+  case KIND_SOCKET:
+    s = Socket_val(val_fd);
+
+    caml_release_runtime_system();
+    n = recv(s, buf, len, 0);
+    win32err = WSAGetLastError();
+    caml_acquire_runtime_system();
+
+    if (n == SOCKET_ERROR)
+    {
+      win32_maperr(win32err);
+      uerror("stub_cstruct_read", Nothing);
+    }
+    break;
+  case KIND_HANDLE:
+    h = Handle_val(val_fd);
+    caml_release_runtime_system();
+    ok = ReadFile(h, buf, len, &numread, NULL);
+    win32err = GetLastError();
+    n = numread;
+    caml_acquire_runtime_system();
+
+    if (!ok)
+    {
+      win32_maperr(win32err);
+      uerror("stub_cstruct_read", Nothing);
+    }
+    break;
+  default:
+    caml_failwith("unknown Descr_kind_val");
+  }
+
+  CAMLreturn(Val_int(n));
+}
+
+CAMLprim value eio_windows_cstruct_write(value val_fd, value val_c)
+{
+  CAMLparam2(val_fd, val_c);
+  CAMLlocal3(val_buf, val_ofs, val_len);
+  val_buf = Field(val_c, 0);
+  val_ofs = Field(val_c, 1);
+  val_len = Field(val_c, 2);
+  void *buf = (char *)Caml_ba_data_val(val_buf) + Long_val(val_ofs);
+  size_t len = Long_val(val_len);
+  ssize_t n = 0;
+
+  int win32err = 0;
+  switch (Descr_kind_val(val_fd))
+  {
+  case KIND_SOCKET:
+    SOCKET s = Socket_val(val_fd);
+
+    caml_release_runtime_system();
+    n = send(s, buf, len, 0);
+    win32err = WSAGetLastError();
+    caml_acquire_runtime_system();
+
+    if (n == SOCKET_ERROR)
+    {
+      win32_maperr(win32err);
+      unix_error(errno, "stub_cstruct_write", Nothing);
+    }
+    break;
+  case KIND_HANDLE:
+    HANDLE h = Handle_val(val_fd);
+    DWORD numwritten;
+    caml_release_runtime_system();
+    int ok = WriteFile(h, buf, len, &numwritten, NULL);
+    win32err = GetLastError();
+
+    n = numwritten;
+    caml_acquire_runtime_system();
+
+    if (!ok)
+    {
+      win32_maperr(win32err);
+      uerror("stub_cstruct_write", Nothing);
+    }
+    break;
+  default:
+    caml_failwith("unknown Descr_kind_val");
+  }
+
+  CAMLreturn(Val_int(n));
+}