Merge pull request #497 from patricoferris/posix-windows

Posix-based windows implementation

Author: talex5

.github/workflows/main.yml

@@ -32,7 +32,31 @@ jobs:
       - run: opam --cli=2.1 pin -yn --with-version=dev .
       - run: opam install ${{ matrix.local-packages }} --deps-only --with-test
       - run: opam install ${{ matrix.local-packages }} --with-test
+  windows:
+    runs-on: windows-latest
 
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v3
+
+      - name: Set-up OCaml
+        uses: ocaml/setup-ocaml@v2
+        with:
+          opam-pin: false
+          opam-depext: false
+          ocaml-compiler: ocaml.5.0.0,ocaml-option-mingw
+          opam-repositories: |
+            dra27: https://github.com/dra27/opam-repository.git#windows-5.0
+            duniverse: git+https://github.com/dune-universe/opam-overlays
+            normal: https://github.com/ocaml/opam-repository.git
+            default: https://github.com/ocaml-opam/opam-repository-mingw.git#opam2
+      # --with-version=dev is not available, and --with-test also tries running tests for packages (like MDX) which fail...
+      - run: | 
+          opam pin -yn eio.dev .
+          opam pin -yn eio_windows.dev .
+          opam install ocamlfind.1.9.5 kcas alcotest mdx crowbar -y
+          opam install eio eio_windows --deps-only
+      - run: opam exec -- dune runtest
   docker:
     runs-on: ubuntu-latest
     steps:

doc/dune

@@ -1,4 +1,5 @@
 (mdx
   (package eio_main)
   (deps (package eio_main) (env_var "EIO_BACKEND"))
+  (enabled_if (<> %{os_type} "Win32"))
   (files multicore.md))

dune

@@ -2,4 +2,5 @@
   (package eio_main)
   (deps (package eio_main) (env_var "EIO_BACKEND"))
   (preludes doc/prelude.ml)
+  (enabled_if (<> %{os_type} "Win32"))
   (files README.md))

dune-project

@@ -56,10 +56,13 @@
 (package
  (name eio_windows)
  (synopsis "Eio implementation for Windows")
- (description "An Eio implementation using I/O Completion Ports")
+ (description "An Eio implementation using OCaml's Unix.select")
  (allow_empty)  ; Work-around for dune bug #6938
  (depends
-  (eio (= :version))))
+  (eio (= :version))
+  (cstruct-unix (= dev))
+  (kcas (and (>= 0.3.0) :with-test))
+  (alcotest (and (>= 1.4.0) :with-test))))
 (package
  (name eio_main)
  (synopsis "Effect-based direct-style IO mainloop for OCaml")

eio_windows.opam

@@ -1,7 +1,7 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
 synopsis: "Eio implementation for Windows"
-description: "An Eio implementation using I/O Completion Ports"
+description: "An Eio implementation using OCaml's Unix.select"
 maintainer: ["[email protected]"]
 authors: ["Anil Madhavapeddy" "Thomas Leonard"]
 license: "ISC"
@@ -11,6 +11,9 @@ bug-reports: "https://github.com/ocaml-multicore/eio/issues"
 depends: [
   "dune" {>= "3.7"}
   "eio" {= version}
+  "cstruct-unix" {= "dev"}
+  "kcas" {>= "0.3.0" & with-test}
+  "alcotest" {>= "1.4.0" & with-test}
   "odoc" {with-doc}
 ]
 build: [
@@ -28,3 +31,10 @@ build: [
   ]
 ]
 dev-repo: "git+https://github.com/ocaml-multicore/eio.git"
+pin-depends: [
+  # Removes base bytes for crowbar
+  [ "ocplib-endian.dev" "git+https://github.com/Leonidas-from-XIV/ocplib-endian#fda4d5525063c8444020be369c63de23d39c246e" ]
+  # Needed for the cstruct read and writes without copying
+  [ "cstruct.dev" "git+https://github.com/djs55/ocaml-cstruct#471ca03b49b3a372945fcf13c89e0447a8bd3932" ]
+  [ "cstruct-unix.dev" "git+https://github.com/djs55/ocaml-cstruct#471ca03b49b3a372945fcf13c89e0447a8bd3932" ]
+]

eio_windows.opam.template

@@ -0,0 +1,7 @@
+pin-depends: [
+  # Removes base bytes for crowbar
+  [ "ocplib-endian.dev" "git+https://github.com/Leonidas-from-XIV/ocplib-endian#fda4d5525063c8444020be369c63de23d39c246e" ]
+  # Needed for the cstruct read and writes without copying
+  [ "cstruct.dev" "git+https://github.com/djs55/ocaml-cstruct#471ca03b49b3a372945fcf13c89e0447a8bd3932" ]
+  [ "cstruct-unix.dev" "git+https://github.com/djs55/ocaml-cstruct#471ca03b49b3a372945fcf13c89e0447a8bd3932" ]
+]

lib_eio/tests/dune

@@ -1,5 +1,6 @@
 (mdx
   (package eio)
+  (enabled_if (<> %{os_type} "Win32"))
   (deps
     (package eio)
     (file ./dscheck/fake_sched.ml)

lib_eio/unix/fork_action.c

@@ -5,9 +5,11 @@
 #include <errno.h>
 
 #include <caml/mlvalues.h>
+#include <caml/unixsupport.h>
 
 #include "fork_action.h"
 
+#ifndef _WIN32
 void eio_unix_run_fork_actions(int errors, value v_actions) {
   int old_flags = fcntl(errors, F_GETFL, 0);
   fcntl(errors, F_SETFL, old_flags & ~O_NONBLOCK);
@@ -19,6 +21,7 @@ void eio_unix_run_fork_actions(int errors, value v_actions) {
   }
   _exit(1);
 }
+#endif
 
 static void try_write_all(int fd, char *buf) {
   int len = strlen(buf);
@@ -67,13 +70,17 @@ CAMLprim value eio_unix_fork_execve(value v_unit) {
 }
 
 static void action_fchdir(int errors, value v_config) {
+  #ifdef _WIN32
+  eio_unix_fork_error(errors, "action_fchdir", "Unsupported operation on windows");
+  #else
   value v_fd = Field(v_config, 1);
   int r;
   r = fchdir(Int_val(v_fd));
   if (r != 0) {
     eio_unix_fork_error(errors, "fchdir", strerror(errno));
     _exit(1);
   }
+  #endif
 }
 
 CAMLprim value eio_unix_fork_fchdir(value v_unit) {
@@ -95,6 +102,9 @@ CAMLprim value eio_unix_fork_chdir(value v_unit) {
 }
 
 static void set_blocking(int errors, int fd, int blocking) {
+  #ifdef _WIN32
+  eio_unix_fork_error(errors, "set_blocking", "Unsupported operation on windows");
+  #else
   int r = fcntl(fd, F_GETFL, 0);
   if (r != -1) {
     int flags = blocking
@@ -108,9 +118,13 @@ static void set_blocking(int errors, int fd, int blocking) {
     eio_unix_fork_error(errors, "fcntl", strerror(errno));
     _exit(1);
   }
+  #endif
 }
 
 static void set_cloexec(int errors, int fd, int cloexec) {
+  #ifdef _WIN32
+  eio_unix_fork_error(errors, "set_cloexec", "Unsupported operation on windows");
+  #else
   int r = fcntl(fd, F_GETFD, 0);
   if (r != -1) {
     int flags = cloexec
@@ -124,6 +138,7 @@ static void set_cloexec(int errors, int fd, int cloexec) {
     eio_unix_fork_error(errors, "fcntl", strerror(errno));
     _exit(1);
   }
+  #endif
 }
 
 static void action_dups(int errors, value v_config) {

lib_eio/unix/stubs.c

@@ -5,10 +5,15 @@
 #include <caml/unixsupport.h>
 
 CAMLprim value eio_unix_is_blocking(value v_fd) {
+  #ifdef _WIN32
+  // We should not call this function from Windows
+  uerror("Unsupported blocking check on Windows", Nothing);
+  #else
   int fd = Int_val(v_fd);
   int r = fcntl(fd, F_GETFL, 0);
   if (r == -1)
     uerror("fcntl", Nothing);
 
   return Val_bool((r & O_NONBLOCK) == 0);
+  #endif
 }

lib_eio_windows/domain_mgr.ml

@@ -0,0 +1,86 @@
+(*
+ * 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
+
+(* 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.Time.Mono.t))
+      | Eio_unix.Private.Socket_of_fd (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.socket)
+        )
+      | Eio_unix.Private.Socketpair (sw, domain, ty, protocol) -> Some (fun k ->
+          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;
+            (Flow.of_fd a :> Eio_unix.socket), (Flow.of_fd b :> Eio_unix.socket)
+          with
+          | r -> continue k r
+          | exception Unix.Unix_error (code, name, arg) ->
+              discontinue k (Err.wrap code name arg)
+        )
+      | Eio_unix.Private.Pipe sw -> Some (fun k ->
+          match
+            let r, w = Low_level.pipe ~sw in
+            let source = (Flow.of_fd r :> Eio_unix.source) in
+            let sink = (Flow.of_fd w :> Eio_unix.sink) 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 v = object
+  inherit Eio.Domain_manager.t
+
+  method run_raw fn =
+    let domain = ref None in
+    Eio.Private.Suspend.enter (fun _ctx enqueue ->
+        domain := Some (Domain.spawn (fun () -> Fun.protect fn ~finally:(fun () -> enqueue (Ok ()))))
+      );
+    Domain.join (Option.get !domain)
+
+  method run fn =
+    let domain = ref None in
+    Eio.Private.Suspend.enter (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 (fun () -> fn ~cancelled))
+              ~finally:(fun () -> enqueue (Ok ()))))
+      );
+    Domain.join (Option.get !domain)
+end

lib_eio_windows/dune

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

lib_eio_windows/eio_windows.ml

@@ -1,3 +1,49 @@
-(* Can base this on the eio_posix directory structure.
-   See HACKING.md for instructions on creating a new backend. *)
-let run _main = failwith "TODO: Windows support."
+(*
+ * 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 = <
+  stdin  : <Eio.Flow.source; Eio_unix.Resource.t>;
+  stdout : <Eio.Flow.sink; Eio_unix.Resource.t>;
+  stderr : <Eio.Flow.sink; Eio_unix.Resource.t>;
+  net : Eio.Net.t;
+  domain_mgr : Eio.Domain_manager.t;
+  clock : Eio.Time.clock;
+  mono_clock : Eio.Time.Mono.t;
+  fs : Eio.Fs.dir Eio.Path.t;
+  cwd : Eio.Fs.dir Eio.Path.t;
+  secure_random : Eio.Flow.source;
+  debug : Eio.Debug.t;
+>
+
+let run main =
+  let stdin = (Flow.of_fd Eio_unix.Fd.stdin :> <Eio.Flow.source; Eio_unix.Resource.t>) in
+  let stdout = (Flow.of_fd Eio_unix.Fd.stdout :> <Eio.Flow.sink; Eio_unix.Resource.t>) in
+  let stderr = (Flow.of_fd Eio_unix.Fd.stderr :> <Eio.Flow.sink; Eio_unix.Resource.t>) 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 = failwith "file-system operations not supported on Windows yet"
+    method fs = failwith "file-system operations not supported on Windows yet"
+    method secure_random = Flow.secure_random
+  end

lib_eio_windows/eio_windows.mli

@@ -0,0 +1,24 @@
+(** Fallback Eio backend for Windows using OCaml's [Unix.select]. *)
+
+type stdenv = <
+  stdin  : <Eio.Flow.source; Eio_unix.Resource.t>;
+  stdout : <Eio.Flow.sink; Eio_unix.Resource.t>;
+  stderr : <Eio.Flow.sink; Eio_unix.Resource.t>;
+  net : Eio.Net.t;
+  domain_mgr : Eio.Domain_manager.t;
+  clock : Eio.Time.clock;
+  mono_clock : Eio.Time.Mono.t;
+  fs : Eio.Fs.dir Eio.Path.t;
+  cwd : Eio.Fs.dir Eio.Path.t;
+  secure_random : Eio.Flow.source;
+  debug : Eio.Debug.t;
+>
+(** An extended version of {!Eio.Stdenv.t} 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. *)