unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/caqti_miou_unix.ml

@@ -0,0 +1,35 @@
+(* Copyright (C) 2023--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Caqti_platform
+
+module System = System
+module Pool = System.Pool
+module Loader = Caqti_platform_unix.Driver_loader.Make (System) (System_unix)
+
+include Connector.Make (System) (Pool) (Loader)
+
+let connect ?subst ?env ?config ?tweaks_version ~sw uri =
+  connect ?subst ?env ?config ?tweaks_version ~sw ~stdenv:() uri
+
+let with_connection = with_connection ~stdenv:()
+
+let connect_pool
+      ?pool_config ?post_connect ?subst ?env ?config ?tweaks_version ~sw uri =
+  connect_pool
+    ?pool_config ?post_connect ?subst ?env ?config ?tweaks_version
+    ~sw ~stdenv:() uri

unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/caqti_miou_unix.mli

@@ -0,0 +1,33 @@
+(* Copyright (C) 2023--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+(** Establishing connections using miou.unix.
+
+    {b This library considered unstable for now,} and may be revised or replaced
+    as the effect-based libraries evolve. *)
+
+module System = System
+
+module Pool : Caqti_pool_sig.S with type 'a fiber := 'a
+
+include Caqti_connect_sig.S
+  with type 'a fiber := 'a
+   and type ('a, 'e) stream := ('a, 'e) Caqti_miou.Stream.t
+   and type ('a, 'e) pool := ('a, 'e) Pool.t
+   and type connection := Caqti_miou.connection
+   and type 'a with_switch := sw: Caqti_miou.Switch.t -> 'a
+   and type 'a with_stdenv := 'a

unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/dune

@@ -0,0 +1,6 @@
+(library
+ (name caqti_miou_unix)
+ (public_name caqti-miou.unix)
+ (optional)
+ (modules caqti_miou_unix system system_unix)
+ (libraries caqti-miou caqti.platform.unix miou.unix ipaddr.unix))

unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/system.ml

@@ -0,0 +1,197 @@
+(* Copyright (C) 2023--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+let error_msgf fmt = Format.kasprintf (fun msg -> Error (`Msg msg)) fmt
+
+module type FLOW = Caqti_platform.System_sig.SOCKET_OPS with type 'a fiber = 'a
+
+type ocaml = | and system = |
+
+type 'a impl =
+  | OCaml : (module FLOW with type t = 'a) * 'a -> ocaml impl
+  | System : Buffer.t * Miou_unix.file_descr -> system impl
+
+type socket = Socket : 'a impl -> socket [@@unboxed]
+
+type Caqti_error.msg +=
+  | Msg_unix of Unix.error * string * string
+
+let () =
+  let pp ppf = function
+    | Msg_unix (err, f, v) ->
+        Format.fprintf ppf "%s(%s): %s" f v (Unix.error_message err)
+    | _ -> assert false
+  in
+  Caqti_error.define_msg ~pp [%extension_constructor Msg_unix]
+
+external reraise : exn -> 'a = "%reraise"
+
+module System_core = struct
+  include Caqti_miou.System_core
+  type stdenv = unit
+end
+include System_core
+
+module Alarm = struct
+  type t = Miou.Condition.t * Miou.Mutex.t
+
+  let schedule ~sw ~stdenv:_ t fn =
+    let t_now = Mtime_clock.now () in
+    let mutex = Miou.Mutex.create () and condition = Miou.Condition.create () in
+    let delay =
+      if Mtime.is_later t ~than:t_now then 0.0
+      else Mtime.Span.to_float_ns (Mtime.span t t_now) *. 1e-9
+    in
+    Logs.debug (fun m -> m "schedule an alarm");
+    let _ =
+      async ~sw @@ fun () ->
+      Logs.debug (fun m -> m "really schedule an alarm");
+      let sleeper = Miou.async @@ fun () ->
+        Logs.debug (fun m -> m "Sleep %fs" delay);
+        Miou_unix.sleep delay;
+        Logs.debug (fun m -> m "Ring the alarm");
+        `Continue in
+      let canceller =
+        Miou.async @@ fun () ->
+        Miou.Condition.wait condition mutex;
+        `Cancel
+      in
+      match Miou.await_first [ sleeper; canceller ] with
+      | Ok `Continue -> fn ()
+      | Ok `Cancel -> ()
+      | Error _exn -> ()
+    in
+    (condition, mutex)
+
+  let unschedule (condition, mutex) =
+    Miou.Mutex.protect mutex @@ fun () -> Miou.Condition.signal condition
+end
+
+module Stream = Caqti_miou.Stream
+module Pool = Caqti_platform.Pool.Make (System_core) (Alarm)
+
+module Net = struct
+  module Sockaddr = struct
+    type t = Unix.sockaddr
+
+    let unix v = Unix.ADDR_UNIX v
+    let tcp (addr, port) = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr addr, port)
+  end
+
+  let getaddrinfo ~stdenv:() host port =
+    let opts = Unix.[ AI_SOCKTYPE SOCK_STREAM ] in
+    match
+      Unix.getaddrinfo (Domain_name.to_string host) (string_of_int port) opts
+    with
+    | lst -> Ok (List.map (fun ai -> ai.Unix.ai_addr) lst)
+    | exception Not_found -> Ok []
+    | exception Unix.Unix_error (err, f, v) ->
+        error_msgf "%s(%s): %s" f v (Unix.error_message err)
+
+  let convert_io_exception = function
+    | Unix.Unix_error (err, f, v) -> Some (Msg_unix (err, f, v))
+    | _ -> None
+
+  type tcp_flow = Miou_unix.file_descr
+  type tls_flow = ocaml impl
+
+  module Socket = struct
+    type t = socket
+
+    let output_char (Socket impl) chr = match impl with
+      | System (buf, _) -> Buffer.add_char buf chr
+      | OCaml ((module Flow), fd) -> Flow.output_char fd chr
+
+    let output_string (Socket impl) str = match impl with
+      | System (buf, _) -> Buffer.add_string buf str
+      | OCaml ((module Flow), fd) -> Flow.output_string fd str
+
+    let flush (Socket impl) = match impl with
+      | System (buf, fd) ->
+          let str = Buffer.contents buf in
+          Buffer.clear buf;
+          if String.length str > 0 then Miou_unix.write fd str
+      | OCaml ((module Flow), fd) -> Flow.flush fd
+
+    let input_char (Socket impl) = match impl with
+      | System (_, fd) ->
+        let buf = Bytes.make 1 '\000' in
+        let len = Miou_unix.read fd buf in
+        if len = 0 then raise End_of_file else Bytes.get buf 0
+      | OCaml ((module Flow), fd) ->
+        Flow.input_char fd
+
+    let really_input (Socket impl) buf off len =
+      match impl with
+      | System (_, fd) ->
+        let rec go off len =
+          if len > 0 then
+            let len' = Miou_unix.read fd buf ~off ~len in
+            go (off + len') (len - len')
+        in
+        go off len
+      | OCaml ((module Flow), fd) ->
+        Flow.really_input fd buf off len
+
+    let close = function
+      | Socket (System (_, fd)) -> Miou_unix.close fd
+      | Socket (OCaml ((module Flow), fd)) -> Flow.close fd
+  end
+
+  let socket = function
+    | Unix.ADDR_UNIX _ ->
+        let fd = Unix.socket ~cloexec:true Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+        Ok (Miou_unix.of_file_descr ~non_blocking:true fd)
+    | Unix.ADDR_INET (inet_addr, _) when Unix.is_inet6_addr inet_addr ->
+        Ok (Miou_unix.tcpv6 ())
+    | _ -> Ok (Miou_unix.tcpv4 ())
+
+  let connect_tcp ~sw:_ ~stdenv:_ sockaddr =
+    let ( >>= ) = Result.bind in
+    socket sockaddr >>= fun socket ->
+    match Miou_unix.connect socket sockaddr with
+    | () -> Ok (Socket (System (Buffer.create 0x7ff, socket)))
+    | exception Unix.Unix_error (err, f, v) ->
+        Miou_unix.close socket;
+        Error (Msg_unix (err, f, v))
+    | exception exn -> Miou_unix.close socket; raise exn
+
+  let tcp_flow_of_socket (Socket impl) = match impl with
+    | System (_, fd) -> Some fd
+    | OCaml _ -> None
+
+  let socket_of_tls_flow : sw:_ -> tls_flow -> Socket.t =
+   fun ~sw:_ -> function
+     | OCaml _ as impl -> Socket impl
+
+  module type TLS_PROVIDER =
+    Caqti_platform.System_sig.TLS_PROVIDER
+      with type 'a fiber := 'a
+       and type tcp_flow := tcp_flow
+       and type tls_flow := tls_flow
+
+  let tls_providers_r : (module TLS_PROVIDER) list ref = ref []
+  let register_tls_provider p = tls_providers_r := p :: !tls_providers_r
+
+  let tls_providers config =
+    if Caqti_connect_config.mem_name "tls" config then begin
+      match Caqti_platform.Connector.load_library "caqti-tls-miou" with
+      | Ok () -> ()
+      | Error msg -> Log.warn (fun m -> m "TLS configured, but missing caqti-tls-miou: %s" msg)
+    end;
+    !tls_providers_r
+end

unikernel/duniverse/ocaml-caqti/caqti-miou/lib-unix/system_unix.ml

@@ -0,0 +1,61 @@
+(* Copyright (C) 2023--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+module Unix = struct
+  type file_descr = Miou_unix.file_descr
+
+  let wrap_fd f fd = f (Miou_unix.of_file_descr ~non_blocking:true fd)
+
+  exception Timeout
+  let or_raise = function Ok v -> v | Error exn -> raise exn
+
+  let poll ~stdenv:() ?(read= false) ?(write= false) ?timeout fd =
+    let fn () = match read, write with
+      | false, false -> (false, false, false)
+      | true, true ->
+        let reader = Miou.async @@ fun () ->
+          Miou_unix.(blocking_read (to_file_descr fd));
+          (true, false, false) in
+        let writer = Miou.async @@ fun () ->
+          Miou_unix.(blocking_write (to_file_descr fd));
+          (false, true, false) in
+        Miou.await_first [ reader; writer ] |> or_raise
+      | true, false ->
+        Miou_unix.(blocking_read (to_file_descr fd)); (true, false, false)
+      | false, true ->
+        Miou_unix.(blocking_write (to_file_descr fd)); (false, true, false) in
+    match timeout with
+    | None -> fn ()
+    | Some t ->
+      let sleep = Miou.async @@ fun () -> Miou_unix.sleep t; raise Timeout in
+      match Miou.await_first [ sleep; Miou.async fn ] with
+      | Ok v -> v
+      | Error Timeout -> (false, false, true)
+      | Error exn -> raise exn
+end
+
+module Preemptive = struct
+  let detach f x =
+    let fn () = f x in
+    let prm =
+      if Miou.Domain.available () > 0
+      then Miou.call fn
+      else Miou.async fn in
+    Miou.await_exn prm
+
+  let run_in_main fn = fn ()
+end

unikernel/duniverse/ocaml-caqti/caqti-miou/lib/caqti_miou.ml

@@ -0,0 +1,191 @@
+(* Copyright (C) 2023--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Caqti_platform
+
+external reraise : exn -> 'a = "%reraise"
+
+module Fiber = struct
+  type 'a t = 'a
+
+  module Infix = struct
+    let ( >>= ) x f = f x
+    let ( >|= ) x f = f x
+  end
+
+  let return x = x
+  let catch f g = try f () with exn -> g exn
+  let finally f finally = Fun.protect ~finally f
+  let cleanup f g = try f () with exn -> g (); raise exn
+end
+
+module Stream = Caqti_platform.Stream.Make (Fiber)
+
+module Log = struct
+  type 'a log = 'a Logs.log
+
+  let err ?(src = Logging.default_log_src) = Logs.err ~src
+  let warn ?(src = Logging.default_log_src) = Logs.warn ~src
+  let info ?(src = Logging.default_log_src) = Logs.info ~src
+  let debug ?(src = Logging.default_log_src) = Logs.debug ~src
+end
+
+module Sequencer = struct
+  type 'a t = 'a * Miou.Mutex.t
+
+  let create v = (v, Miou.Mutex.create ())
+  let enqueue (v, m) f = Miou.Mutex.protect m (fun () -> f v)
+end
+
+type switch =
+  { stop : bool Atomic.t
+  ; mutex : Miou.Mutex.t
+  ; condition : Miou.Condition.t
+  ; hooks : (unit -> unit) Miou.Sequence.t
+  ; jobs : [ `Job of (unit -> unit) | `Check ] Miou.Queue.t }
+
+
+module Switch = struct
+  type hook = Miou.Mutex.t * (unit -> unit) Miou.Sequence.node
+  type t = switch
+
+  exception Off
+
+  let create () =
+    { stop= Atomic.make true
+    ; mutex= Miou.Mutex.create ()
+    ; condition= Miou.Condition.create ()
+    ; hooks= Miou.Sequence.create ()
+    ; jobs= Miou.Queue.create () }
+
+  let eternal = create ()
+
+  let release t =
+    Miou.Mutex.protect t.mutex @@ fun () ->
+    List.iter (fun fn -> fn ()) (Miou.Sequence.to_list t.hooks);
+    Miou.Sequence.drop t.hooks
+
+  let rec terminate orphans =
+    match Miou.care orphans with
+    | None -> ()
+    | Some None -> Miou.yield (); terminate orphans
+    | Some (Some prm) -> (
+        match Miou.await prm with
+        | Ok () -> terminate orphans
+        | Error exn ->
+            Log.err (fun m -> m "Got an unexpected error: %S" (Printexc.to_string exn));
+            terminate orphans)
+
+  let rec clean orphans =
+    match Miou.care orphans with
+    | None | Some None -> Miou.yield ()
+    | Some (Some prm) -> (
+        match Miou.await prm with
+        | Ok () -> clean orphans
+        | Error exn ->
+            Log.err (fun m -> m "Got an unexpected error: %S" (Printexc.to_string exn));
+            clean orphans)
+
+  let rec worker ~orphans t =
+    clean orphans;
+    let jobs = Miou.Mutex.protect t.mutex @@ fun () ->
+      if Miou.Queue.is_empty t.jobs && Atomic.get t.stop = false
+      then Miou.Condition.wait t.condition t.mutex;
+      Miou.Queue.(to_list (transfer t.jobs)) in
+    let prgm = function
+      | `Job fn -> ignore (Miou.async ~orphans fn)
+      | `Check -> clean orphans in
+    List.iter prgm jobs;
+    if Atomic.get t.stop = false
+    then worker ~orphans t
+    else terminate orphans
+
+  let worker t () =
+    let orphans = Miou.orphans () in
+    worker ~orphans t
+
+  let stop ~daemon t =
+    Miou.Mutex.protect t.mutex begin fun () ->
+      Atomic.set t.stop true;
+      Miou.Condition.signal t.condition
+    end;
+    match Miou.await daemon with
+    | Ok () -> ()
+    | Error exn ->
+        Log.err (fun m -> m "our worker finished with: %S" (Printexc.to_string exn));
+        reraise exn
+
+  let enqueue t fn =
+    Miou.Mutex.protect t.mutex @@ fun () ->
+    Miou.Queue.enqueue t.jobs (`Job fn);
+    Miou.Condition.signal t.condition
+
+  let call_if_available fn =
+    if Miou.Domain.available () > 0
+    then Miou.call fn
+    else Miou.async fn
+
+  let run fn =
+    let t = { stop= Atomic.make false
+            ; mutex= Miou.Mutex.create ()
+            ; condition= Miou.Condition.create ()
+            ; hooks= Miou.Sequence.create ()
+            ; jobs= Miou.Queue.create () } in
+    let daemon = call_if_available (worker t) in
+    match fn t with
+    | value -> stop ~daemon t; release t; value
+    | exception exn ->
+        Log.debug (fun m -> m "our function finished with: %S" (Printexc.to_string exn));
+        stop ~daemon t; release t; reraise exn
+
+  let on_release_cancellable t fn =
+    Miou.Mutex.protect t.mutex @@ fun () ->
+    let hook = Miou.Sequence.(add Left) t.hooks fn in
+    (t.mutex, hook)
+
+  let remove_hook (mutex, hook) =
+    Miou.Mutex.protect mutex @@ fun () ->
+    Miou.Sequence.remove hook
+
+  let check t =
+    if Atomic.get t.stop then raise Off
+    else Miou.Mutex.protect t.mutex @@ fun () ->
+      Miou.Queue.enqueue t.jobs `Check;
+      Miou.Condition.signal t.condition
+end
+
+module System_core = struct
+  module Fiber = Fiber
+  module Stream = Stream
+  module Switch = Switch
+  module Mutex = Miou.Mutex
+  module Condition = Miou.Condition
+  module Log = Log
+  module Sequencer = Sequencer
+
+  let async ~sw fn = Switch.enqueue sw fn
+end
+
+module type CONNECTION = Caqti_connection_sig.S
+  with type 'a fiber := 'a
+    and type ('a, 'e) stream := ('a, 'e) Stream.t
+
+type connection = (module CONNECTION)
+
+let or_fail = function
+  | Ok x -> x
+  | Error (#Caqti_error.t as err) -> raise (Caqti_error.Exn err)

unikernel/duniverse/ocaml-caqti/caqti-miou/lib/caqti_miou.mli

@@ -0,0 +1,49 @@
+(* Copyright (C) 2023--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+(** Prerequisites for establishing connections under miou.
+
+    The connection functions can be found in caqti-miou.unix.
+
+    {b This library considered unstable for now,} and may be revised or replaced
+    as the effect-based libraries evolve. *)
+
+type switch
+
+module Stream : Caqti_stream_sig.S with type 'a fiber := 'a
+module Switch : Caqti_switch_sig.S
+  with type 'a fiber := 'a
+   and type t = switch
+
+(**/**)
+(* For private use by Caqti. *)
+module System_core : sig
+  include Caqti_platform.System_sig.CORE
+    with type 'a Fiber.t = 'a
+     and module Stream = Stream
+     and type Switch.t = Switch.t
+     and type stdenv := unit
+end
+(**/**)
+
+module type CONNECTION = Caqti_connection_sig.S
+  with type 'a fiber := 'a
+   and type ('a, 'e) stream := ('a, 'e) Stream.t
+
+type connection = (module CONNECTION)
+
+val or_fail : ('a, [< Caqti_error.t ]) result -> 'a

unikernel/duniverse/ocaml-caqti/caqti-miou/lib/dune

@@ -0,0 +1,6 @@
+(library
+ (name caqti_miou)
+ (public_name caqti-miou)
+ (optional)
+ (modules caqti_miou)
+ (libraries logs caqti caqti.platform miou))

unikernel/duniverse/ocaml-caqti/caqti-miou/test-unix/dune

@@ -0,0 +1,5 @@
+(test
+ (name main)
+ (package caqti-miou)
+ (enabled_if (>= %{ocaml_version} "5.0"))
+ (libraries logs.threaded alcotest caqti caqti-miou caqti-miou.unix testlib))

unikernel/duniverse/ocaml-caqti/caqti-miou/test-unix/main.ml

@@ -0,0 +1,23 @@
+(* Copyright (C) 2023--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+let () = Logs_threaded.enable ()
+
+let () =
+  Alcotest.run "caqti-miou" [
+    "pool-miou", Test_pool_miou.test_cases;
+  ]

unikernel/duniverse/ocaml-caqti/caqti-miou/test-unix/test_pool_miou.ml

@@ -0,0 +1,228 @@
+(* Copyright (C) 2023--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+module Pool = Caqti_miou_unix.System.Pool
+
+module Resource = struct
+  type t = {
+    id: int;
+    use_count: int Atomic.t;
+  }
+
+  let alive = Hashtbl.create 17
+  let alive_mutex = Mutex.create ()
+
+  let with_alive_locked f =
+    Mutex.lock alive_mutex;
+    Fun.protect ~finally:(fun () -> Mutex.unlock alive_mutex) f
+
+  let latest_id = Atomic.make 0
+
+  let create () =
+    let id = Atomic.fetch_and_add latest_id 1 in
+    with_alive_locked (fun () -> Hashtbl.add alive id ());
+    Ok {id; use_count = Atomic.make 0}
+
+  let create_or_fail () =
+    if Random.int 4 = 0 then Error () else
+    create ()
+
+  let free resource =
+    with_alive_locked begin fun () ->
+      assert (Hashtbl.mem alive resource.id);
+      Hashtbl.remove alive resource.id
+    end
+end
+
+exception Timeout
+
+let with_timeout ts fn =
+  let prm0 = Miou.async fn in
+  let prm1 = Miou.async @@ fun () -> Miou_unix.sleep ts; raise Timeout in
+  match Miou.await_first [ prm0; prm1 ] with
+  | Ok value -> value
+  | Error Timeout -> raise Timeout
+  | Error exn ->
+      Logs.err (fun m -> m "Unexpected exception: %S" (Printexc.to_string exn));
+      raise exn
+
+let test_n n =
+  Caqti_miou.Switch.run @@ fun sw ->
+  let max_idle_size = Random.int 11 in
+  let max_size = max 1 (max_idle_size + Random.int 5) in
+  let max_use_count =
+    (match Random.bool () with
+     | false -> None
+     | true -> Some (1 + Random.int 8))
+  in
+  let pool =
+    let config =
+      Caqti_pool_config.create ~max_idle_size ~max_size ~max_use_count ()
+    in
+    Pool.create ~config ~sw ~stdenv:()
+      Resource.create_or_fail Resource.free
+  in
+  let wakers = Array.make n None in
+  let wait_count = ref 0 in
+  let wait_count_cond = Miou.Condition.create () in
+  let wait_count_mutex = Miou.Mutex.create () in
+  let wake j c =
+    ignore (Miou.Computation.try_return c ());
+    wakers.(j) <- None in
+  for _ = 0 to 3 * n - 1 do
+    let j = Random.int n in
+    (* NOTE(dinosaure): This assertion is not necessarily true when another
+       domain may be in charge of the asynchronous functions and these are not
+       actually launched immediately. *)
+    (* assert (Pool.size pool = Hashtbl.length Resource.alive); *)
+    (match wakers.(j) with
+     | None ->
+        let c = Miou.Computation.create () in
+        Miou.Mutex.protect wait_count_mutex (fun () -> incr wait_count);
+        let task (resource : Resource.t) =
+          begin match max_use_count with
+          | None -> ()
+          | Some n -> assert (Atomic.get resource.use_count < n) end;
+          Atomic.incr resource.use_count;
+          ignore (Miou.Computation.await c);
+          Miou.Mutex.protect wait_count_mutex begin fun () ->
+            decr wait_count;
+            Miou.Condition.signal wait_count_cond
+          end;
+          Ok ()
+        in
+        Caqti_miou.System_core.async ~sw begin fun () ->
+          begin match Pool.use task pool with
+          | Ok () -> ()
+          | Error () ->
+             ignore (Miou.Computation.await c);
+             Miou.Mutex.protect wait_count_mutex begin fun () ->
+               decr wait_count;
+               Miou.Condition.signal wait_count_cond
+             end;
+          end
+        end;
+        wakers.(j) <- Some c
+     | Some c -> wake j c)
+  done;
+  for j = 0 to n - 1 do
+    (match wakers.(j) with
+     | None -> Miou.yield ()
+     | Some c -> wake j c)
+  done;
+  let rec wait_for_all () =
+    Miou.Mutex.lock wait_count_mutex;
+    while !wait_count > 0 do
+      Miou.Condition.wait wait_count_cond wait_count_mutex;
+    done;
+    let n = !wait_count in
+    Miou.Mutex.unlock wait_count_mutex;
+    if n > 0 then wait_for_all ()
+  in
+  (* NOTE(dinosaure): see the note below, we need to give a better chance to
+     wait all tasks. *)
+  with_timeout 5.0 wait_for_all;
+  if not (Pool.size pool <= max_idle_size) then begin
+    (* TODO: Remove condition and CI config after fixing #126. *)
+    if Sys.getenv_opt "CAQTI_DEBUGGING_ISSUE_126" = Some "true" then
+      Alcotest.failf "%d resources left in pool, expected at most %d"
+        (Pool.size pool) max_idle_size
+  end;
+  Alcotest.(check int) "still waiting" 0 !wait_count;
+  Pool.drain pool;
+  Alcotest.(check int) "pool size after drain" 0 (Pool.size pool);
+  Alcotest.(check int) "alive after drain" 0 (Hashtbl.length Resource.alive)
+
+let test () =
+  Miou_unix.run @@ fun () ->
+  test_n 0;
+  test_n 1;
+  (* NOTE(dinosaure): For a simple core, the miou pattern is not the most
+     optimised: it's basically a scheduler within a scheduler. So the [Switch]
+     ends up in the role of a small scheduler which will execute tasks with
+     [async], whereas Miou is a scheduler. The aim is for the [Switch] to
+     execute tasks in another domain. In this case, the test execution time is
+     reasonable, but for a simple core, this repetition of task management slows
+     down the process. We therefore limit the number of tasks to be performed
+     for a single core.
+
+     We could offer another [Switch] implementation depending on the number of
+     domains available. However, this choice can only be made dynamically. It is
+     more reasonable to consider that with miou, we have at least 2 cores
+     available. *)
+  let max =
+    if Miou.Domain.available () > 0
+    then 12 else 6 in
+  let rec loop n_it =
+    if n_it > 0 then begin
+      test_n (Random.int (1 lsl max));
+      loop (n_it - 1)
+    end
+  in
+  loop 500
+
+let create_gathering n =
+  let count = Atomic.make n in
+  let c = Miou.Computation.create () in
+  fun () ->
+    let v = Atomic.fetch_and_add count (-1) in
+    Logs.debug (fun m -> m "count:%d" (v - 1));
+    if v - 1 > 0 then Miou.Computation.await_exn c
+    else begin
+      assert (Miou.Computation.try_return c ());
+      Logs.debug (fun m -> m "signal others")
+    end
+
+let test_age _ =
+  Miou_unix.run @@ fun () ->
+  Caqti_miou.Switch.run @@ fun sw ->
+  let max_size = 8 in
+  let max_idle_size = 4 in
+  let max_idle_age = Some Mtime.Span.(100 * ms) in
+  let pool =
+    let config =
+      Caqti_pool_config.create ~max_size ~max_idle_size ~max_idle_age ()
+    in
+    Pool.create ~config ~sw ~stdenv:() Resource.create Resource.free
+  in
+  let user_count = 8 in
+  let join_gathering = create_gathering user_count in
+  let f _i _resource =
+    Ok (join_gathering ()) in
+  let jobs = List.init user_count f in
+  let launch job =
+    Caqti_miou_unix.System.async ~sw @@ fun () ->
+    ignore (Pool.use job pool) in
+  List.iter launch jobs;
+  (* NOTE(dinosaure): miou does not effectively launch jobs. So, [Pool.use]
+     is not yet effectively executed. At this stage, [Pool.size] should be
+     equal to [0] but, due to the fact the a domain is probably used to launch
+     these jobs, it can be higher than [0]. *)
+  (* Alcotest.(check int) "pool size before sleep" 4 (Pool.size pool); *)
+  let rec wait_while_draining timeout =
+    if Pool.size pool > 0 then begin
+      Miou_unix.sleep 0.1; Miou.yield ();
+      wait_while_draining (timeout -. 0.1)
+    end
+  in
+  wait_while_draining 5.0;
+  Alcotest.(check int) "pool size after sleep" 0 (Pool.size pool)
+
+let test_cases = [
+  Alcotest.test_case "basic usage" `Quick test;
+  Alcotest.test_case "timed cleanup" `Quick test_age;
+]

unikernel/duniverse/ocaml-caqti/caqti-miou/testlib-unix/dune

@@ -0,0 +1,4 @@
+(library
+ (name testlib_miou_unix)
+ (optional)
+ (libraries alcotest caqti_miou caqti_miou_unix testlib))

unikernel/duniverse/ocaml-caqti/caqti-miou/testlib-unix/testlib_miou_unix.ml

@@ -0,0 +1,45 @@
+(* Copyright (C) 2023--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+include Caqti_miou.System_core
+include Caqti_miou
+include Caqti_miou_unix
+
+module Fiber = struct
+  include Fiber
+
+  let fail = raise
+
+  module Infix = struct
+    include Infix
+    let (>>=?) = Result.bind
+    let (>|=?) x f = Result.map f x
+  end
+end
+
+module Alcotest_cli =
+  Testlib.Make_alcotest_cli
+    (Alcotest.Unix_platform)
+    (Alcotest_engine.Monad.Identity)
+
+module List_result_fiber = struct
+  open Fiber.Infix
+
+  let rec iter_s f = function
+   | [] -> Fiber.return (Ok ())
+   | x :: xs -> f x >>=? fun () -> iter_s f xs
+end

unikernel/duniverse/ocaml-caqti/caqti-miou/testlib-unix/testlib_miou_unix.mli

@@ -0,0 +1,21 @@
+(* Copyright (C) 2023--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library 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, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library 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
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+include Testlib.Sig.Ground
+  with type 'a Fiber.t = 'a
+   and module Stream = Caqti_miou.Stream
+   and module Pool = Caqti_miou_unix.Pool