unikernel/duniverse/ocaml-caqti/caqti/lib-platform/connection_utils.ml

@@ -0,0 +1,110 @@
+(* Copyright (C) 2019--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 Make_helpers
+  (System : System_sig.S) =
+struct
+  open System
+  open System.Fiber.Infix
+
+  let assert_single_use ~what in_use f =
+    if !in_use then
+      failwith ("Invalid concurrent usage of " ^ what ^ " detected.");
+    in_use := true;
+    Fiber.cleanup
+      (fun () -> f () >|= fun res -> in_use := false; res)
+      (fun () -> in_use := false; Fiber.return ())
+end
+
+module Make_convenience
+  (System : System_sig.S)
+  (C : Caqti_connection_sig.Base
+        with type 'a fiber := 'a System.Fiber.t
+         and type ('a, 'err) stream := ('a, 'err) System.Stream.t) =
+struct
+  open System
+  open System.Fiber.Infix
+  module Response = C.Response
+  let (>>=?) m f = m >>= function Ok x -> f x | Error _ as r -> Fiber.return r
+  let (>|=?) m f = m >|= function Ok r -> Ok (f r) | Error _ as r -> r
+
+  let exec q p = C.call ~f:Response.exec q p
+  let find q p = C.call ~f:Response.find q p
+  let find_opt q p = C.call ~f:Response.find_opt q p
+  let fold q f p acc = C.call ~f:(fun resp -> Response.fold f resp acc) q p
+  let fold_s q f p acc = C.call ~f:(fun resp -> Response.fold_s f resp acc) q p
+  let iter_s q f p = C.call ~f:(fun resp -> Response.iter_s f resp) q p
+  let collect_list q p =
+    let f resp = Response.fold List.cons resp [] >|= Result.map List.rev in
+    C.call ~f q p
+  let rev_collect_list q p =
+    let f resp = Response.fold List.cons resp [] in
+    C.call ~f q p
+
+  let exec_with_affected_count q p =
+    let f response =
+      Response.exec response >>= fun execResult ->
+      match execResult with
+      | Ok () -> Response.affected_count response
+      | Error x -> Fiber.return (Error x) in
+    C.call ~f q p
+
+  let with_transaction f =
+    C.start () >>=? fun () ->
+    Fiber.cleanup
+      (fun () ->
+        f () >>= (function
+         | Ok y -> C.commit () >|=? fun () -> y
+         | Error _ as r -> C.rollback () >|= fun _ -> r))
+      (fun () -> C.rollback () >|= ignore)
+end
+
+module Make_populate
+  (System : System_sig.S)
+  (C : Caqti_connection_sig.Base
+        with type 'a fiber := 'a System.Fiber.t
+         and type ('a, 'e) stream := ('a, 'e) System.Stream.t) =
+struct
+  open System
+  open System.Fiber.Infix
+  let (>>=?) m f = m >>= function Ok x -> f x | Error _ as r -> Fiber.return r
+
+  let populate ~table ~columns row_type =
+    let request =
+      let open Caqti_template.Create in
+      dynamic_gen T.(row_type -->. unit) @@ Fun.const @@
+      Q.concat [
+        Q.lit "INSERT INTO "; Q.lit table; Q.lit "(";
+        Q.concat ~sep:", " (List.map Q.lit columns);
+        Q.lit ") VALUES (";
+        Q.concat ~sep:", " (List.mapi (fun i _ -> Q.param i) columns);
+        Q.lit ")";
+      ]
+    in
+    fun data ->
+      C.start () >>=? fun () ->
+      Stream.iter_s ~f:(C.call ~f:C.Response.exec request) data >>= fun res ->
+      C.deallocate request >>= fun _ ->
+      (match res with
+       | Ok () ->
+          C.commit ()
+       | Error (`Congested err) ->
+          C.rollback () >>=? fun () ->
+          Fiber.return (Error (`Congested err))
+       | Error err ->
+          Fiber.return (Error err))
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/connection_utils.mli

@@ -0,0 +1,41 @@
+(* Copyright (C) 2019--2020  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.
+ *)
+
+(** Internal connection-related utilities. *)
+
+module Make_helpers : functor (Sys : System_sig.S) -> sig
+  open Sys
+
+  val assert_single_use :
+    what: string -> bool ref -> (unit -> 'a Fiber.t) -> 'a Fiber.t
+end
+
+module Make_convenience :
+  functor (Sys : System_sig.S) ->
+  functor (_ : Caqti_connection_sig.Base
+                with type 'a fiber := 'a Sys.Fiber.t
+                 and type ('a, 'err) stream := ('a, 'err) Sys.Stream.t) ->
+  Caqti_connection_sig.Convenience with type 'a fiber := 'a Sys.Fiber.t
+
+module Make_populate :
+  functor (Sys : System_sig.S) ->
+  functor (_ : Caqti_connection_sig.Base
+                with type 'a fiber := 'a Sys.Fiber.t
+                 and type ('a, 'err) stream := ('a, 'err) Sys.Stream.t) ->
+  Caqti_connection_sig.Populate
+    with type 'a fiber := 'a Sys.Fiber.t
+     and type ('a, 'err) stream := ('a, 'err) Sys.Stream.t

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/connector.ml

@@ -0,0 +1,236 @@
+(* Copyright (C) 2014--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.
+ *)
+
+[@@@alert "-caqti_private"]
+
+let dynload_library = ref None
+
+let define_loader load = dynload_library := Some load
+
+let load_library lib =
+  (match !dynload_library with
+   | Some load -> load lib
+   | None ->
+      Error (Printf.sprintf "\
+        Neither %s nor a dynamic loader is linked into the application." lib))
+
+let library_name_of_scheme = function
+ | "postgres" | "postgresql" -> "caqti-driver-postgresql"
+ | s -> "caqti-driver-" ^ s
+
+let set_tweaks_version = function
+ | None -> Fun.id
+ | Some x -> Caqti_connect_config.(set tweaks_version) x
+
+let compose_subst_with_env subst env dialect =
+  let compose_subst subst1 subst2 var =
+    (try subst1 var with Not_found -> subst2 var)
+  in
+  (match subst, env with
+   | None, None -> fun _ -> raise Not_found
+   | Some subst, None -> subst dialect
+   | None, Some env ->
+      env (Caqti_driver_info.of_dialect dialect)
+   | Some subst, Some env ->
+      let driver_info = Caqti_driver_info.of_dialect dialect in
+      compose_subst (subst dialect) (env driver_info))
+
+module Make
+  (System : System_sig.S)
+  (Pool : Pool.S
+    with type 'a fiber := 'a System.Fiber.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv)
+  (Loader : Driver_loader.S
+    with type 'a fiber := 'a System.Fiber.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv
+     and type ('a, 'e) stream := ('a, 'e) System.Stream.t) =
+struct
+  open System
+  open System.Fiber.Infix
+
+  module type CONNECTION = Caqti_connection_sig.S
+    with type 'a fiber := 'a Fiber.t
+     and type ('a, 'err) stream := ('a, 'err) Stream.t
+
+  type connection = (module CONNECTION)
+
+  let (>>=?) m f = m >>= function Ok x -> f x | Error _ as r -> Fiber.return r
+  let (>|=?) m f = m >|= function Ok x -> (Ok (f x)) | Error _ as r -> r
+  let (let+?) = (>|=?)
+
+  module type DRIVER = Driver_loader.DRIVER
+    with type 'a fiber := 'a Fiber.t
+     and type ('a, 'err) stream := ('a, 'err) Stream.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv
+
+  let drivers : (string, (module DRIVER)) Hashtbl.t = Hashtbl.create 11
+
+  let message_cont : (_, _, _, _) format4 =
+    if Loader.provides_unix then
+      "Your entry point provides both the networking and unix components."
+    else
+      "Your entry point provides the networking but not the unix component, \
+       which is required by drivers based on C bindings."
+
+  let message_static = Printf.sprintf
+    ("A suitable driver for the URI-scheme %s was not found. " ^^ message_cont)
+
+  let message_dynamic = Printf.sprintf
+    ("A suitable driver for the URI-scheme %s was not found \
+      after linking in %s. " ^^ message_cont)
+
+  let load_driver' ~uri scheme =
+    (match Loader.find_and_apply scheme with
+     | Some driver -> Ok driver
+     | None ->
+        (match !dynload_library with
+         | None ->
+            let msg = message_static scheme in
+            Error (Caqti_error.load_failed ~uri (Caqti_error.Msg msg))
+         | Some load ->
+            let driver_lib = library_name_of_scheme scheme in
+            (match load driver_lib with
+             | Ok () ->
+                (match Loader.find_and_apply scheme with
+                 | Some driver -> Ok driver
+                 | None ->
+                    let msg = message_dynamic scheme driver_lib in
+                    Error (Caqti_error.load_failed ~uri (Caqti_error.Msg msg)))
+             | Error msg ->
+                Error (Caqti_error.load_failed ~uri (Caqti_error.Msg msg)))))
+
+  let load_driver uri =
+    (match Uri.scheme uri with
+     | None ->
+        let msg = "Missing URI scheme." in
+        Error (Caqti_error.load_rejected ~uri (Caqti_error.Msg msg))
+     | Some scheme ->
+        (try Ok (Hashtbl.find drivers scheme) with
+         | Not_found ->
+            (match load_driver' ~uri scheme with
+             | Ok driver ->
+                Hashtbl.add drivers scheme driver;
+                Ok driver
+             | Error _ as r -> r)))
+
+  let connect
+        ?subst ?env ?(config = Caqti_connect_config.default)
+        ?tweaks_version ~sw ~stdenv uri
+      : ((module CONNECTION), _) result Fiber.t =
+    let subst = compose_subst_with_env subst env in
+    let config = set_tweaks_version tweaks_version config in
+    Switch.check sw;
+    (match load_driver uri with
+     | Ok driver ->
+        let module Driver = (val driver) in
+        let+? conn = Driver.connect ~sw ~stdenv ~subst ~config uri in
+        let module Conn = (val conn : CONNECTION) in
+        let module Conn' = struct
+          include Conn
+          let disconnect =
+            let hook = Switch.on_release_cancellable sw disconnect in
+            fun () -> Switch.remove_hook hook; disconnect ()
+        end in
+        (module Conn' : CONNECTION)
+     | Error err ->
+        Fiber.return (Error err))
+
+  let with_connection
+        ?subst ?env ?config ?tweaks_version ~stdenv uri f =
+    Switch.run begin fun sw ->
+      connect ~sw ~stdenv ?subst ?env ?config ?tweaks_version uri >>=? f
+    end
+
+  let connect_pool
+        ?pool_config ?post_connect ?subst ?env
+        ?(config = Caqti_connect_config.default)
+        ?tweaks_version ~sw ~stdenv uri =
+    let subst = compose_subst_with_env subst env in
+    let pool_config =
+      (match pool_config with
+       | None -> Caqti_pool_config.default_from_env ()
+       | Some pool_config -> pool_config)
+    in
+    let config = set_tweaks_version tweaks_version config in
+    Switch.check sw;
+    let check_arg cond =
+      if not cond then invalid_arg "Caqti_connect.Make.connect_pool"
+    in
+    (match Caqti_pool_config.(get max_size) pool_config,
+           Caqti_pool_config.(get max_idle_size) pool_config with
+     | None, None -> ()
+     | Some max_size, None -> check_arg (max_size >= 0)
+     | None, Some _ -> check_arg false
+     | Some max_size, Some max_idle_size ->
+        check_arg (max_size >= 0);
+        check_arg (0 <= max_idle_size && max_idle_size <= max_size));
+    (match load_driver uri with
+     | Ok driver ->
+        let module Driver = (val driver) in
+        let connect =
+          (match post_connect with
+           | None ->
+              fun () ->
+                (Driver.connect ~sw ~stdenv ~subst ~config uri
+                    :> (connection, _) result Fiber.t)
+           | Some post_connect ->
+              fun () ->
+                (Driver.connect ~sw ~stdenv ~subst ~config uri
+                    :> (connection, _) result Fiber.t)
+                  >>=? fun conn -> post_connect conn
+                  >|=? fun () -> conn)
+        in
+        let disconnect (module Db : CONNECTION) = Db.disconnect () in
+        let validate (module Db : CONNECTION) = Db.validate () in
+        let check (module Db : CONNECTION) = Db.check in
+        let di = Driver.driver_info in
+        let pool_config =
+          (match Caqti_driver_info.can_concur di,
+                 Caqti_driver_info.can_pool di,
+                 Caqti_pool_config.(get max_idle_size) pool_config with
+           | true, true, _ ->
+              pool_config
+           | true, false, _ ->
+              pool_config |> Caqti_pool_config.(set max_idle_size) 0
+           | false, true, Some 0 ->
+              pool_config
+                |> Caqti_pool_config.(set max_size) 1
+                |> Caqti_pool_config.(set max_idle_size) 0
+           | false, true, _ ->
+              pool_config
+                |> Caqti_pool_config.(set max_size) 1
+                |> Caqti_pool_config.(set max_idle_size) 1
+           | false, false, _ ->
+              pool_config
+                |> Caqti_pool_config.(set max_size) 1
+                |> Caqti_pool_config.(set max_idle_size) 0)
+        in
+        let pool =
+          Pool.create
+            ~config:pool_config ~validate ~check ~sw ~stdenv connect disconnect
+        in
+        let hook =
+          Switch.on_release_cancellable sw (fun () -> Pool.drain pool)
+        in
+        Gc.finalise (fun _ -> Switch.remove_hook hook) pool;
+        Ok pool
+     | Error err ->
+        Error err)
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/connector.mli

@@ -0,0 +1,46 @@
+(* Copyright (C) 2017--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.
+ *)
+
+(** Connection functor and backend registration. *)
+
+val define_loader : (string -> (unit, string) result) -> unit
+(** Defines the function used to dynamically load driver libraries. This is
+    normally called during initialization by the [caqti.plugin] library, if
+    linked into the application. *)
+
+val load_library : string -> (unit, string) result
+
+module Make :
+  functor (System : System_sig.S) ->
+  functor (Pool : Pool.S
+    with type 'a fiber := 'a System.Fiber.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv) ->
+  functor (Loader : Driver_loader.S
+    with type 'a fiber := 'a System.Fiber.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv
+     and type ('a, 'e) stream := ('a, 'e) System.Stream.t) ->
+  Caqti_connect_sig.S
+    with type 'a fiber := 'a System.Fiber.t
+     and type ('a, 'e) stream := ('a, 'e) System.Stream.t
+     and type ('a, 'e) pool := ('a, 'e) Pool.t
+     and type 'a with_switch := sw: System.Switch.t -> 'a
+     and type 'a with_stdenv := stdenv: System.stdenv -> 'a
+     and type connection := (module Loader.CONNECTION)
+(** Constructs the main module used to connect to a database for the given
+    concurrency model. *)

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/conv.ml

@@ -0,0 +1,64 @@
+(* Copyright (C) 2019--2022  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 Printf
+
+let datetuple_of_iso8601 s =
+  if String.length s = 10 && s.[4] = '-' && s.[7] = '-' then
+    try
+      (int_of_string (String.sub s 0 4),
+       int_of_string (String.sub s 5 2),
+       int_of_string (String.sub s 8 2))
+    with Failure _ ->
+      failwith "Caqti_platform.datetuple_of_iso8601"
+  else
+    failwith "Caqti_platform.datetuple_of_iso8601"
+
+let iso8601_of_datetuple (y, m, d) =
+  sprintf "%04d-%02d-%02d" y m d
+
+let string_of_rfc3339_error ~input err =
+  let buf = Buffer.create 64 in
+  let ppf = Format.formatter_of_buffer buf in
+  Ptime.pp_rfc3339_error ppf err;
+  Format.fprintf ppf " in value %S." input;
+  Format.pp_print_flush ppf ();
+  Buffer.contents buf
+
+let ptime_of_rfc3339_utc s =
+  let n = String.length s in
+  let s' =
+    if n < 13 then s else
+    if s.[n - 1] = 'Z' then s else
+    if s.[n - 3] = '+' || s.[n - 3] = '-' then s ^ ":00" else
+    if s.[n - 6] = '+' || s.[n - 6] = '-' then s else
+    s ^ "Z"
+  in
+  (match Ptime.of_rfc3339 s' with
+   | Ok (t, _, _) -> Ok t
+   | Error (`RFC3339 (_, err)) ->
+      Error (string_of_rfc3339_error ~input:s' err))
+
+let pdate_of_iso8601 s =
+  (match Ptime.of_date (datetuple_of_iso8601 s) with
+   | exception Failure _ ->
+      Error (sprintf "Cannot parse date %S." s)
+   | None ->
+      Error (sprintf "Date %s is out of range." s)
+   | Some pdate -> Ok pdate)
+
+let iso8601_of_pdate x = iso8601_of_datetuple (Ptime.to_date x)

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/conv.mli

@@ -0,0 +1,26 @@
+(* Copyright (C) 2019--2022  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.
+ *)
+
+(** Miscellaneous conversions. *)
+
+val datetuple_of_iso8601 : string -> int * int * int
+val iso8601_of_datetuple : int * int * int -> string
+
+val ptime_of_rfc3339_utc : string -> (Ptime.t, string) result
+
+val pdate_of_iso8601 : string -> (Ptime.t, string) result
+val iso8601_of_pdate : Ptime.t -> string

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/driver_loader.ml

@@ -0,0 +1,89 @@
+(* Copyright (C) 2022--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 type DRIVER = sig
+  type +'a fiber
+  type (+'a, +'err) stream
+  type switch
+  type stdenv
+
+  module type CONNECTION = Caqti_connection_sig.S
+    with type 'a fiber := 'a fiber
+     and type ('a, 'err) stream := ('a, 'err) stream
+
+  val driver_info : Caqti_driver_info.t
+
+  val connect :
+    sw: switch ->
+    stdenv: stdenv ->
+    subst: (Caqti_template.Dialect.t -> Caqti_template.Query.subst) ->
+    config: Caqti_connect_config.t ->
+    Uri.t ->
+    ((module CONNECTION), [> Caqti_error.connect]) result fiber
+end
+
+module type DRIVER_FUNCTOR =
+  functor (System : System_sig.S) ->
+  DRIVER
+    with type 'a fiber := 'a System.Fiber.t
+     and type ('a, 'err) stream := ('a, 'err) System.Stream.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv
+
+let drivers = Hashtbl.create 5
+let register scheme p = Hashtbl.add drivers scheme p
+
+module type S = sig
+  type +'a fiber
+  type (+'a, +'e) stream
+  type switch
+  type stdenv
+
+  module type CONNECTION = Caqti_connection_sig.S
+    with type 'a fiber := 'a fiber
+     and type ('a, 'e) stream := ('a, 'e) stream
+
+  module type DRIVER = DRIVER
+    with type 'a fiber := 'a fiber
+     and type ('a, 'e) stream := ('a, 'e) stream
+     and type switch := switch
+     and type stdenv := stdenv
+
+  val provides_unix : bool
+
+  val find_and_apply : string -> (module DRIVER) option
+end
+
+module Make (System : System_sig.S) = struct
+  module type DRIVER = DRIVER
+    with type 'a fiber := 'a System.Fiber.t
+     and type ('a, 'e) stream := ('a, 'e) System.Stream.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv
+
+  module type CONNECTION = Caqti_connection_sig.S
+    with type 'a fiber := 'a System.Fiber.t
+     and type ('a, 'e) stream := ('a, 'e) System.Stream.t
+
+  let provides_unix = false
+
+  let find_and_apply scheme =
+    (match Hashtbl.find_opt drivers scheme with
+     | None -> None
+     | Some (module F : DRIVER_FUNCTOR) ->
+        Some (module F (System) : DRIVER))
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/driver_loader.mli

@@ -0,0 +1,93 @@
+(* Copyright (C) 2022--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.
+ *)
+
+(** Registration and Loading of Drivers
+
+    This interface is unstable and may change between minor versions.  If you
+    are developing an external driver, please open an issue to sort out
+    requirements and to announce you need for a stable driver API. *)
+
+(** This is the signature implemented by drivers, given the system dependencies.
+    More precisely, drivers implement either {!DRIVER_FUNCTOR} or
+    {!Caqti_platform_unix.Driver_loader.DRIVER_FUNCTOR} depending on
+    requirements. *)
+module type DRIVER = sig
+  type +'a fiber
+  type (+'a, +'err) stream
+  type switch
+  type stdenv
+
+  module type CONNECTION = Caqti_connection_sig.S
+    with type 'a fiber := 'a fiber
+     and type ('a, 'err) stream := ('a, 'err) stream
+
+  val driver_info : Caqti_driver_info.t
+
+  val connect :
+    sw: switch ->
+    stdenv: stdenv ->
+    subst: (Caqti_template.Dialect.t -> Caqti_template.Query.subst) ->
+    config: Caqti_connect_config.t ->
+    Uri.t ->
+    ((module CONNECTION), [> Caqti_error.connect]) result fiber
+end
+
+(** {2 Registration} *)
+
+module type DRIVER_FUNCTOR =
+  functor (System : System_sig.S) ->
+  DRIVER
+    with type 'a fiber := 'a System.Fiber.t
+     and type ('a, 'err) stream := ('a, 'err) System.Stream.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv
+(** The functor implemented by drivers independent from the unix library. *)
+
+val register : string -> (module DRIVER_FUNCTOR) -> unit
+(** [register scheme driver_functor] registers [driver_functor] as the driver
+    implementation for handling the URI scheme [scheme]. *)
+
+(** {2 Usage} *)
+
+(** The the interface used internally to load drivers. *)
+module type S = sig
+  type +'a fiber
+  type (+'a, +'e) stream
+  type switch
+  type stdenv
+
+  module type CONNECTION = Caqti_connection_sig.S
+    with type 'a fiber := 'a fiber
+     and type ('a, 'e) stream := ('a, 'e) stream
+
+  module type DRIVER = DRIVER
+    with type 'a fiber := 'a fiber
+     and type ('a, 'e) stream := ('a, 'e) stream
+     and type switch := switch
+     and type stdenv := stdenv
+
+  val provides_unix : bool
+
+  val find_and_apply : string -> (module DRIVER) option
+end
+
+module Make (System : System_sig.S) : S
+  with type 'a fiber := 'a System.Fiber.t
+   and type ('a, 'e) stream := ('a, 'e) System.Stream.t
+   and type switch := System.Switch.t
+   and type stdenv := System.stdenv
+(** Instantiation of the loader interface for give system dependencies. *)

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

@@ -0,0 +1,5 @@
+(library
+ (name caqti_platform)
+ (public_name caqti.platform)
+ (flags (:standard -alert -caqti_unstable))
+ (libraries caqti domain-name ipaddr lru lwt-dllist mtime.clock.os))

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/heap.ml

@@ -0,0 +1,61 @@
+(* Copyright (C) 2014--2016  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 type S = sig
+  type elt
+  type t
+
+  val empty : t
+  val is_empty : t -> bool
+  val card : t -> int
+  val push : elt -> t -> t
+  val merge : t -> t -> t
+  val pop_e : t -> elt * t
+end
+
+module Make (Elt : Set.OrderedType) = struct
+
+  type elt = Elt.t
+  type t = O | Y of int * elt * t * t
+
+  let empty = O
+
+  let is_empty h = h = O
+
+  let card = function
+    | O -> 0
+    | Y (n, _, _, _) -> n
+
+  let rec push e' = function
+    | O -> Y (1, e', O, O)
+    | Y (n, e, hL, hR) ->
+      let e_min, e_max = if Elt.compare e' e < 0 then e', e else e, e' in
+      if card hL < card hR then Y (n + 1, e_min, push e_max hL, hR)
+                           else Y (n + 1, e_min, hL, push e_max hR)
+
+  let rec merge hL hR =
+    match hL, hR with
+    | O, h | h, O -> h
+    | Y (nL, eL, hA, hB), Y (nR, eR, hC, hD) ->
+      if Elt.compare eL eR < 0 then Y (nL + nR, eL, merge hA hB, hR)
+                               else Y (nL + nR, eR, hL, merge hC hD)
+
+  let pop_e = function
+    | O -> invalid_arg "Caqti_heap.pop_e: Empty heap."
+    | Y (_, e, hL, hR) -> e, merge hL hR
+
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/heap.mli

@@ -0,0 +1,35 @@
+(* Copyright (C) 2014--2018  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.
+ *)
+
+(** Internal min-heap implementation.
+
+    This is a simple min-heap implementation deemed sufficient for the {!Pool}
+    module.  There are algorithms better suited for larger heaps. *)
+
+module type S = sig
+  type t
+  type elt
+
+  val empty : t
+  val is_empty : t -> bool
+  val card : t -> int
+  val push : elt -> t -> t
+  val merge : t -> t -> t
+  val pop_e : t -> elt * t
+end
+
+module Make (Elt : Set.OrderedType) : S with type elt = Elt.t

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/list_ext.ml

@@ -0,0 +1,28 @@
+(* Copyright (C) 2019--2022  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 rec fold f = function
+ | [] -> Fun.id
+ | x :: xs -> fun acc -> acc |> f x |> fold f xs
+
+let iteri_r f xs =
+  let rec loop i = function
+   | [] -> Ok ()
+   | x :: xs ->
+      (match f i x with Ok () -> loop (i + 1) xs | Error _ as r -> r)
+  in
+  loop 0 xs

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/list_ext.mli

@@ -0,0 +1,21 @@
+(* Copyright (C) 2019--2022  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.
+ *)
+
+(** Additions to the {!List} module. *)
+
+val fold : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
+val iteri_r : (int -> 'a -> (unit, 'e) result) -> 'a list -> (unit, 'e) result

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/logging.ml

@@ -0,0 +1,20 @@
+(* Copyright (C) 2019--2021  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 default_log_src = Logs.Src.create "caqti"
+
+let request_log_src = Logs.Src.create "caqti.request"

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/logging.mli

@@ -0,0 +1,21 @@
+(* Copyright (C) 2019--2021  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.
+ *)
+
+(** Internals related to logging. *)
+
+val default_log_src : Logs.Src.t
+val request_log_src : Logs.Src.t

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/pool.ml

@@ -0,0 +1,346 @@
+(* Copyright (C) 2014--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 Config = Caqti_pool_config
+
+let default_max_size =
+  try int_of_string (Sys.getenv "CAQTI_POOL_MAX_SIZE") with Not_found -> 8
+
+let default_log_src = Logs.Src.create "Caqti_platform.Pool"
+
+module type ALARM = sig
+  type switch
+  type stdenv
+
+  type t
+
+  val schedule :
+    sw: switch ->
+    stdenv: stdenv ->
+    Mtime.t -> (unit -> unit) -> t
+
+  val unschedule : t -> unit
+end
+
+module type S = sig
+  type switch
+  type stdenv
+
+  include Caqti_pool_sig.S
+
+  val create :
+    ?config: Caqti_pool_config.t ->
+    ?check: ('a -> (bool -> unit) -> unit) ->
+    ?validate: ('a -> bool fiber) ->
+    ?log_src: Logs.Src.t ->
+    sw: switch ->
+    stdenv: stdenv ->
+    (unit -> ('a, 'e) result fiber) -> ('a -> unit fiber) ->
+    ('a, 'e) t
+end
+
+module Make
+  (System : System_sig.CORE)
+  (Alarm : ALARM
+    with type stdenv := System.stdenv
+     and type switch := System.Switch.t) =
+struct
+  open System
+  open System.Fiber.Infix
+
+  type reaper_state =
+    | Idle
+    | Working
+    | Waiting of Alarm.t
+
+  let (>>=?) m f =
+    m >>= function Ok x -> f x | Error e -> Fiber.return (Error e)
+
+  module Task = struct
+    type t = {priority: float; condition: Condition.t}
+    let wake {condition; _} = Condition.signal condition
+    let compare {priority = pA; _} {priority = pB; _} = Float.compare pB pA
+  end
+
+  module Taskq = Heap.Make (Task)
+
+  type 'a entry = {
+    resource: 'a;
+    mutable used_count: int;
+    mutable used_latest: Mtime.t;
+  }
+
+  type ('a, +'e) t = {
+    stdenv: stdenv;
+    switch: Switch.t;
+    create: unit -> ('a, 'e) result Fiber.t;
+    free: 'a -> unit Fiber.t;
+    check: 'a -> (bool -> unit) -> unit;
+    validate: 'a -> bool Fiber.t;
+    log_src: Logs.Src.t;
+    max_idle_size: int;
+    max_idle_age: Mtime.Span.t option;
+    max_size: int;
+    max_use_count: int option;
+
+    (* Mutable *)
+    mutex: Mutex.t;
+    mutable cur_size: int;
+    queue: 'a entry Queue.t;
+    mutable waiting: Taskq.t;
+    mutable reaper_state: reaper_state;
+  }
+
+(*
+  let configure c pool =
+    Option.iter (fun x -> pool.max_size <- x) Config.(get max_size c);
+    Option.iter (fun x -> pool.max_idle_size <- x) Config.(get max_idle_size c);
+    Option.iter (fun x -> pool.max_idle_age <- x) Config.(get max_idle_age c);
+    Option.iter (fun x -> pool.max_use_count <- x) Config.(get max_use_count c)
+*)
+
+  let create
+        ?(config = Caqti_pool_config.default)
+        ?(check = fun _ f -> f true)
+        ?(validate = fun _ -> Fiber.return true)
+        ?(log_src = default_log_src)
+        ~sw
+        ~stdenv
+        create free =
+    let max_size =
+      Config.(get max_size) config |> Option.value ~default:default_max_size in
+    let max_idle_size =
+      Config.(get max_idle_size) config |> Option.value ~default:max_size in
+    let max_idle_age =
+      Config.(get max_idle_age) config |> Option.value ~default:None in
+    let max_use_count =
+      Config.(get max_use_count) config |> Option.value ~default:(Some 100) in
+    assert (max_size > 0);
+    assert (max_size >= max_idle_size);
+    assert (Option.fold ~none:true ~some:(fun n -> n > 0) max_use_count);
+    {
+      stdenv; switch = sw;
+      create; free; check; validate; log_src;
+      max_idle_size; max_size; max_use_count; max_idle_age;
+      cur_size = 0;
+      queue = Queue.create ();
+      waiting = Taskq.empty;
+      reaper_state = Idle;
+      mutex = Mutex.create ();
+    }
+
+  let size pool = pool.cur_size (* TODO: atomic *)
+
+  let wait_lck ~priority pool =
+    let condition = Condition.create () in
+    pool.waiting <- Taskq.push Task.({priority; condition}) pool.waiting;
+    Condition.wait condition pool.mutex
+
+  let schedule_lck pool =
+    if not (Taskq.is_empty pool.waiting) then begin
+      let task, taskq = Taskq.pop_e pool.waiting in
+      pool.waiting <- taskq;
+      Task.wake task
+    end
+
+  let realloc pool =
+    let on_error () =
+      Mutex.lock pool.mutex >|= fun () ->
+      pool.cur_size <- pool.cur_size - 1;
+      schedule_lck pool;
+      Mutex.unlock pool.mutex
+    in
+    Fiber.cleanup
+      (fun () ->
+        pool.create () >>=
+        (function
+         | Ok resource ->
+            Fiber.return @@
+              Ok {resource; used_count = 0; used_latest = Mtime_clock.now ()}
+         | Error err ->
+            on_error () >|= fun () ->
+            Error err))
+      on_error
+
+  let rec acquire ~priority pool =
+    Mutex.lock pool.mutex >>= fun () ->
+    acquire_and_unlock ~priority pool
+  and acquire_and_unlock ~priority pool =
+    if Queue.is_empty pool.queue then begin
+      if pool.cur_size < pool.max_size then
+        begin
+          pool.cur_size <- pool.cur_size + 1;
+          Mutex.unlock pool.mutex;
+          realloc pool
+        end
+      else
+        begin
+          wait_lck ~priority pool >>= fun () ->
+          acquire_and_unlock ~priority pool
+        end
+    end else begin
+      let entry = Queue.take pool.queue in
+      Mutex.unlock pool.mutex;
+      pool.validate entry.resource >>= fun ok ->
+      if ok then
+        Fiber.return (Ok entry)
+      else
+        begin
+          Log.warn ~src:pool.log_src (fun f ->
+            f "Dropped pooled connection due to invalidation.") >>= fun () ->
+          realloc pool
+        end
+    end
+
+  let can_reuse_lck pool entry =
+    pool.cur_size <= pool.max_idle_size
+     && Option.fold ~none:true ~some:(fun n -> entry.used_count < n)
+          pool.max_use_count
+
+  let dispose_expiring_lck pool =
+    let rec process_queue_lck () =
+      (* We hold the lock and only release it while freeing resources, which
+       * means that some other operations may have been processed right before
+       * each recursive call. *)
+      (match Queue.peek_opt pool.queue, pool.max_idle_age with
+       | None, _ | _, None -> Fiber.return ()
+       | Some entry, Some max_idle_age ->
+          let now = Mtime_clock.now () in
+          (match Mtime.add_span entry.used_latest max_idle_age with
+           | None ->
+              Logs.warn ~src:pool.log_src (fun f -> f
+                "Cannot schedule pool expiration check due to \
+                 Mtime overflow.");
+              pool.reaper_state <- Idle;
+              Fiber.return ()
+           | Some expiry when Mtime.compare now expiry < 0 ->
+              let alarm =
+                Alarm.schedule
+                  ~sw:pool.switch ~stdenv:pool.stdenv
+                  expiry on_alarm
+              in
+              pool.reaper_state <- Waiting alarm;
+              Fiber.return ()
+           | Some _ ->
+              let entry = Queue.take pool.queue in
+              pool.cur_size <- pool.cur_size - 1;
+              Mutex.unlock pool.mutex;
+              pool.free entry.resource >>= fun () ->
+              Mutex.lock pool.mutex >>= fun () ->
+              assert (pool.reaper_state = Working);
+              process_queue_lck ()))
+    and on_alarm () =
+      async ~sw:pool.switch begin fun () ->
+        Mutex.lock pool.mutex >>= fun () ->
+        pool.reaper_state <- Working;
+        process_queue_lck () >|= fun () ->
+        Mutex.unlock pool.mutex
+      end
+    in
+    (match pool.reaper_state, pool.max_idle_age with
+     | Idle, None | Working, _ | Waiting _, Some _ ->
+        Fiber.return ()
+     | Idle, Some _ ->
+        pool.reaper_state <- Working;
+        process_queue_lck ()
+     | Waiting alarm, None ->
+        (* Not reachable unless live reconfiguration is implemented. *)
+        Alarm.unschedule alarm;
+        pool.reaper_state <- Idle;
+        Fiber.return ())
+
+  let release pool entry =
+    Mutex.lock pool.mutex >>= fun () ->
+    entry.used_count <- entry.used_count + 1;
+    if not (can_reuse_lck pool entry) then
+      begin
+        pool.cur_size <- pool.cur_size - 1;
+        Mutex.unlock pool.mutex;
+        pool.free entry.resource >>= fun () ->
+        Mutex.lock pool.mutex >|= fun () ->
+        schedule_lck pool;
+        Mutex.unlock pool.mutex
+      end
+    else
+      begin
+        Mutex.unlock pool.mutex;
+        (* TODO: Consider changing the signature of check to return a bool
+         * Fiber.t to avoid the async call. *)
+        pool.check entry.resource begin fun ok ->
+          async ~sw:pool.switch @@ fun () ->
+          Mutex.lock pool.mutex >>= fun () ->
+          begin
+            if ok then
+              begin
+                entry.used_latest <- Mtime_clock.now ();
+                Queue.add entry pool.queue;
+                dispose_expiring_lck pool
+              end
+            else
+              begin
+                Logs.warn ~src:pool.log_src (fun f ->
+                  f "Will not repool connection due to invalidation.");
+                pool.cur_size <- pool.cur_size - 1;
+                Fiber.return ()
+              end
+          end >|= fun () ->
+          schedule_lck pool;
+          Mutex.unlock pool.mutex
+        end;
+        Fiber.return ()
+      end
+
+  let use ?(priority = 0.0) f pool =
+    acquire ~priority pool >>=? fun entry ->
+    Fiber.finally
+      (fun () -> f entry.resource)
+      (fun () -> release pool entry)
+
+  let rec drain pool =
+    Mutex.lock pool.mutex >>= fun () ->
+    drain_and_unlock pool
+  and drain_and_unlock pool =
+    if pool.cur_size = 0 then
+      begin
+        (match pool.reaper_state with
+         | Idle | Working -> ()
+         | Waiting alarm ->
+            Alarm.unschedule alarm;
+            pool.reaper_state <- Idle);
+        Mutex.unlock pool.mutex;
+        Fiber.return ()
+      end
+    else
+      (match Queue.take_opt pool.queue with
+       | None ->
+          wait_lck ~priority:0.0 pool >>= fun () ->
+          drain_and_unlock pool
+       | Some entry ->
+          pool.cur_size <- pool.cur_size - 1;
+          Mutex.unlock pool.mutex;
+          pool.free entry.resource >>= fun () ->
+          drain pool)
+
+end
+
+module No_alarm = struct
+  type t = unit
+  let schedule ~sw:_ ~stdenv:_ _ _ = ()
+  let unschedule _ = ()
+end
+
+module Make_without_alarm (System : System_sig.CORE) = Make (System) (No_alarm)

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/pool.mli

@@ -0,0 +1,92 @@
+(* Copyright (C) 2014--2023  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.
+ *)
+
+(** Internal resource pool implementation. *)
+
+(** Scheduling taks in the future. *)
+module type ALARM = sig
+  type switch
+  type stdenv
+
+  type t
+  (** A handle for cancelling the alarm if supported. *)
+
+  val schedule :
+    sw: switch ->
+    stdenv: stdenv ->
+    Mtime.t -> (unit -> unit) -> t
+  (** If supported, [schedule ~sw ~stdenv time f] schedules [f] to be run
+      at [time] and returns a handle which can be used to {!unschedule} it.  The
+      caqti-blocking implementation does nothing.  The pool implementation using
+      it makes additional opportunistic calls to the handler.  This function
+      must insert a yield before running the function even if the delay is
+      non-positive. *)
+
+  val unschedule : t -> unit
+  (** Cancels the alarm if supported. This is only used for early clean-up, so
+      the implementation may choose to let it time out instead. *)
+end
+
+module type S = sig
+  type switch
+  type stdenv
+
+  include Caqti_pool_sig.S
+
+  val create :
+    ?config: Caqti_pool_config.t ->
+    ?check: ('a -> (bool -> unit) -> unit) ->
+    ?validate: ('a -> bool fiber) ->
+    ?log_src: Logs.Src.t ->
+    sw: switch ->
+    stdenv: stdenv ->
+    (unit -> ('a, 'e) result fiber) -> ('a -> unit fiber) ->
+    ('a, 'e) t
+  (** {b Internal:} [create alloc free] is a pool of resources allocated by
+      [alloc] and freed by [free]. This is primarily intended for implementing
+      the [connect_pool] functions.
+
+      @param max_size
+        The maximum number of allocated resources.
+
+      @param max_idle_size
+        The maximum number of resources to pool for later use. Defaults to
+        [max_size].
+
+      @param max_use_count
+        The maximum number of times to use a connection, or [None] for no limit.
+
+      @param check
+        A function used to check a resource after use.
+
+      @param validate
+        A function to check before use that a resource is still valid. *)
+end
+
+module Make
+  (System : System_sig.CORE)
+  (_ : ALARM
+    with type switch := System.Switch.t
+     and type stdenv := System.stdenv) :
+  S with type 'a fiber := 'a System.Fiber.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv
+
+module Make_without_alarm (System : System_sig.CORE) :
+  S with type 'a fiber := 'a System.Fiber.t
+     and type switch := System.Switch.t
+     and type stdenv := System.stdenv

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/request_cache.ml

@@ -0,0 +1,222 @@
+(* Copyright (C) 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.
+ *)
+
+[@@@alert "-caqti_private"]
+open Caqti_template
+
+module type S = sig
+  type elt
+  type t
+
+  val create : ?dynamic_capacity: int -> Dialect.t -> t
+
+  val find_and_promote : t -> ('a, 'b, 'm) Request.t -> elt option
+  val add : t -> ('a, 'b, 'm) Request.t -> elt -> unit
+  val remove_and_discard : t -> ('a, 'b, 'm) Request.t -> unit
+  val deallocate : t -> ('a, 'b, 'm) Request.t -> (elt * (unit -> unit)) option
+  val iter : (elt -> unit) -> t -> unit
+  val elements : t -> elt list
+  val trim : ?max_promote_count: int -> t -> elt list * (unit -> unit)
+  val clear_and_discard : t -> unit
+  val dynamic_weight : t -> int
+end
+
+module Key = struct
+
+  type t =
+    T : {
+      param_type: 'a Row_type.t;
+      row_type: 'b Row_type.t;
+      row_mult: 'm Row_mult.t;
+      query: Query.t;
+    } -> t
+
+  let create request dialect =
+    T {
+      param_type = Request.param_type request;
+      row_type = Request.row_type request;
+      row_mult = Request.row_mult request;
+      query = Request.query request dialect;
+    }
+
+  let equal (T k1) (T k2) =
+    Query.equal k1.query k2.query
+      && Row_type.unify k1.param_type k2.param_type <> None
+      && Row_type.unify k1.row_type k2.row_type <> None
+
+  let hash (T k) =
+    (* TODO: Consider also hashing over the types. *)
+    Query.hash k.query
+
+end
+
+let is_static request =
+  (match Request.prepare_policy request with
+   | Request.Direct ->
+      failwith "Prepare_cache must not be used with direct requests."
+   | Request.Dynamic -> false
+   | Request.Static -> true)
+
+module Make (Elt : Lru.Weighted) = struct
+
+  type elt = Elt.t
+
+  (* This module adds a weak pointer to the request template, so that we can
+   * promote the associated prepare query in the LRU cache if the request has
+   * not been garbage collected.  To avoid extra engineering with limited
+   * gain, we only track the first request producing a certain key.  This seems
+   * better than tracking the latest request in the case there are a mixture of
+   * short- and long-lived request, since it gives longer lived requests a
+   * better chance of holding on to the liveness slot. *)
+  module Dynamic_node = struct
+    type t = {
+      elt: Elt.t;
+      liveness_witness: Request.liveness_witness Weak.t;
+    }
+
+    let create request elt =
+      let liveness_witness = Weak.create 1 in
+      Weak.set liveness_witness 0 (Some (Request.liveness_witness request));
+      {elt; liveness_witness}
+
+    let is_alive node = Weak.check node.liveness_witness 0
+
+    let elt node = node.elt
+
+    let weight node = Elt.weight node.elt
+  end
+
+  module Static_cache = Hashtbl.Make (Key)
+  module Dynamic_cache = Lru.M.Make (Key) (Dynamic_node)
+
+  type t = {
+    dialect: Caqti_template.Dialect.t;
+    static_cache: Elt.t Static_cache.t;
+    dynamic_cache: Dynamic_cache.t;
+    mutable dynamic_orphans: Elt.t list;
+  }
+
+  let create ?(dynamic_capacity = 20) dialect = {
+    dialect;
+    static_cache = Static_cache.create 11;
+    dynamic_cache = Dynamic_cache.create dynamic_capacity;
+    dynamic_orphans = [];
+  }
+
+  let find_and_promote cache request =
+    let key = Key.create request cache.dialect in
+    if is_static request then
+      (* Try the static map first, then the dynamic map.  If found in the
+       * latter, move the binding to the former, since we have a witness of the
+       * static lifetime of the associated prepared query. *)
+      (match Static_cache.find_opt cache.static_cache key with
+       | None ->
+          (match Dynamic_cache.find key cache.dynamic_cache with
+           | None -> None
+           | Some node ->
+              let elt = Dynamic_node.elt node in
+              Static_cache.add cache.static_cache key elt;
+              Dynamic_cache.remove key cache.dynamic_cache;
+              Some elt)
+       | Some elt -> Some elt)
+    else
+      (* Try the dynamic map first, then the static map. *)
+      (match Dynamic_cache.find key cache.dynamic_cache with
+       | None ->
+          Static_cache.find_opt cache.static_cache key
+       | Some node ->
+          Dynamic_cache.promote key cache.dynamic_cache;
+          Some (Dynamic_node.elt node))
+
+  let rec trim' ~max_promote_count cache =
+    let cap = Dynamic_cache.capacity cache.dynamic_cache in
+    if Dynamic_cache.weight cache.dynamic_cache > cap then
+      (match Dynamic_cache.lru cache.dynamic_cache with
+       | None -> assert false
+       | Some (key, node) when Dynamic_node.is_alive node ->
+          if max_promote_count > 0 then
+            begin
+              Dynamic_cache.promote key cache.dynamic_cache;
+              trim' ~max_promote_count:(max_promote_count - 1) cache
+            end
+       | Some (_, node) ->
+          cache.dynamic_orphans <- node.elt :: cache.dynamic_orphans;
+          Dynamic_cache.drop_lru cache.dynamic_cache;
+          trim' ~max_promote_count cache)
+
+  let trim ?(max_promote_count = 1) cache =
+    trim' ~max_promote_count cache;
+    (cache.dynamic_orphans, (fun () -> cache.dynamic_orphans <- []))
+
+  let add cache request elt =
+    trim' ~max_promote_count:0 cache;
+    let key = Key.create request cache.dialect in
+    assert (not (Static_cache.mem cache.static_cache key));
+    assert (not (Dynamic_cache.mem key cache.dynamic_cache));
+    if is_static request then
+      Static_cache.add cache.static_cache key elt
+    else
+      let node = Dynamic_node.create request elt in
+      Dynamic_cache.add key node cache.dynamic_cache
+
+  let remove_and_discard cache request =
+    let key = Key.create request cache.dialect in
+    if is_static request then
+      begin
+        assert (Static_cache.mem cache.static_cache key);
+        Static_cache.remove cache.static_cache key
+      end
+    else
+      begin
+        assert (Dynamic_cache.mem key cache.dynamic_cache);
+        Dynamic_cache.remove key cache.dynamic_cache
+      end
+
+  let deallocate cache request =
+    let key = Key.create request cache.dialect in
+    if is_static request then
+      (match Static_cache.find_opt cache.static_cache key with
+       | None -> None
+       | Some elt ->
+          let commit () = Static_cache.remove cache.static_cache key in
+          Some (elt, commit))
+    else
+      (match Dynamic_cache.find key cache.dynamic_cache with
+       | None -> None
+       | Some node ->
+          let commit () = Dynamic_cache.remove key cache.dynamic_cache in
+          Some (node.elt, commit))
+
+  let iter f cache =
+    Static_cache.iter (Fun.const f) cache.static_cache;
+    Dynamic_cache.iter (fun _ node -> f node.elt) cache.dynamic_cache
+
+  let elements cache =
+    let add_static _ elt acc = elt :: acc in
+    let add_dynamic _ node acc = node.Dynamic_node.elt :: acc in
+    [] |> Static_cache.fold add_static cache.static_cache
+       |> Fun.flip (Dynamic_cache.fold add_dynamic) cache.dynamic_cache
+
+  let clear_and_discard cache =
+    Static_cache.clear cache.static_cache;
+    let cap = Dynamic_cache.capacity cache.dynamic_cache in
+    Dynamic_cache.resize 0 cache.dynamic_cache;
+    Dynamic_cache.trim cache.dynamic_cache;
+    Dynamic_cache.resize cap cache.dynamic_cache
+
+  let dynamic_weight cache = Dynamic_cache.weight cache.dynamic_cache
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/request_cache.mli

@@ -0,0 +1,76 @@
+(* Copyright (C) 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.
+ *)
+
+(** Cache for associating data to requests for a fixed dialect. *)
+
+module type S = sig
+  type elt
+  type t
+
+  val create : ?dynamic_capacity: int -> Caqti_template.Dialect.t -> t
+  (** [create dialect] creates a cache of prepared queries for requests
+      specialized for [dialect].
+
+      @param dynamic_capacity
+        is the sum weight of elements of the LRU used for dynamic requests below
+        which {!trim} will not attempt to release anything. *)
+
+  val find_and_promote :
+    t -> ('a, 'b, 'm) Caqti_template.Request.t -> elt option
+  (** [find_and_promote cache request] promotes and returns the data associated
+      with [request] in [cache], if any. *)
+
+  val add : t -> ('a, 'b, 'm) Caqti_template.Request.t -> elt -> unit
+  (** Given the hard precondition that [request] is not bound in [cache], as
+      verified by {!find_and_promote}, [add cache request data] binds it to
+      [data]. *)
+
+  val remove_and_discard : t -> ('a, 'b, 'm) Caqti_template.Request.t -> unit
+  (** [remove_and_discard cache request] removes the binding for [request] from
+      [cache]. The caller is assumed to have just extracted the element with
+      {!find_and_promote} and is resposible for releasing related resources. *)
+
+  val deallocate :
+    t -> ('a, 'b, 'm) Caqti_template.Request.t -> (elt * (unit -> unit)) option
+  (** [deallocate request] returns the entry for [request], if any, along with a
+      function to remove it from the cache. *)
+
+  val iter : (elt -> unit) -> t -> unit
+  (** [iter f cache] calls [f] on each element of [cache]. *)
+
+  val elements : t -> elt list
+  (** [elements cache] is an arbitrarily ordered list of all elements, whether
+      associated with a static or dynamic request. *)
+
+  val trim : ?max_promote_count: int -> t -> elt list * (unit -> unit)
+  (** [trim ?promote_count cache] carrious out some work trimming elements from
+      the dynamic LRU cache.
+      The call promotes up to [max_promote_count] elements, which are alive
+      according to the garbage collector, and stop at the next one.
+      It is up to the caller to free any resources associated with the returned
+      elements. *)
+
+  val clear_and_discard : t -> unit
+  (** [clear cache] removes all entries form [cache].  Elements are not
+      returned, since this function may be used after a connection reset which
+      invalidates the cached resources, but can be requested by calling
+      {!elements} first. *)
+
+  val dynamic_weight : t -> int
+end
+
+module Make : functor (Elt : Lru.Weighted) -> S with type elt = Elt.t

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/request_utils.ml

@@ -0,0 +1,240 @@
+(* Copyright (C) 2017--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_template
+
+let (%>) f g x = g (f x)
+
+let empty_subst _ = raise Not_found
+
+type linear_param =
+  Linear_param : int * 'a Field_type.t * 'a -> linear_param
+
+let linear_param_length ?(subst = empty_subst) templ =
+  let templ = Query.expand subst templ in
+  let rec loop : Query.t -> int -> int = function
+   | L _ -> Fun.id
+   | V (_, _) -> succ
+   | Q _ -> succ
+   | P _ -> succ
+   | E _ -> assert false
+   | S frags -> List_ext.fold loop frags
+  in
+  loop templ 0
+
+let nonlinear_param_length ?(subst = empty_subst) templ =
+  let templ = Query.expand subst templ in
+  let rec loop : Query.t -> int -> int = function
+   | L _ -> Fun.id
+   | V _ -> Fun.id
+   | Q _ -> Fun.id
+   | P n -> max (n + 1)
+   | E _ -> assert false
+   | S frags -> List_ext.fold loop frags
+  in
+  loop templ 0
+
+let linear_param_order ?(subst = empty_subst) templ =
+  let templ = Query.expand subst templ in
+  let a = Array.make (nonlinear_param_length templ) [] in
+  let rec loop : Query.t -> _ -> _ = function
+   | L _ -> Fun.id
+   | V (t, v) ->
+      fun (j, params) ->
+        (j + 1, Linear_param (j, t, v) :: params)
+   | Q s ->
+      fun (j, params) ->
+        (j + 1, Linear_param (j, Field_type.String, s) :: params)
+   | P i -> fun (j, params) -> a.(i) <- j :: a.(i); (j + 1, params)
+   | E _ -> assert false
+   | S frags -> List_ext.fold loop frags
+  in
+  let _, params = loop templ (0, []) in
+  (Array.to_list a, List.rev params)
+
+let linear_query_string ?(subst = empty_subst) templ =
+  let templ = Query.expand subst templ in
+  let buf = Buffer.create 64 in
+  let rec loop : Query.t -> unit = function
+   | L s -> Buffer.add_string buf s
+   | Q _ | V _ | P _ -> Buffer.add_char buf '?'
+   | E _ -> assert false
+   | S frags -> List.iter loop frags
+  in
+  loop templ;
+  Buffer.contents buf
+
+let raise_encode_missing ~uri ~field_type () =
+  raise (Caqti_error.Exn (Caqti_error.encode_missing ~uri ~field_type ()))
+let raise_encode_rejected ~uri ~typ msg =
+  raise (Caqti_error.Exn (Caqti_error.encode_rejected ~uri ~typ msg))
+let raise_encode_failed ~uri ~typ msg =
+  raise (Caqti_error.Exn (Caqti_error.encode_failed ~uri ~typ msg))
+let raise_decode_missing ~uri ~field_type () =
+  raise (Caqti_error.Exn (Caqti_error.decode_missing ~uri ~field_type ()))
+let raise_decode_rejected ~uri ~typ msg =
+  raise (Caqti_error.Exn (Caqti_error.decode_rejected ~uri ~typ msg))
+let raise_response_failed ~uri ~query msg =
+  raise (Caqti_error.Exn (Caqti_error.response_failed ~uri ~query msg))
+let raise_response_rejected ~uri ~query msg =
+  raise (Caqti_error.Exn (Caqti_error.response_rejected ~uri ~query msg))
+
+type 'a field_encoder = {
+  write_value: 'b. uri: Uri.t -> 'b Field_type.t -> 'b -> 'a -> 'a;
+  write_null: 'b. uri: Uri.t -> 'b Field_type.t -> 'a -> 'a;
+}
+constraint 'e = [> `Encode_rejected of Caqti_error.coding_error]
+
+let rec encode_null_param : type a. uri: _ -> _ -> a Row_type.t -> _ =
+  fun ~uri f ->
+  (function
+   | Field ft -> f.write_null ~uri ft
+   | Option t -> encode_null_param ~uri f t
+   | Product (_, ts) -> encode_null_param_of_product ~uri f ts
+   | Annot (_, t) -> encode_null_param ~uri f t)
+and encode_null_param_of_product
+  : type a i. uri: _ -> _ -> (i, a) Row_type.product -> _  =
+  fun ~uri f ->
+  (function
+   | Proj_end -> Fun.id
+   | Proj (t, _, ts) ->
+      encode_null_param ~uri f t %>
+      encode_null_param_of_product ~uri f ts)
+
+let reject_encode ~uri ~typ msg =
+  let msg = Caqti_error.Msg msg in
+  raise_encode_rejected ~uri ~typ msg
+
+let rec encode_param
+  : type a. uri: _ -> _ -> a Row_type.t -> a -> 'b -> 'b =
+  fun ~uri f typ ->
+  (match typ with
+   | Field ft ->
+      (try f.write_value ~uri ft with
+       | Row_type.Reject msg -> reject_encode ~uri ~typ msg)
+   | Option t ->
+      let encode_none = encode_null_param ~uri f t in
+      let encode_some = encode_param ~uri f t in
+      (function None -> encode_none | Some x -> encode_some x)
+   | Product (_, ts) ->
+      (try encode_param_of_product ~uri f ts with
+       | Row_type.Reject msg -> reject_encode ~uri ~typ msg)
+   | Annot (_, t) -> encode_param ~uri f t)
+and encode_param_of_product
+  : type a i. uri: _ -> _ -> (i, a) Row_type.product -> a -> 'b -> 'b =
+  fun ~uri f ->
+  (function
+   | Proj_end -> fun _ acc -> acc
+   | Proj (t, p, ts) ->
+      let encode_t = encode_param ~uri f t in
+      let encode_ts = encode_param_of_product ~uri f ts in
+      fun x acc -> encode_t (p x) acc |> encode_ts x)
+
+type 'a field_decoder = {
+  read_value: 'b. uri: Uri.t -> 'b Field_type.t -> 'a -> 'b * 'a;
+  skip_null: int -> 'a -> 'a option;
+}
+constraint 'e = [> `Decode_rejected of Caqti_error.coding_error]
+
+let reject_decode ~uri ~typ msg =
+  let msg = Caqti_error.Msg msg in
+  raise_decode_rejected ~uri ~typ msg
+
+let rec decode_row : type a. uri: _ -> _ -> a Row_type.t -> 'b -> a * 'b =
+  fun ~uri f typ ->
+  (match typ with
+   | Field ft ->
+      f.read_value ~uri ft
+   | Option t ->
+      let decode_t = decode_row ~uri f t in
+      let skip_null = f.skip_null (Row_type.length t) in
+      fun acc ->
+        (match skip_null acc with
+         | Some acc -> (None, acc)
+         | None ->
+            let x, acc = decode_t acc in
+            (Some x, acc))
+   | Product ({construct; _}, Proj_end) ->
+      fun acc ->
+        (match construct with
+         | Ok y -> (y, acc)
+         | Error msg -> reject_decode ~uri ~typ msg)
+   | Product ({construct; _}, Proj (t1, _, Proj (t2, _, Proj_end))) ->
+      (* Optimization *)
+      let decode_t1 = decode_row ~uri f t1 in
+      let decode_t2 = decode_row ~uri f t2 in
+      fun acc ->
+        let x1, acc = decode_t1 acc in
+        let x2, acc = decode_t2 acc in
+        (match construct x1 x2 with
+         | Ok y -> (y, acc)
+         | Error msg -> reject_decode ~uri ~typ msg
+         | exception Row_type.Reject msg -> reject_decode ~uri ~typ msg)
+   | Product ({construct; _},
+        Proj (t1, _, Proj (t2, _, Proj (t3, _, Proj_end)))) ->
+      (* Optimization *)
+      let decode_t1 = decode_row ~uri f t1 in
+      let decode_t2 = decode_row ~uri f t2 in
+      let decode_t3 = decode_row ~uri f t3 in
+      fun acc ->
+        let x1, acc = decode_t1 acc in
+        let x2, acc = decode_t2 acc in
+        let x3, acc = decode_t3 acc in
+        (match construct x1 x2 x3 with
+         | Ok y -> (y, acc)
+         | Error msg -> reject_decode ~uri ~typ msg
+         | exception Row_type.Reject msg -> reject_decode ~uri ~typ msg)
+   | Product ({construct; _},
+        Proj (t1, _, Proj (t2, _, Proj (t3, _, Proj (t4, _, Proj_end))))) ->
+      (* Optimization *)
+      let decode_t1 = decode_row ~uri f t1 in
+      let decode_t2 = decode_row ~uri f t2 in
+      let decode_t3 = decode_row ~uri f t3 in
+      let decode_t4 = decode_row ~uri f t4 in
+      fun acc ->
+        let x1, acc = decode_t1 acc in
+        let x2, acc = decode_t2 acc in
+        let x3, acc = decode_t3 acc in
+        let x4, acc = decode_t4 acc in
+        (match construct x1 x2 x3 x4 with
+         | Ok y -> (y, acc)
+         | Error msg -> reject_decode ~uri ~typ msg
+         | exception Row_type.Reject msg -> reject_decode ~uri ~typ msg)
+   | Product ({construct; _}, ts) as typ ->
+      let rec loop
+        : type a i. (i, a) Row_type.product -> i -> _ -> a * _ =
+        (function
+         | Proj_end ->
+            fun construct acc ->
+              (match construct with
+               | Ok y -> (y, acc)
+               | Error msg -> reject_decode ~uri ~typ msg)
+         | Proj (t, _, ts) ->
+            let decode_t = decode_row ~uri f t in
+            let decode_ts = loop ts in
+            fun construct acc ->
+              let x, acc = decode_t acc in
+              decode_ts (construct x) acc)
+      in
+      (try loop ts construct with
+       | Row_type.Reject msg -> reject_decode ~uri ~typ msg)
+   | Annot (_, t0) ->
+      decode_row ~uri f t0)
+
+let fresh_name_generator prefix =
+  let c = ref 0 in
+  fun () -> incr c; Printf.sprintf "%s%d" prefix !c

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/request_utils.mli

@@ -0,0 +1,85 @@
+(* Copyright (C) 2017--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.
+ *)
+
+(** Internal request-related utilities. *)
+
+open Caqti_template
+
+(** {2 Queries} *)
+
+type linear_param =
+  Linear_param : int * 'a Field_type.t * 'a -> linear_param
+
+val linear_param_length : ?subst: Query.subst -> Query.t -> int
+(** [linear_param_length templ] is the number of linear parameters expected by a
+    query represented by [templ]. *)
+
+val linear_param_order :
+  ?subst: Query.subst -> Query.t -> int list list * linear_param list
+(** [linear_param_order templ] describes the parameter bindings expected for
+    [templ] after linearizing parameters and lifting quoted strings out of the
+    query:
+
+      - The first is a list where item number [i] is a list of linear parameter
+        positions to which to bind the [i]th incoming parameter.
+
+      - The second is a list of [Linear_param (i, t, v)] where [i] is the
+        position of the linear parameter taking the place of a embedded value,
+        [t] is its field type, and [v] is the value itself.
+
+    All positions are zero-based. *)
+
+val linear_query_string : ?subst: Query.subst -> Query.t -> string
+(** [linear_query_string templ] is [templ] where ["?"] is substituted for
+    parameters and quoted strings. *)
+
+(** {2 Parameter Encoding and Row Decoding} *)
+
+val raise_encode_missing :
+  uri: Uri.t -> field_type: 'a Field_type.t -> unit -> 'counit
+val raise_encode_rejected :
+  uri: Uri.t -> typ: 'a Row_type.t -> Caqti_error.msg -> 'counit
+val raise_encode_failed :
+  uri: Uri.t -> typ: 'a Row_type.t -> Caqti_error.msg -> 'counit
+val raise_decode_missing :
+  uri: Uri.t -> field_type: 'a Field_type.t -> unit -> 'counit
+val raise_decode_rejected :
+  uri: Uri.t -> typ: 'a Row_type.t -> Caqti_error.msg -> 'counit
+val raise_response_failed :
+  uri: Uri.t -> query: string -> Caqti_error.msg -> 'counit
+val raise_response_rejected :
+  uri: Uri.t -> query: string -> Caqti_error.msg -> 'counit
+
+type 'a field_encoder = {
+  write_value: 'b. uri: Uri.t -> 'b Field_type.t -> 'b -> 'a -> 'a;
+  write_null: 'b. uri: Uri.t -> 'b Field_type.t -> 'a -> 'a;
+}
+constraint 'e = [> `Encode_rejected of Caqti_error.coding_error]
+
+val encode_param :
+  uri: Uri.t -> 'a field_encoder -> 'b Row_type.t -> 'b -> 'a -> 'a
+
+type 'a field_decoder = {
+  read_value: 'b. uri: Uri.t -> 'b Field_type.t -> 'a -> 'b * 'a;
+  skip_null: int -> 'a -> 'a option;
+}
+constraint 'e = [> `Decode_rejected of Caqti_error.coding_error]
+
+val decode_row :
+  uri: Uri.t -> 'a field_decoder -> 'b Row_type.t -> 'a -> 'b * 'a
+
+val fresh_name_generator : string -> (unit -> string)

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/stream.ml

@@ -0,0 +1,84 @@
+(* Copyright (C) 2018--2019  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_stream_sig
+
+module type FIBER = sig
+  type +'a t
+
+  module Infix : sig
+    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+  end
+
+  val return : 'a -> 'a t
+end
+
+module Make(Fiber : FIBER) : S with type 'a fiber := 'a Fiber.t = struct
+  open Fiber.Infix
+
+  let (>>=?) res_future f =
+    res_future >>= function
+    | Ok a -> f a
+    | Error _ as r -> Fiber.return r
+
+  let (>|=?) res_future f =
+    res_future >>= function
+    | Ok a -> Fiber.return @@ Ok (f a)
+    | Error _ as r -> Fiber.return r
+
+  type ('a, 'err) t = unit -> ('a, 'err) node Fiber.t
+  and ('a, 'err) node =
+    | Nil
+    | Error of 'err
+    | Cons of 'a * ('a, 'err) t
+
+  let rec fold ~f t state =
+    t () >>= function
+    | Nil -> Fiber.return (Ok state)
+    | Error err -> Fiber.return (Error err : ('a, 'err) result)
+    | Cons (a, t') -> fold ~f t' (f a state)
+
+  let rec fold_s ~f t state =
+    t () >>= function
+    | Nil -> Fiber.return (Ok state)
+    | Error err -> Fiber.return (Error (`Congested err) : ('a, 'err) result)
+    | Cons (a, t') -> f a state >>=? fold_s ~f t'
+
+  let rec iter_s ~f t =
+    t () >>= function
+    | Nil -> Fiber.return (Ok ())
+    | Error err -> Fiber.return (Error (`Congested err) : ('a, 'err) result)
+    | Cons (a, t') -> f a >>=? fun () -> iter_s ~f t'
+
+  let to_rev_list t = fold ~f:List.cons t []
+
+  let to_list t = to_rev_list t >|=? List.rev
+
+  let rec of_list l =
+    fun () -> match l with
+    | [] -> Fiber.return Nil
+    | hd::tl -> Fiber.return (Cons (hd, (of_list tl)))
+
+  let rec map_result ~f xs () =
+    xs () >|= function
+     | Cons (x, xs') ->
+        (match f x with
+         | Result.Ok y -> Cons (y, map_result ~f xs')
+         | Result.Error e -> Error e)
+     | Nil | Error _ as r -> r
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/stream.mli

@@ -0,0 +1,33 @@
+(* Copyright (C) 2018--2019  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.
+ *)
+
+(** A stream with monadic concurrency and error handling. *)
+
+module type FIBER = sig
+  type +'a t
+
+  module Infix : sig
+    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+  end
+
+  val return : 'a -> 'a t
+end
+
+module Make (Fiber : FIBER) :
+  Caqti_stream_sig.S with type 'a fiber := 'a Fiber.t
+(** Constructs a stream for the provided concurrency monad. *)

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/switch.ml

@@ -0,0 +1,87 @@
+(* Copyright (C) 2023  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 type FIBER = sig
+  type 'a t
+
+  val return : 'a -> 'a t
+  module Infix : sig
+    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  end
+  val finally : (unit -> 'a t) -> (unit -> unit t) -> 'a t
+end
+
+module type S = sig
+  type 'a fiber
+  type t
+  type hook
+
+  exception Off
+
+  val eternal : t
+  val create : unit -> t
+  val release : t -> unit fiber
+  val run : (t -> 'a fiber) -> 'a fiber
+  val check : t -> unit
+  val on_release_cancellable : t -> (unit -> unit fiber) -> hook
+  val remove_hook : hook -> unit
+end
+
+module Make (Fiber : FIBER) = struct
+  open Fiber.Infix
+
+  type state =
+    | On of (unit -> unit Fiber.t) Lwt_dllist.t
+    | Off
+
+  type t =
+    | Eternal
+    | Ephemeral of {mutable state: state}
+
+  type hook = (unit -> unit Fiber.t) Lwt_dllist.node option
+
+  exception Off
+
+  let eternal = Eternal
+  let create () = Ephemeral {state = On (Lwt_dllist.create ())}
+
+  let release = function
+   | Eternal -> failwith "Tried to release eternal switch."
+   | Ephemeral {state = Off} -> Fiber.return ()
+   | Ephemeral ({state = On tasks} as arg) ->
+      let rec loop () =
+        if Lwt_dllist.is_empty tasks then Fiber.return (arg.state <- Off) else
+        Lwt_dllist.take_l tasks () >>= loop
+      in
+      loop ()
+
+  let run f =
+    let sw = create () in
+    Fiber.finally (fun () -> f sw) (fun () -> release sw)
+
+  let check = function
+   | Ephemeral {state = On _} | Eternal -> ()
+   | Ephemeral {state = Off} -> raise Off
+
+  let on_release_cancellable sw f =
+    (match sw with
+     | Eternal -> None
+     | Ephemeral {state = On tasks} -> Some (Lwt_dllist.add_l f tasks)
+     | Ephemeral {state = Off} -> raise Off)
+
+  let remove_hook hook = Option.iter Lwt_dllist.remove hook
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/switch.mli

@@ -0,0 +1,30 @@
+(* Copyright (C) 2023  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 type FIBER = sig
+  type 'a t
+
+  val return : 'a -> 'a t
+  module Infix : sig
+    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  end
+  val finally : (unit -> 'a t) -> (unit -> unit t) -> 'a t
+end
+
+module type S = Caqti_switch_sig.S
+
+module Make (Fiber : FIBER) : S with type 'a fiber := 'a Fiber.t

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/system_sig.ml

@@ -0,0 +1,206 @@
+(* Copyright (C) 2022--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.
+ *)
+
+(** Signature for concurrency model and OS-calls.
+
+    This is the common part of the signature declarning system dependencies.
+    Driver which depend on features from the unix library will also need
+    {!Caqti_platform_unix.System_sig.S}.
+  *)
+
+module type FIBER = sig
+
+  type +'a t
+  (** A concurrency monad with an optional failure monad, or just the identity
+      type constructor for blocking operation. *)
+
+  module Infix : sig
+
+    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    (** Bind operation of the concurrency monad. *)
+
+    val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+    (** Map operation of the concurrency monad. *)
+
+  end
+
+  val return : 'a -> 'a t
+  (** Return operation of the  concurrency monad. *)
+
+  val catch : (unit -> 'a t) -> (exn -> 'a t) -> 'a t
+
+  val finally : (unit -> 'a t) -> (unit -> unit t) -> 'a t
+  (** [finally f g] runs [f ()] and then runs [g ()] whether the former
+      finished, failed with an exception, or failed with a monadic failure. *)
+
+  val cleanup : (unit -> 'a t) -> (unit -> unit t) -> 'a t
+  (** [cleanup f g] runs [f ()] and then runs [g ()] and re-raise the failure if
+      and only if [f ()] failed with an exception or a monadic failure. *)
+end
+
+module type SEQUENCER = sig
+  type 'a fiber
+  type 'a t
+  val create : 'a -> 'a t
+  val enqueue : 'a t -> ('a -> 'b fiber) -> 'b fiber
+end
+
+module type CORE = sig
+  module Fiber : FIBER
+
+  type stdenv
+  (** Type of an extra argument to connect functions used to pass through the
+      network stack in Mirage and stdenv in EIO.  This is eliminated at the
+      service API where not needed. *)
+
+  (** A module used by EIO to handle cleanup tasks; unit for other platforms. *)
+  module Switch : sig
+    type t
+    type hook
+    val run : (t -> 'a Fiber.t) -> 'a Fiber.t
+    val check : t -> unit
+    val on_release_cancellable : t -> (unit -> unit Fiber.t) -> hook
+    val remove_hook : hook -> unit
+  end
+
+  val async : sw: Switch.t -> (unit -> unit Fiber.t) -> unit
+  (** [async f] runs [f ()] asynchroneously if possible, else immediately. *)
+
+  module Mutex : sig
+    type t
+    val create : unit -> t
+    val lock : t -> unit Fiber.t
+    val unlock : t -> unit
+  end
+
+  module Condition : sig
+    type t
+    val create : unit -> t
+    val wait : t -> Mutex.t -> unit Fiber.t
+    val signal : t -> unit
+  end
+
+  module Log : sig
+    type 'a log = ('a, unit Fiber.t) Logs.msgf -> unit Fiber.t
+    val err : ?src: Logs.src -> 'a log
+    val warn : ?src: Logs.src -> 'a log
+    val info : ?src: Logs.src -> 'a log
+    val debug : ?src: Logs.src -> 'a log
+  end
+
+  module Stream : Caqti_stream_sig.S with type 'a fiber := 'a Fiber.t
+
+  module Sequencer : SEQUENCER with type 'a fiber := 'a Fiber.t
+
+end
+
+module type SOCKET_OPS = sig
+  type 'a fiber
+  type t
+
+  (* These are currently only used by PGX.  Despite the flush, it PGX is doing
+   * it's own buffering, so unbuffered should be okay.  output_char and
+   * input_char are only used for the packet header. *)
+  val output_char : t -> char -> unit fiber
+  val output_string : t -> string -> unit fiber
+  val flush : t -> unit fiber
+  val input_char : t -> char fiber
+  val really_input : t -> Bytes.t -> int -> int -> unit fiber
+  val close : t -> unit fiber
+end
+
+module type TLS_PROVIDER = sig
+  type 'a fiber
+  type tcp_flow
+  type tls_flow
+
+  type tls_config
+  val tls_config_key : tls_config option Caqti_connect_config.key
+
+  val start_tls :
+    config: tls_config ->
+    ?host: [`host] Domain_name.t ->
+    tcp_flow -> (tls_flow, Caqti_error.msg) result fiber
+end
+
+module type NET = sig
+  type 'a fiber
+  type switch
+  type stdenv
+
+  module Sockaddr : sig
+    type t
+    val unix : string -> t
+    val tcp : Ipaddr.t * int -> t
+  end
+
+  val getaddrinfo :
+    stdenv: stdenv -> [`host] Domain_name.t -> int ->
+    (Sockaddr.t list, [> `Msg of string]) result fiber
+  (** This should be a specialized version of getaddrinfo, which only returns
+      entries which is expected to work with the corresponding connect on the
+      platform implementing this interface.  In particular:
+
+        - The family can be IPv4 or IPv6, where supported, and this must be
+          encoded in the {!Sockaddr.t}.
+        - The socket type is restricted to STREAM.
+        - The protocol is assumed to be selected automatically from address
+          family, given the socket type restriction.
+
+      All returned values are TCP destinations.  If a distinction can be made,
+      an empty list indicates that the address has no DNS entries, while an
+      error return indicates that an appropriate DNS server could not be
+      queried. *)
+
+  val convert_io_exception : exn -> Caqti_error.msg option
+  (** If the read and write operations in Socket raise exceptions other than
+      {!End_of_file} and {!Failure}, this function is used to intercept them. *)
+
+  (** A socket with input and output channels and dedicated IO functions.  This
+      bundling is done to support the various APIs involved for networking and
+      StartTLS. *)
+  module Socket : SOCKET_OPS with type 'a fiber := 'a fiber
+
+  type tcp_flow
+  type tls_flow
+
+  val connect_tcp :
+    sw: switch -> stdenv: stdenv -> Sockaddr.t ->
+    (Socket.t, Caqti_error.msg) result fiber
+
+  val tcp_flow_of_socket : Socket.t -> tcp_flow option
+  val socket_of_tls_flow : sw: switch -> tls_flow -> Socket.t
+
+  module type TLS_PROVIDER = TLS_PROVIDER
+    with type 'a fiber := 'a fiber
+     and type tcp_flow := tcp_flow
+     and type tls_flow := tls_flow
+
+  val register_tls_provider : (module TLS_PROVIDER) -> unit
+
+  val tls_providers : Caqti_connect_config.t -> (module TLS_PROVIDER) list
+
+end
+
+module type S = sig
+  include CORE
+
+  module Net : NET
+    with type 'a fiber := 'a Fiber.t
+     and type switch := Switch.t
+     and type stdenv := stdenv
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/system_utils.ml

@@ -0,0 +1,31 @@
+(* Copyright (C) 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 Monad_syntax (Monad : System_sig.FIBER) = struct
+  open Monad.Infix
+
+  let ( let* ) = (>>=)
+  let ( let+ ) = (>|=)
+
+  let ( >>=? ) m f =
+    m >>= function Ok x -> f x | Error _ as r -> Monad.return r
+  let ( >|=? ) m f =
+    m >|= function Ok x -> Ok (f x) | Error _ as r -> r
+
+  let ( let*? ) = ( >>=? )
+  let ( let+? ) = ( >|=? )
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-platform/system_utils.mli

@@ -0,0 +1,36 @@
+(* Copyright (C) 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 Monad_syntax (Monad : System_sig.FIBER) : sig
+  open Monad
+
+  val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
+
+  val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
+
+  val ( >>=? ) :
+    ('a, 'e) result t -> ('a -> ('b, 'e) result t) -> ('b, 'e) result t
+
+  val ( >|=? ) :
+    ('a, 'e) result t -> ('a -> 'b) -> ('b, 'e) result t
+
+  val ( let*? ) :
+    ('a, 'e) result t -> ('a -> ('b, 'e) result t) -> ('b, 'e) result t
+
+  val ( let+? ) :
+    ('a, 'e) result t -> ('a -> 'b) -> ('b, 'e) result t
+end