unikernel/duniverse/ocaml-caqti/caqti/doc/dune

@@ -0,0 +1 @@
+(documentation (package caqti))

unikernel/duniverse/ocaml-caqti/caqti/doc/index.mld

@@ -0,0 +1,75 @@
+{0 caqti index}
+
+{1 Library caqti}
+
+This is classic API for Caqti, which mirrors the above libray and provides
+signatures, configurations, and a few other things for other Caqti packages.
+The plan in to uses wrapped module everywhere and to make some adjustments
+to the organization of modules.  You may continue to use this for now, as
+deprecation is posponed until the complete replacement is available.
+
+This library exposes the following toplevel modules:
+{!modules:
+    Caqti_connect_sig
+    Caqti_connection_sig
+    Caqti_driver_info
+    Caqti_error
+    Caqti_mult
+    Caqti_pool_config
+    Caqti_pool_sig
+    Caqti_query
+    Caqti_query_fmt
+    Caqti_request
+    Caqti_response_sig
+    Caqti_stream_sig
+    Caqti_switch_sig
+    Caqti_type
+    Caqti_type_sig
+}
+
+{1 Preview library caqti.template}
+
+For now, {b this library is provides as a preview only.  The interface will
+change in incompatible ways} before it's declared ready for usage in
+production code.
+
+This library provides the interface to create templates for requests to send
+to the database.  A request template essentially combines a parametrised
+query string with a parameter encoder and a row decoder, and can often be
+defined statically.  Execution of queries are handled by other packages,
+depending on your preferred concurrency and OS libraries.
+
+The entry point of this library is the module:
+{!module-Caqti_template}
+
+{1 Library caqti.blocking}
+
+This library implements the blocking (non-)concurrency using the unix library.
+Real concurrency support is provided by separate packages.
+
+The entry point of this library is the module:
+{!module-Caqti_blocking}.
+
+{1 Library caqti.plugin}
+
+This library registers a dynamic linker based on the dune-site.plugin
+library, which allows Caqti to automatically load driver libraries inferred
+from the URI when connecting to a new kind of database for the first time.
+It has entry point; linking aganist it provides all of its functionality.
+
+
+{1 Platform Libraries for Internal Use}
+
+The platform libraries are only meant for use in implementing drivers and
+concurrency support.  {b These APIs are unstable}, i.e. they can change between
+minor versions and without prior deprecation notices.
+
+{2 Library caqti.platform}
+
+The entry point of this library is the module:
+{!module-Caqti_platform}.
+
+{2 Library caqti.platform.unix}
+
+The entry point of this library is the module:
+{!module-Caqti_platform_unix}.

unikernel/duniverse/ocaml-caqti/caqti/doc/query_template.mld

@@ -0,0 +1,98 @@
+{1 The Syntax of Query Templates}
+
+In order to help even out common difference between database systems and
+provide additional features, Caqti uses a lightweight template syntax parsed
+into the internal form {!Caqti_query.t} by the
+{!Caqti_query.angstrom_parser} and related utility functions.  Query strings
+are written almost as you expect them to be sent to the database, but with
+some in-text special syntax.
+
+{2 Semicolon and End-of-Input}
+
+The {!Caqti_query.t} type represents a single statement. To allow reading
+statements from a script file and sending them to database one by one, the
+parser will stop at the first {{!quotes} unquoted} semicolon, as well as at
+the end of input.  The semicolon itself will not be parsed, but you can
+create your own parser from the {!Caqti_query.angstrom_parser} which does.
+
+{2 Parameter References}
+
+Parameters are specified as either
+
+  - ["?"] for linear substitutions (like Sqlite and MariaDB), or
+  - ["$1"], ["$2"], ... for non-linear substitutions (like PostgreSQL).
+
+Either case works independent of the style used by the database system; if
+non-linear substitutions are used with a database system which does not
+support it, the parameter values will be reorderd and duplicated as needed.
+Mixing the two styles in the same query string is not permitted.  Note that
+numbering of non-linear parameters is offset by one compared to
+{!Caqti_query.P}, in order to be consistent with PostgreSQL conventions.
+
+The following characters are not permitted immediately after a [?]
+reference:
+{[
+    'A'..'Z' | 'a'..'z' | '0'..'9' | '_'
+  | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '.' | ':'
+  | '<' | '=' | '>' | '?' | '@' | '^' | '`' | '|' | '~'
+]}
+
+{!quotes} are not scanned for parameter references, to avoid accidental
+transformation of string literals within query strings.
+
+{2 Environment References}
+
+Functions processing queries take an [?env] argument which provides
+substitutions for the references which can have one of the following
+syntaxes:
+
+  - ["$(<var>)"] is substituted by [env driver_info "<var>"].
+  - ["$(<var>.)"], if not found by the first rule, is substituted by
+    [env driver_info "<var>"] followed by a dot iff that result is nonempty.
+  - ["$<var>."] is a shortcut for ["$(<var>.)"].
+
+These aid in substituting configurable fragments into the queries, like
+database schemas or table names.  The forms involving a period are
+suggested for qualifying tables, sequences, and other database objects with
+the database schema.
+
+Environment references are not parsed inside quotes, except for one kind;
+see {!quotes} for details.
+
+{2:quotes Quotes}
+
+In order to avoid accidental conversion of parameter references or undesired
+expansion of environment lookups, the parser recognizes several kinds of
+quotations used by database systems.  The following common kinds of
+quotations are recognized:
+
+  - ['<text>'] where ['] may be escapes as ['']
+  - ["<text>"] where ["] may be escaped as [""]
+  - [`<text>`] with no escape mechanism
+
+In addition the parser recognizes PostgreSQL style tagged quotations:
+
+  - [$<tag>$<text>$<tag>$] where the tag has the form of an identifier
+  - [$$<text>$$] as above but with an emtpy tag
+
+The former is treated like the other quotations, i.e. the text inside is
+passed on as-is.  In the latter form, environment references are expanded,
+while parameter references are not recognized.
+
+The motivation for this exception is that dollar quotes are often used in
+PostgreSQL schemas to define saved procedures, where it is useful to
+substitute schema names and possibly other code fragments.  On the other
+hand, the dollar quotes are useful for other purposes, and when a tag is
+provided, whether it is around a saved procedure or elsewhere, it is
+typically to avoid a clashes with dollar signs in the text.  Therefore, the
+exception to expand environment references is only made for the tagless
+variant of the dollar quotes.
+
+Note that nested quotes are not recognized inside [$$<text>$$], so
+substitutions apply unconditionally.  That is, the [$(x)] substring will
+
+  - in [SELECT '$(x)'] be interpreted literally due to the single quotes,
+    and
+  - in [$q$SELECT '$(x)'$q$] be interpreted literally due to the tagged
+    quotes, but will
+  - in [$$SELECT '$(x)'$$] be expanded.

unikernel/duniverse/ocaml-caqti/caqti/doc/tweaks.mld

@@ -0,0 +1,37 @@
+{1:tweaks Database Tweaks}
+
+{2 TL;DR}
+
+The [?tweaks_version] parameter tells Caqti drivers to enable all tweaks
+introduced up to and including the given major and minor version of Caqti.
+
+{2 The Tweaks Parameter}
+
+Occasionally Caqti makes changes to the database session parameters or
+otherwise how it interacts with specific database systems.  This may be done
+to improve consistency across databases, to make it easier to detect
+mistakes, to avoid obsolete behaviour, etc.  However, this can break
+backwards compatibility with applications, sometimes in subtle ways, which
+is the motivation for the [?tweaks_version] parameter of the connecting
+functions.
+
+Passing [~tweaks_version:(major_version, minor_verson)] declares that the
+application is compatible with all tweaks introduced up to and including
+that version of Caqti.  The default is to omit all tweaks introduced since
+the last major version.  On each major release, all tweaks up to that point
+becomes permanent and requesting an earlier tweaks version will have no
+effect.
+
+Production code should either omit the parameter or pass the largest major
+and minor version pair for which the code has been tested.  This offers the
+choice of adapting only on major versions or incrementally.
+
+Code in development can declare a progressive value, like the next major
+version, in order to always use the latest set of tweaks.
+
+{2 Current Tweaks}
+
+{3 Introduced with [(1, 8)] and later}
+
+  - SQLite3: Checking of foreign key constraints has been enabled by issuing
+    a [PRAGMA foreign_keys = ON] for the session.

unikernel/duniverse/ocaml-caqti/caqti/lib-blocking/caqti_blocking.ml

@@ -0,0 +1,195 @@
+(* Copyright (C) 2018--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Caqti_platform
+
+type Caqti_error.msg += Msg_unix of Unix.error * string * string
+
+let () =
+  let pp ppf = function
+   | Msg_unix (err, func, arg) ->
+      Format.fprintf ppf "%s in %s(%S)" (Unix.error_message err) func arg
+   | _ -> assert false
+  in
+  Caqti_error.define_msg ~pp [%extension_constructor Msg_unix]
+
+module Fiber = struct
+  type 'a t = 'a
+  module Infix = struct
+    let (>>=) x f = f x
+    let (>|=) x f = f x
+  end
+  let return x = x
+
+  let catch f g = try f () with exn -> g exn
+
+  let finally f g =
+    (match f () with
+     | y -> g (); y
+     | exception exn -> g (); raise exn)
+
+  let cleanup f g = try f () with exn -> g (); raise exn
+end
+
+module Stream = Caqti_platform.Stream.Make (Fiber)
+
+module System_core = struct
+  module Fiber = Fiber
+
+  module Switch = Caqti_platform.Switch.Make (Fiber)
+
+  let async ~sw:_ f = f ()
+
+  module Stream = Stream
+
+  module Mutex = Mutex
+
+  module Condition = Condition
+
+  module Log = struct
+    type 'a log = 'a Logs.log
+    let err ?(src = Logging.default_log_src) = Logs.err ~src
+    let warn ?(src = Logging.default_log_src) = Logs.warn ~src
+    let info ?(src = Logging.default_log_src) = Logs.info ~src
+    let debug ?(src = Logging.default_log_src) = Logs.debug ~src
+  end
+
+  type stdenv = unit
+
+  module Sequencer = struct
+    type 'a t = 'a
+    let create m = m
+    let enqueue m f = f m
+  end
+end
+
+module Pool = Caqti_platform.Pool.Make_without_alarm (System_core)
+
+module System = struct
+  include System_core
+
+  module Net = struct
+
+    module Sockaddr = struct
+      type t = Unix.sockaddr
+      let unix s = Unix.ADDR_UNIX s
+      let tcp (addr, port) =
+        Unix.ADDR_INET (Unix.inet_addr_of_string (Ipaddr.to_string addr), port)
+    end
+
+    let getaddrinfo ~stdenv:() host port =
+      try
+        let opts = Unix.[AI_SOCKTYPE SOCK_STREAM] in
+        Unix.getaddrinfo (Domain_name.to_string host) (string_of_int port) opts
+          |> List.map (fun ai -> ai.Unix.ai_addr) |> Result.ok
+      with
+       | Not_found -> Ok []
+       | Unix.Unix_error (code, _, _) ->
+          Error (`Msg ("Cannot resolve host name: " ^ Unix.error_message code))
+
+    let convert_io_exception = function
+     | Unix.Unix_error (err, fn, arg) -> Some (Msg_unix (err, fn, arg))
+     | _ -> None
+
+    module Socket = struct
+      type t = Tcp of in_channel * out_channel
+
+      let output_char (Tcp (_, oc)) = output_char oc
+      let output_string (Tcp (_, oc)) = output_string oc
+      let flush (Tcp (_, oc)) = flush oc
+      let input_char (Tcp (ic, _)) = input_char ic
+      let really_input (Tcp (ic, _)) = really_input ic
+      let close (Tcp (_, oc)) = close_out oc
+    end
+
+    type tcp_flow = Socket.t
+    type tls_flow = Socket.t
+
+    let connect_tcp ~sw:_ ~stdenv:() sockaddr =
+      try
+        let ic, oc = Unix.open_connection sockaddr in
+        Ok (Socket.Tcp (ic, oc))
+      with
+       | Unix.Unix_error (err, func, arg) -> Error (Msg_unix (err, func, arg))
+
+    let tcp_flow_of_socket _ = None
+    let socket_of_tls_flow ~sw:_ = Fun.id
+
+    module type TLS_PROVIDER = System_sig.TLS_PROVIDER
+      with type 'a fiber := 'a
+       and type tcp_flow := Socket.t
+       and type tls_flow := Socket.t
+
+    let tls_providers_r : (module TLS_PROVIDER) list ref = ref []
+
+    let register_tls_provider p = tls_providers_r := p :: !tls_providers_r
+
+    let tls_providers _ =
+      (* Try to load caqti-tls.unix here if/when implemented. *)
+      !tls_providers_r
+  end
+
+end
+
+module System_unix = struct
+
+  module Unix = struct
+    type file_descr = Unix.file_descr
+    let wrap_fd f fd = f fd
+    let poll ~stdenv:()
+             ?(read = false) ?(write = false) ?(timeout = -1.0) fd =
+      let read_fds = if read then [fd] else [] in
+      let write_fds = if write then [fd] else [] in
+      let read_fds, write_fds, _ = Unix.select read_fds write_fds [] timeout in
+      (read_fds <> [], write_fds <> [], read_fds = [] && write_fds = [])
+  end
+
+  module Preemptive = struct
+    let detach f x = f x
+    let run_in_main f = f ()
+  end
+
+end
+
+module Loader = Caqti_platform_unix.Driver_loader.Make (System) (System_unix)
+
+include Connector.Make (System) (Pool) (Loader)
+
+open System
+
+module type CONNECTION = Caqti_connection_sig.S
+  with type 'a fiber := 'a
+   and type ('a, 'e) stream := ('a, 'e) Stream.t
+
+type connection = (module CONNECTION)
+
+let connect ?subst ?env ?config ?tweaks_version uri =
+  let sw = Switch.create () in
+  connect ?subst ?env ?config ?tweaks_version ~sw ~stdenv:() uri
+
+let with_connection = with_connection ~stdenv:()
+
+let connect_pool
+      ?pool_config ?post_connect ?subst ?env ?config ?tweaks_version uri =
+  let sw = Switch.create () in
+  connect_pool
+    ?pool_config ?post_connect ?subst ?env ?config ?tweaks_version
+    ~sw ~stdenv:() uri
+
+let or_fail = function
+ | Ok x -> x
+ | Error (#Caqti_error.t as err) -> raise (Caqti_error.Exn err)

unikernel/duniverse/ocaml-caqti/caqti/lib-blocking/caqti_blocking.mli

@@ -0,0 +1,44 @@
+(* Copyright (C) 2018--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.
+ *)
+
+(** Blocking API based on the Unix module.
+
+    This module implements a blocking API.  It is not designed for preemptive
+    threading.  That is, connections and connection pools must be created and
+    used within a single thread, and any limitation on multithreading from the
+    driver or client library applies.
+
+    You can use a connection pool to cache a single DB connection, additional
+    connections will not be allocated, since usage is serial. *)
+
+module Stream : Caqti_stream_sig.S with type 'a fiber := 'a
+module Pool : Caqti_pool_sig.S with type 'a fiber := 'a
+
+module type CONNECTION = Caqti_connection_sig.S
+  with type 'a fiber := 'a
+   and type ('a, 'e) stream := ('a, 'e) Stream.t
+
+include Caqti_connect_sig.S
+  with type 'a fiber := 'a
+   and type 'a with_switch := 'a
+   and type 'a with_stdenv := 'a
+   and type ('a, 'e) stream := ('a, 'e) Stream.t
+   and type ('a, 'e) pool := ('a, 'e) Pool.t
+   and type connection = (module CONNECTION)
+
+val or_fail : ('a, [< Caqti_error.t]) result -> 'a
+(** Takes [Ok x] to [x] and raises {!Caqti_error.Exn}[ err] on [Error err]. *)

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

@@ -0,0 +1,8 @@
+(library
+ (name caqti_blocking)
+ (public_name caqti.blocking)
+ (libraries
+    caqti caqti.platform caqti.platform.unix
+    domain-name ipaddr
+    logs threads unix))
+  ; TODO: Can threads dependency be moved to drivers which need it?

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

@@ -0,0 +1,56 @@
+(* 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_FUNCTOR =
+  functor (System : Caqti_platform.System_sig.S) ->
+  functor (_ : System_sig.S
+    with type 'a fiber := 'a System.Fiber.t
+     and type stdenv := System.stdenv) ->
+  Caqti_platform.Driver_loader.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 Make
+  (System : Caqti_platform.System_sig.S)
+  (System_unix : System_sig.S
+    with type 'a fiber := 'a System.Fiber.t
+     and type stdenv := System.stdenv) =
+struct
+  module Core_loader = Caqti_platform.Driver_loader.Make (System)
+
+  module type DRIVER = Core_loader.DRIVER
+  module type CONNECTION = Core_loader.CONNECTION
+
+  let provides_unix = true
+
+  let find_and_apply' scheme =
+    (match Hashtbl.find_opt drivers scheme with
+     | None -> None
+     | Some (module F : DRIVER_FUNCTOR) ->
+        let module Driver = F (System) (System_unix) in
+        Some (module Driver : DRIVER))
+
+  let find_and_apply scheme =
+    (match Core_loader.find_and_apply scheme with
+     | Some _ as r -> r
+     | None -> find_and_apply' scheme)
+end

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

@@ -0,0 +1,52 @@
+(* Copyright (C) 2022--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.
+ *)
+
+(** Connection functor and registration for driver using the Unix module. *)
+
+(** {2 Registration} *)
+
+module type DRIVER_FUNCTOR =
+  functor (System : Caqti_platform.System_sig.S) ->
+  functor (_ : System_sig.S
+    with type 'a fiber := 'a System.Fiber.t
+     and type stdenv := System.stdenv) ->
+  Caqti_platform.Driver_loader.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 dependent on the unix library. *)
+
+val register : string -> (module DRIVER_FUNCTOR) -> unit
+(** [define_unix_driver scheme m] installs [m] as a handler for the URI scheme
+    [scheme].  This call must be done by a backend installed with findlib name
+    caqti-driver-{i scheme} as part of its initialization. *)
+
+(** {2 Usage} *)
+
+module Make
+    (System : Caqti_platform.System_sig.S)
+    (_ : System_sig.S
+      with type 'a fiber := 'a System.Fiber.t
+       and type stdenv := System.stdenv) :
+  Caqti_platform.Driver_loader.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
+(** Constructs the main module used to connect to a database for the given
+    concurrency model. *)

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

@@ -0,0 +1,4 @@
+(library
+ (name caqti_platform_unix)
+ (public_name caqti.platform.unix)
+ (libraries caqti caqti.platform unix))

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

@@ -0,0 +1,36 @@
+(* Copyright (C) 2022--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 S = sig
+  type 'a fiber
+  type stdenv
+
+  module Unix : sig
+    type file_descr
+    val wrap_fd : (file_descr -> 'a fiber) -> Unix.file_descr -> 'a fiber
+    val poll :
+      stdenv: stdenv ->
+      ?read: bool -> ?write: bool -> ?timeout: float ->
+      file_descr -> (bool * bool * bool) fiber
+  end
+
+  module Preemptive : sig
+    val detach : ('a -> 'b) -> 'a -> 'b fiber
+    val run_in_main : (unit -> 'a fiber) -> 'a
+  end
+
+end

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

unikernel/duniverse/ocaml-caqti/caqti/lib-plugin/caqti_plugin.ml

@@ -0,0 +1,33 @@
+(* Copyright (C) 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 Log = (val Logs.src_log (Logs.Src.create "caqti.plugin"))
+
+let () =
+  let load pkg =
+    let pkg = String.map (function '.' -> '-' | c -> c) pkg in
+    let plugins = Sites.Plugins.Plugins.list () in
+    Log.debug (fun p -> p "Available plugins: %s" (String.concat ", " plugins));
+    if List.mem pkg plugins then
+      begin
+        Sites.Plugins.Plugins.load pkg;
+        Ok ()
+      end
+    else
+      Error ("Package " ^ pkg ^ " is not avaliable.")
+  in
+  Caqti_platform.Connector.define_loader load

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

@@ -0,0 +1,9 @@
+(library
+ (name caqti_plugin)
+ (public_name caqti.plugin)
+ (library_flags (:standard -linkall))
+ (libraries caqti.platform dune-site dune-site.plugins))
+
+(generate_sites_module
+ (module sites)
+ (plugins (caqti plugins)))

unikernel/duniverse/ocaml-caqti/caqti/lib-template/caqti_template.ml

@@ -0,0 +1,100 @@
+(* Copyright (C) 2024--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 Constructor = Constructor
+module Dialect = Dialect
+module Field_type = Field_type
+module Query = Query
+module Query_fmt = Query_fmt
+module Request = Request
+module Row_mult = Row_mult
+module Row_type = Row_type
+module Row = Row
+module Shims = Shims
+module Version = Version
+
+module Type = struct
+  include (Row_type : Row_type.STD)
+  include Request_type.Infix
+end
+
+module type CREATE = sig
+
+  module T = Type
+
+  module D = Dialect
+  include module type of Version.Infix
+
+  module Q = Query
+  module Qf = Query_fmt
+  include module type of Query.Infix
+
+  val static :
+    ('a, 'b, 'm) Request_type.t -> string ->
+    ('a, 'b, 'm) Request.t
+
+  val static_gen :
+    ('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
+    ('a, 'b, 'm) Request.t
+
+  val dynamic :
+    ('a, 'b, 'm) Request_type.t -> string ->
+    ('a, 'b, 'm) Request.t
+
+  val dynamic_gen :
+    ('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
+    ('a, 'b, 'm) Request.t
+
+  val direct :
+    ('a, 'b, 'm) Request_type.t -> string ->
+    ('a, 'b, 'm) Request.t
+
+  val direct_gen :
+    ('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
+    ('a, 'b, 'm) Request.t
+end
+
+module Create = struct
+
+  module T = Type
+
+  module D = Dialect
+  include Version.Infix
+
+  module Q = Query
+  module Qf = Query_fmt
+  include Query.Infix
+
+  let static req_type qs =
+    Request.create Static req_type (Fun.const (Query.parse qs))
+
+  let static_gen req_type qf =
+    Request.create Static req_type qf
+
+  let dynamic req_type qs =
+    Request.create Dynamic req_type (Fun.const (Query.parse qs))
+
+  let dynamic_gen req_type qf =
+    Request.create Dynamic req_type qf
+
+  let direct req_type qs =
+    Request.create Direct req_type (Fun.const (Query.parse qs))
+
+  let direct_gen req_type qf =
+    Request.create Direct req_type qf
+
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-template/caqti_template.mli

@@ -0,0 +1,224 @@
+(* Copyright (C) 2024--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_unstable
+  "This library is a preview; expect incompatible changes without prior notice."]
+
+(** {2 Primitives}
+
+    These modules are part of the stable API, but the casual user may find it
+    sufficient to use the {!Create} module. *)
+
+(** {3 Prerequisities} *)
+
+module Shims = Shims
+module Version = Version
+module Dialect = Dialect
+
+(** {3 Data Types} *)
+
+module Constructor = Constructor
+module Field_type = Field_type
+module Row_type = Row_type
+module Row_mult = Row_mult
+module Row = Row
+
+module Type : sig
+  include Row_type.STD
+  include module type of Request_type.Infix
+end
+(** This module imports everything needed to describe a request type,
+    including the parameter type, row type, and row multiplicity. *)
+
+(** {3 Request Templates} *)
+
+module Query = Query
+module Query_fmt = Query_fmt
+module Request = Request
+
+(** {2 Convenience} *)
+
+module type CREATE = sig
+  (** This is a convenience API which collects everything needed to create
+      {{!Caqti_template.Request} request templates}.  A request template
+      describes a database query and how to encode parameters and decode the
+      result.
+
+      {1 Basic Usage}
+
+      Consider the example:
+      {[
+        let bounds_upto_req =
+          let open Caqti_template.Create in
+          static T.(t2 int32 float -->! option (t2 float float))
+          "SELECT min(y), max(y) FROM samples WHERE series_id = ? AND x < ?"
+      ]}
+      First we opening the current module.
+      We then pick the function {!static} to create a template for prepared
+      queries where the query template has static lifetime.
+      The first argument describes the parameter type and the result row type
+      combined with an arrow which describes the multiplicity of the result
+      rows.
+      The exclamation mark in the arrow indicates that precisely one result row
+      is expected.
+      The second argument is the query template, here in the form of a string.
+
+      In the query template, [?] refer to parameters, but you can also use the
+      [PostgreSQL]-style [$1], [$2], etc. if you prefer, as long as you stick to
+      the same convention for a given query template.  Caqti drivers translate
+      parameter references to fit the database system, rearranging parameters if
+      necessary.
+
+      Caqti provides a way to handle dialectical differences between database
+      systems apart from the parameter syntax.
+      The example above uses a shortcut, since it does not need this
+      functionality.
+      In the full form it looks like:
+      {[
+        let bounds_upto_req =
+          let open Caqti_template.Create in
+          static_gen
+            T.(t2 int32 float -->! option (t2 float float)) @@ Fun.const @@
+            Q.parse
+              "SELECT min(y), max(y) FROM samples WHERE series_id = ? AND x < ?"
+      ]}
+      The callback receives a {!Dialect.t} and returns a {!Query.t}.
+      We can now see that the still same query string is explicitly parsed.
+      {!Query} and {!Query_fmt} provides alternative ways of constructing query
+      template which is more suitable for dynamically generated queries.
+
+      The following example makes use of the dialect argument to handle
+      dialectical differences regarding string concatenation:
+      {[
+        let concat_req =
+          let open Caqti_template.Create in
+          static_gen T.(t2 string string -->! string) @@ function
+           | D.Mysql _ -> Q.parse "SELECT concat(?, ?)"
+           | _ -> Q.parse "SELECT ? || ?"
+      ]}
+      In summary
+
+        - Pick the main function according to the lifetime of prepared queries
+          and whether to use the simplified or generic callback.
+        - In the request type argument, the arrow decoration
+          selects the expected multiplicity of result rows:
+          [-->.] for zero, [-->!] for one, [-->?] for zero or one, [-->*] for
+          zero or more.
+
+      {1 Supplementing}
+
+      If needed, you can supplement the current module with custom types:
+      {[
+        module Ct : sig
+          open Caqti_template
+
+          include Caqti_template.CREATE
+
+          module T : sig
+            include module type of T
+
+            val password : string Row_type.t
+            val uri : Uri.t Row_type.t
+          end
+        end = struct
+          open Caqti_template
+
+          include Caqti_template.Create
+
+          module T = struct
+            include T
+
+            let password = redacted string (* a string redacted from logs *)
+
+            let uri =
+              let encode x = Ok (Uri.to_string x) in
+              let decode s = Ok (Uri.of_string s) in
+              Row_type.custom ~encode ~decode string
+          end
+        end
+      ]}
+  *)
+
+  (** {1 Reference} *)
+
+  (** {2 Type Descriptors} *)
+
+  module T = Type
+
+  (** {2 Dialect Descriptors} *)
+
+  module D = Dialect
+  include module type of Version.Infix
+
+  (** {2 Query Templates} *)
+
+  module Q = Query
+  module Qf = Query_fmt
+  include module type of Query.Infix
+
+  (** {2 Request Templates}
+
+      The following are shortcuts for {!Request.create} and {!Query.parse}
+      In particular {!static}, {!dynamic}, and {!direct} covers the most common
+      case of sending a pre-composed query string to the database while the
+      {!static_gen}, {!dynamic_gen}, and {!direct_gen} are the correspending
+      fully generic variants. *)
+
+  val static :
+    ('a, 'b, 'm) Request_type.t -> string ->
+    ('a, 'b, 'm) Request.t
+  (** Creates a template of static lifetime for prepared requests where the
+      query template is provided as a string to be parsed by {!Query.parse}. *)
+
+  val static_gen :
+    ('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
+    ('a, 'b, 'm) Request.t
+  (** Creates a template of static lifetime for prepared requests where the
+      query template is dialect-dependent and explicitly constructed by the
+      caller. *)
+
+  val dynamic :
+    ('a, 'b, 'm) Request_type.t -> string ->
+    ('a, 'b, 'm) Request.t
+  (** Creates a template of static lifetime for prepared requests where the
+      query template is provided as a string to be parsed by {!Query.parse}. *)
+
+  val dynamic_gen :
+    ('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
+    ('a, 'b, 'm) Request.t
+  (** Creates a template of static lifetime for prepared requests where the
+      query template is dialect-dependent and explicitly constructed by the
+      caller. *)
+
+  val direct :
+    ('a, 'b, 'm) Request_type.t -> string ->
+    ('a, 'b, 'm) Request.t
+  (** Creates a template for non-prepared requests where the query template is
+      provided as a string to be parsed by {!Query.parse}.
+      If non-prepared requests are not unsupported by the driver, a temporarily
+      prepared request is used instead. *)
+
+  val direct_gen :
+    ('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
+    ('a, 'b, 'm) Request.t
+  (** Creates a template for non-prepared requests where the query template is
+      dialect-dependent and explicitly constructed by the caller.
+      If non-prepared requests are not unsupported by the driver, a temporarily
+      prepared request is used instead. *)
+end
+
+module Create : CREATE

unikernel/duniverse/ocaml-caqti/caqti/lib-template/constructor.ml

@@ -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.
+ *)
+
+open Shims
+
+type 'a return = ('a, string) result
+
+type ('i, 'j) unifier =
+  | Equal : ('i return, 'i return) unifier
+  | Assume : (('a, 'b) Type.eq -> ('i, 'j) unifier) ->
+      ('a -> 'i, 'b -> 'j) unifier
+
+type (_, _) tag = ..
+
+type ('i, 'a) t = {
+  tag: ('i, 'a) tag;
+  unify_tag: 'j 'b. ('j, 'b) tag -> ('i, 'j) unifier option;
+  construct: 'i;
+}
+
+let unify : type i j a b. (i, a) t -> (j, b) t -> (i, j) unifier option =
+  fun x y -> x.unify_tag y.tag

unikernel/duniverse/ocaml-caqti/caqti/lib-template/constructor.mli

@@ -0,0 +1,165 @@
+(* 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.
+ *)
+
+(** Reified constructors for product row types.
+
+    Usage of this module is somewhat technical and only needed when defining
+    type descriptors for custom {e parametric} types, or if, for some other
+    reason, the type descriptor cannot be defined once statically.
+    For statically defined types, {!Row_type.product} can generate a descriptor
+    from the bare function.
+
+    This module bundles a bare constructor function with a fresh tag from an
+    open GADT, used to identify it along with its type.
+    The type may be parametric as long as parameters in the result type occurs
+    in argument types.
+
+    As an example, consider the record type:
+    {[
+      type 'a acquired_value = {
+        source: string;
+        value: 'a;
+        confidence: float;
+      }
+    ]}
+    A straight forward but not quite correct way to define a type descriptor for
+    each parametric instance of this type constructor would be:
+    {[
+      open Caqti_template
+      open Caqti_template.Shims
+
+      let acquired_value_rowtype value_rowtype =
+        let open Row_type in
+        product (fun source value confidence -> Ok {source; value; confidence})
+        @@ proj string (fun {source; _} -> source)
+        @@ proj value_rowtype (fun {value; _} -> value)
+        @@ proj float (fun {confidence; _} -> confidence)
+        @@ proj_end
+
+      let () =
+        let t1 = acquired_value_rowtype Row_type.int in
+        let t2 = acquired_value_rowtype Row_type.int in
+        assert (Row_type.unify t1 t2 = None) (* Bad! *)
+    ]}
+    The function [acquired_value_rowtype] is, however, generative; a fresh type
+    descriptor is returned for each call, even for identical arguments.
+    In particular, this means that {!Row_type.unify} will fail to unify two
+    descriptors describing the same type, unless they are physically equal.
+
+    The correct way of defining this descriptor is to use {!Row_type.product'},
+    which expects a constructor descriptor instead of a bare constructor
+    function.
+    This is the purpose of this module.
+    To create the custom descriptor, first define a {!type-tag} with correct
+    signature and a corresponding type-unifying equality predicate:
+    {[
+      type (_, _) Constructor.tag +=
+        Acquired_value : (
+          string -> 'a -> float -> 'a acquired_value Constructor.return,
+          'a acquired_value
+        ) Constructor.tag
+
+      let acquired_value_constructor =
+        let tag = Acquired_value in
+        let unify_tag
+          : type j b a. (j, b) Constructor.tag ->
+            (string -> a -> float -> a acquired_value Constructor.return, j)
+              Constructor.unifier option =
+          (function
+           | Acquired_value ->
+              Some (Constructor.Assume (fun Type.Equal ->
+                    Constructor.Assume (fun Type.Equal ->
+                    Constructor.Assume (fun Type.Equal -> Constructor.Equal))))
+           | _ -> None)
+        in
+        let construct source value confidence = Ok {source; value; confidence} in
+        {Constructor.tag; unify_tag; construct}
+    ]}
+    Our original attempt to define the descriptor can now be adjusted to support
+    parametricity:
+    {[
+      let acquired_value_rowtype value_rowtype =
+        let open Row_type in
+        product' acquired_value_constructor
+        @@ proj string (fun {source; _} -> source)
+        @@ proj value_rowtype (fun {value; _} -> value)
+        @@ proj float (fun {confidence; _} -> confidence)
+        @@ proj_end
+
+      let () =
+        let t1 = acquired_value_rowtype Row_type.int in
+        let t2 = acquired_value_rowtype Row_type.int in
+        assert (Row_type.unify t1 t2 <> None) (* Good! *)
+    ]} *)
+
+open Shims
+
+type 'a return = ('a, string) result
+(** The result type of a constructor function. *)
+
+type ('i, 'j) unifier =
+  | Equal : ('i return, 'i return) unifier
+  | Assume : (('a, 'b) Type.eq -> ('i, 'j) unifier) ->
+      ('a -> 'i, 'b -> 'j) unifier (**)
+(** [('i, 'j) unifier] witness that two constructors of types [('i, _) t] and
+    [('j, _) t] are equal, providing a dependent unification of ['i] and ['j] in
+    the following sense:
+
+      - ['i] and ['j] are constrained by this definition to have the shape of a
+        function which terminates in a {!result} type, like
+        ['a1 -> ... -> 'aN -> 'b return].
+      - For each constructor argument, a node [Assume f] is provided, where [f]
+        accepts an equality proof of the constructor argument and returns a
+        proof of the remaining constructor type.
+      - A final node [Equal] which, after resolving [Assume] nodes, witness that
+        constructed values have the same type.
+
+    By constraining the return type to a non-abstract non-function type, we
+    ensure that {!Equal}- and {!Assume}-patterns match disjoint types, so that
+    we can refute {!Equal} patterns when the type in question is known to be a
+    function type. *)
+
+type (_, _) tag = ..
+(** [('a1 -> ... -> 'aN -> 'r return, 'r) tag] represents the type of a
+    constructor which takes arguments of type ['a1], ..., ['aN] and returns
+    values of type ['r].
+    These tags is normally only passed around in the combination {!type-t}. *)
+
+type ('i, 'a) t = {
+  tag: ('i, 'a) tag;
+    (** The constructor type. *)
+  unify_tag: 'j 'b. ('j, 'b) tag -> ('i, 'j) unifier option;
+    (** Unifying equality for the constructor type. *)
+  construct: 'i;
+    (** The bare constructor function. *)
+}
+(** [('a1 -> ... -> 'aN -> 'r return, 'r) t] represents a constructor which
+    takes arguments of type ['a1], ..., ['aN] and constructs values of type
+    ['r].  The public record type is exposed to allow passing the {!unify_tag}
+    field in a way which preserves universal quantification.
+
+    This type is only a reification of the constructor to allow comparison,
+    disallowed for bare functions, and type unification.
+    Ideally the {!field-construct} field is unique, while {!field-tag} and
+    {!field-unify_tag} are implied by the type; the rest is technicalities which
+    could be handle by a PPX or other kind of code generator.  *)
+
+val unify : ('i, 'a) t -> ('j, 'b) t -> ('i, 'j) unifier option
+(** [unify t t'] is [Some witness] if [t] and [t'] are equal, otherwise [None].
+    In the former case, [witness] provides the unification of the result type of
+    the construction, provided the unifications of each constructor argument
+    type. *)

unikernel/duniverse/ocaml-caqti/caqti/lib-template/dialect.ml

@@ -0,0 +1,33 @@
+(* Copyright (C) 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.
+ *)
+
+type t = ..
+
+type t +=
+  | Pgsql of {
+      server_version: Version.t;
+      client_library: [`postgresql | `pgx];
+    }
+  | Mysql of {server_version: Version.t}
+  | Sqlite of {server_version: Version.t}
+  | Unknown of {purpose: [`Dummy | `Printing]}
+
+let create_pgsql ~server_version ~client_library () =
+  Pgsql {server_version; client_library}
+let create_mysql ~server_version () = Mysql {server_version}
+let create_sqlite ~server_version () = Sqlite {server_version}
+let create_unknown ~purpose () = Unknown {purpose}

unikernel/duniverse/ocaml-caqti/caqti/lib-template/dialect.mli

@@ -0,0 +1,69 @@
+(* Copyright (C) 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.
+ *)
+
+(** Identification of SQL Dialects and Related Information *)
+
+type t = ..
+(** This type identifies the SQL dialect and other differences which may be
+    relevant when composing query strings.  This is an open type to allow future
+    additions, either defined below or externally.  Each case has the form of a
+    constructor identifying the software which interprets the SQL code and its
+    version number, if available, followed by any backend-specific details. *)
+
+type t += private
+  | Pgsql of {
+      server_version: Version.t;
+      (** The version number of the server, currently only available when using
+          caqti-driver-postgresql. *)
+      client_library: [`postgresql | `pgx];
+      (** Which client library is being used to communicate with the server. *)
+    }
+    (** Identifies the backend as a PostgreSQL server. *)
+  | Mysql of {
+      server_version: Version.t;
+      (** The version number of the server, but curretly unavailable, awaiting
+          ocaml-mariadb support. *)
+    }
+    (** Identifies the backend as a MariaDB or MySQL server. No information is
+        currently provided about the variant and version. *)
+  | Sqlite of {
+      server_version: Version.t;
+      (** The version number of the Sqlite3 library. *)
+    }
+    (** Identifies the backend as an Sqlite3 library. *)
+  | Unknown of {
+      purpose: [`Dummy | `Printing];
+    }
+    (** The query is to be used for logging or other display purposes, and no
+        information is been provided about a potential SQL backend. *)
+
+(**/**)
+
+val create_pgsql :
+  server_version: Version.t ->
+  client_library: [`postgresql | `pgx] ->
+  unit -> t
+[@@alert caqti_private "Private function for used by Caqti drivers."]
+
+val create_mysql : server_version: Version.t -> unit -> t
+[@@alert caqti_private "Private function for used by Caqti drivers."]
+
+val create_sqlite : server_version: Version.t -> unit -> t
+[@@alert caqti_private "Private function for used by Caqti drivers."]
+
+val create_unknown : purpose: [`Dummy | `Printing] -> unit -> t
+[@@alert caqti_private "Private function for used by Caqti drivers."]

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

@@ -0,0 +1,34 @@
+(library
+ (name caqti_template)
+ (public_name caqti.template)
+ (libraries angstrom bigstringaf logs ptime uri))
+
+(rule
+ (target shims.mli)
+ (deps shims.5.1.mli)
+ (enabled_if (>= %{ocaml_version} 5.1))
+ (action (copy# %{deps} %{target})))
+
+(rule
+ (target shims.ml)
+ (deps shims.5.1.ml)
+ (enabled_if (>= %{ocaml_version} 5.1))
+ (action (copy# %{deps} %{target})))
+
+(rule
+ (target shims.mli)
+ (deps shims.fallback.mli)
+ (enabled_if (< %{ocaml_version} 5.1))
+ (action (copy# %{deps} %{target})))
+
+(rule
+ (target shims.ml)
+ (deps shims.fallback.ml)
+ (enabled_if (< %{ocaml_version} 5.1))
+ (action (copy# %{deps} %{target})))
+
+(mdx
+  (package caqti)
+  (preludes mdx.prelude)
+  (files :standard *.mli)
+  (libraries caqti.template uri))

unikernel/duniverse/ocaml-caqti/caqti/lib-template/field_type.ml

@@ -0,0 +1,108 @@
+(* Copyright (C) 2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Shims
+
+type 'a t =
+  | Bool : bool t
+  | Int : int t
+  | Int16 : int t
+  | Int32 : int32 t
+  | Int64 : int64 t
+  | Float : float t
+  | String : string t
+  | Octets : string t
+  | Pdate : Ptime.t t
+  | Ptime : Ptime.t t
+  | Ptime_span : Ptime.span t
+  | Enum : string -> string t
+
+let unify : type a b. a t -> b t -> (a, b) Type.eq option =
+  fun ft1 ft2 ->
+  (match ft1, ft2 with
+   | Bool, Bool -> Some Equal
+   | Bool, _ | _, Bool -> None
+   | Int, Int -> Some Equal
+   | Int, _ | _, Int -> None
+   | Int16, Int16 -> Some Equal
+   | Int16, _ | _, Int16 -> None
+   | Int32, Int32 -> Some Equal
+   | Int32, _ | _, Int32 -> None
+   | Int64, Int64 -> Some Equal
+   | Int64, _ | _, Int64 -> None
+   | Float, Float -> Some Equal
+   | Float, _ | _, Float -> None
+   | String, String -> Some Equal
+   | String, _ | _, String -> None
+   | Octets, Octets -> Some Equal
+   | Octets, _ | _, Octets -> None
+   | Pdate, Pdate -> Some Equal
+   | Pdate, _ | _, Pdate -> None
+   | Ptime, Ptime -> Some Equal
+   | Ptime, _ | _, Ptime -> None
+   | Ptime_span, Ptime_span -> Some Equal
+   | Ptime_span, _ | _, Ptime_span -> None
+   | Enum name1, Enum name2 when name1 = name2 -> Some Equal
+   | Enum _, Enum _ -> None)
+
+let equal_value : type a. a t -> a -> a -> bool = function
+ | Bool -> Bool.equal
+ | Int -> Int.equal
+ | Int16 -> Int.equal
+ | Int32 -> Int32.equal
+ | Int64 -> Int64.equal
+ | Float -> Float.equal
+ | String -> String.equal
+ | Octets -> String.equal
+ | Pdate -> Ptime.equal
+ | Ptime -> Ptime.equal
+ | Ptime_span -> Ptime.Span.equal
+ | Enum _ -> String.equal
+
+let to_string : type a. a t -> string = function
+ | Bool -> "bool"
+ | Int -> "int"
+ | Int16 -> "int16"
+ | Int32 -> "int32"
+ | Int64 -> "int64"
+ | Float -> "float"
+ | String -> "string"
+ | Octets -> "octets"
+ | Pdate -> "pdate"
+ | Ptime -> "ptime"
+ | Ptime_span -> "ptime_span"
+ | Enum name -> name
+
+let pp ppf ft = Format.pp_print_string ppf (to_string ft)
+
+let pp_ptime = Ptime.pp_rfc3339 ~tz_offset_s:0 ~space:false ()
+
+let pp_value : type a. _ -> a t * a -> unit = fun ppf -> function
+ | Bool, x -> Format.pp_print_bool ppf x
+ | Int, x -> Format.pp_print_int ppf x
+ | Int16, x -> Format.pp_print_int ppf x
+ | Int32, x -> Format.fprintf ppf "%ldl" x
+ | Int64, x -> Format.fprintf ppf "%LdL" x
+ | Float, x -> Format.fprintf ppf "%F" x
+ | String, x -> Format.fprintf ppf "%S" x
+ | Octets, x -> Format.fprintf ppf "%S" x
+ | Pdate, x ->
+    let y, m, d = Ptime.to_date x in
+    Format.fprintf ppf "%d-%02d-%02d" y m d
+ | Ptime, x -> pp_ptime ppf x
+ | Ptime_span, x -> Ptime.Span.pp ppf x
+ | Enum _, x -> Format.pp_print_string ppf x

unikernel/duniverse/ocaml-caqti/caqti/lib-template/field_type.mli

@@ -0,0 +1,44 @@
+(* Copyright (C) 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.
+ *)
+
+(** Database field types. *)
+
+open Shims
+
+type 'a t =
+  | Bool : bool t
+  | Int : int t
+  | Int16 : int t
+  | Int32 : int32 t
+  | Int64 : int64 t
+  | Float : float t
+  | String : string t
+  | Octets : string t
+  | Pdate : Ptime.t t
+  | Ptime : Ptime.t t
+  | Ptime_span : Ptime.span t
+  | Enum : string -> string t
+
+val unify : 'a t -> 'b t -> ('a, 'b) Type.eq option
+
+val equal_value : 'a t -> 'a -> 'a -> bool
+
+val to_string : 'a t -> string
+
+val pp : Format.formatter -> 'a t -> unit
+
+val pp_value : Format.formatter -> 'a t * 'a -> unit

unikernel/duniverse/ocaml-caqti/caqti/lib-template/mdx.prelude

@@ -0,0 +1 @@
+[@@@alert "-caqti_unstable"]

unikernel/duniverse/ocaml-caqti/caqti/lib-template/query.ml

@@ -0,0 +1,393 @@
+(* 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.
+ *)
+
+open Shims
+
+module Private = struct
+  type t =
+    | L of string
+    | V : 'a Field_type.t * 'a -> t
+    | Q of string
+    | P of int
+    | E of string
+    | S of t list
+end
+open Private
+
+type t = Private.t
+
+let empty = S []
+let lit frag = L frag
+let quote str = Q str
+let param i = P i
+let var v = E v
+
+let cat q1 q2 =
+  (match q1, q2 with
+   | S [], qs | qs, S [] -> qs
+   | S qs1, S qs2 -> S (List.append qs1 qs2)
+   | S qs1, q2 -> S (List.append qs1 [q2])
+   | q1, S qs2 -> S (q1 :: qs2)
+   | q1, q2 -> S [q1; q2])
+
+let concat =
+  let rec loop pfx acc = function
+   | [] -> acc
+   | q :: qs -> loop pfx (pfx :: q :: acc) qs
+  in
+  fun ?sep qs ->
+    (match sep, qs with
+     | _, [] -> S []
+     | None, _ -> S qs
+     | Some sep, q :: qs -> S (q :: loop (L sep) [] (List.rev qs)))
+
+let parens q = concat [lit "("; q; lit ")"]
+
+let bool x = V (Field_type.Bool, x)
+let int x = V (Field_type.Int, x)
+let int16 x = V (Field_type.Int16, x)
+let int32 x = V (Field_type.Int32, x)
+let int64 x = V (Field_type.Int64, x)
+let float x = V (Field_type.Float, x)
+let string x = V (Field_type.String, x)
+let octets x = V (Field_type.Octets, x)
+let pdate x = V (Field_type.Pdate, x)
+let ptime x = V (Field_type.Ptime, x)
+let ptime_span x = V (Field_type.Ptime_span, x)
+let const t v = V (t, v)
+
+let rec const_fields_opt : type a. a Row_type.t -> a option -> t list =
+  (function
+   | Field ft ->
+      (function None -> [L "NULL"] | Some x -> [V (ft, x)])
+   | Option t ->
+      let of_t = const_fields_opt t in
+      (function None -> of_t None | Some x -> of_t x)
+   | Product (_, pt) ->
+      const_fields_opt_of_product pt
+   | Annot (_, t) ->
+      const_fields_opt t)
+and const_fields_opt_of_product
+  : type i a. (i, a) Row_type.product -> a option -> t list =
+  (function
+   | Proj_end -> fun _ -> []
+   | Proj (t, p, pt) ->
+      let of_t = const_fields_opt t in
+      let of_pt = const_fields_opt_of_product pt in
+      fun x -> of_t (Option.map p x) @ of_pt x)
+
+let const_fields (t : _ Row_type.t) =
+  let f = const_fields_opt t in
+  fun x -> f (Some x)
+
+let rec equal_list f xs ys = (* stdlib 4.12.0 *)
+  (match xs, ys with
+   | [], [] -> true
+   | x :: xs', y :: ys' -> f x y && equal_list f xs' ys'
+   | [], _ :: _ | _ :: _, [] -> false)
+
+let normal =
+  let rec collect acc = function
+   | [] -> List.rev acc
+   | ((L"" | S[]) :: qs) -> collect acc qs
+   | ((P _ | V _ | Q _ | E _ as q) :: qs) -> collect (q :: acc) qs
+   | (S (q' :: qs') :: qs) -> collect acc (q' :: S qs' :: qs)
+   | (L s :: qs) -> collectL acc [s] qs
+  and collectL acc accL = function
+   | ((L"" | S[]) :: qs) -> collectL acc accL qs
+   | (L s :: qs) -> collectL acc (s :: accL) qs
+   | (S (q' :: qs') :: qs) -> collectL acc accL (q' :: S qs' :: qs)
+   | [] | ((P _ | V _ | Q _ | E _) :: _) as qs ->
+      collect (L (String.concat "" (List.rev accL)) :: acc) qs
+  in
+  fun q ->
+    (match collect [] [q] with
+     | [] -> S[]
+     | [q] -> q
+     | qs -> S qs)
+
+let rec equal t1 t2 =
+  (match t1, t2 with
+   | L s1, L s2 -> String.equal s1 s2
+   | V (t1, v1), V (t2, v2) ->
+      (match Field_type.unify t1 t2 with
+       | None -> false
+       | Some Type.Equal -> Field_type.equal_value t1 v1 v2)
+   | Q s1, Q s2 -> String.equal s1 s2
+   | P i1, P i2 -> Int.equal i1 i2
+   | E n1, E n2 -> String.equal n1 n2
+   | S ts1, S ts2 -> equal_list equal ts1 ts2
+   | V _, _ -> false
+   | L _, _ -> false
+   | Q _, _ -> false
+   | P _, _ -> false
+   | E _, _ -> false
+   | S _, _ -> false)
+
+let hash = Hashtbl.hash
+
+let rec pp ppf = function
+ | L s -> Format.pp_print_string ppf s
+ | V (t, v) -> Field_type.pp_value ppf (t, v)
+ | Q s ->
+    (* Using non-SQL quoting, to avoid issues with newlines and other control
+     * characters when printing to log files. *)
+    Format.pp_print_string ppf "E'";
+    for i = 0 to String.length s - 1 do
+      (match s.[i] with
+       | '\\' -> Format.pp_print_string ppf {|\\|}
+       | '\'' -> Format.pp_print_string ppf {|\'|}
+       | '\t' -> Format.pp_print_string ppf {|\t|}
+       | '\n' -> Format.pp_print_string ppf {|\n|}
+       | '\r' -> Format.pp_print_string ppf {|\r|}
+       | '\x00'..'\x1f' as c -> Format.fprintf ppf {|\x%02x|} (Char.code c)
+       | _ -> Format.pp_print_char ppf s.[i])
+    done;
+    Format.pp_print_char ppf '\''
+ | P n -> Format.pp_print_char ppf '$'; Format.pp_print_int ppf (n + 1)
+ | E n -> Format.fprintf ppf "$(%s)" n
+ | S qs -> List.iter (pp ppf) qs
+
+let show q =
+  let buf = Buffer.create 512 in
+  let ppf = Format.formatter_of_buffer buf in
+  pp ppf q; Format.pp_print_flush ppf ();
+  Buffer.contents buf
+
+module Expand_error = struct
+
+  type nonrec t = {
+    query: t;
+    var: string;
+    reason: [`Undefined | `Invalid of t];
+  }
+
+  let pp ppf {query; var; reason} =
+    let open Format in
+    (match reason with
+     | `Undefined ->
+        fprintf ppf "Undefined variable %s in query %a" var pp query
+     | `Invalid expansion ->
+        fprintf ppf
+          "While expanding %a, lookup of %s gives %a, which is invalid \
+           because it contains an environment or parameter reference."
+          pp query var pp expansion)
+end
+
+exception Expand_error of Expand_error.t
+
+type subst = string -> t
+
+let expand ?(final = false) f query =
+  let rec is_valid = function
+   | L _ | V _ | Q _ -> true
+   | P _ | E _ -> false
+   | S qs -> List.for_all is_valid qs
+  in
+  let rec recurse = function
+   | L _ | V _ | Q _ | P _ as q -> q
+   | E var as q ->
+      let not_found () =
+        if not final then q else
+        raise (Expand_error {query; var; reason = `Undefined})
+      in
+      (match f var with
+       | q' ->
+          if is_valid q' then q' else
+          raise (Expand_error {query; var; reason = `Invalid q'})
+       | exception Not_found ->
+          let l = String.length var in
+          if l > 0 && var.[l - 1] = '.' then
+            (match f (String.sub var 0 (l - 1)) with
+             | frag ->
+                (match normal frag with
+                 | S[] as q' -> q'
+                 | q' -> S[q'; L"."])
+             | exception Not_found -> not_found ())
+          else
+            not_found ())
+   | S qs -> S (List.map recurse qs)
+  in
+  recurse query
+
+module Angstrom_parsers = struct
+  open Angstrom
+
+  let failf = Printf.ksprintf fail
+  let ign p = p >>| fun _ -> ()
+
+  let is_digit = function '0'..'9' -> true | _ -> false
+  let is_digit_nz = function '1'..'9' -> true | _ -> false
+  let is_idrfst = function 'a'..'z'|'A'..'Z' | '_' -> true | _ -> false
+  let is_idrcnt = function 'a'..'z'|'A'..'Z' | '_' | '0'..'9' -> true | _ -> false
+  let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false
+
+  let single_quoted = skip_many (ign (not_char '\'') <|> ign (string "''"))
+  let double_quoted = skip_many (ign (not_char '"') <|> ign (string "\"\""))
+
+  let tagged_quote_cont =
+    consumed (skip is_idrfst *> skip_while is_idrcnt) <* char '$' >>= fun tag ->
+    many_till any_char (char '$' *> string tag <* char '$') >>| (fun _ -> ())
+
+  let verbatim =
+    let fragment = any_char >>= function
+     | '\'' -> single_quoted <* char '\''
+     | '"' -> double_quoted <* char '"'
+     | '`' -> skip_many (not_char '`') <* char '`'
+     | '-' ->
+        (peek_char >>= function
+         | Some '-' -> skip_while ((<>) '\n') <* char '\n'
+         | _ -> return ())
+     | '$' -> tagged_quote_cont
+     | '?' | ';' as c -> failf "%C is not valid here" c
+     | _ -> return ()
+    in
+    consumed (many1 fragment) >>| (fun s -> (L s))
+
+  let skip_idr = skip is_idrfst *> skip_while is_idrcnt
+  let identifier_dot = consumed (skip_idr *> char '.')
+  let identifier_dotopt = consumed (option () skip_idr *> option ' ' (char '.'))
+  let parameter_number = consumed (skip is_digit_nz *> skip_while is_digit)
+
+  let lookup =
+    choice ~failure_msg:"invalid environment lookup" [
+      string "$(" *> identifier_dotopt <* char ')' >>| (fun v -> E v);
+      string "$." >>| (fun _ -> E ".");
+      char '$' *> identifier_dot >>| (fun v -> E v);
+    ]
+
+  let untagged_quote =
+    let nonlookup =
+      consumed (many1 (satisfy (function '$' -> false | _ -> true)))
+        >>| (fun s -> (L s))
+    in
+    string "$$" *> many_till (lookup <|> nonlookup) (string "$$") >>| fun qs ->
+    normal (S ([L "$$"] @ qs @ [L "$$"]))
+
+  let atom =
+    peek_char_fail >>= function
+     | '$' ->
+        choice ~failure_msg:"invalid dollar sequence" [
+          char '$' *> parameter_number >>| (fun iP -> P (int_of_string iP - 1));
+          lookup;
+          untagged_quote;
+          verbatim;
+        ]
+     | '?' ->
+        let valid_lookahead = peek_char >>= function
+         | Some ':' ->
+            (peek_string 2 >>= function
+             | "::" -> return ()
+             | _ -> fail "':' is not allowed after parameter reference '?'")
+         | Some ('A'..'Z' | 'a'..'z' | '0'..'9' | '_'
+               | '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '.'
+               | '<' | '=' | '>' | '?' | '@' | '^' | '`' | '|' | '~' as c) ->
+            failf "%C is not allowed after parameter reference '?'" c
+         | None | Some _ ->
+            return ()
+        in
+        char '?' >>| (fun _ -> P (-1)) <* valid_lookahead
+     | _ ->
+        verbatim
+
+  let atom_or_semi = (char ';' >>| fun _ -> L";") <|> atom
+
+  let reindex atoms =
+    if List.for_all (function P (-1) -> false | _ -> true) atoms then
+      return atoms
+    else
+    let rec loop iP acc = function
+     | [] -> return (List.rev acc)
+     | P (-1) :: frags -> loop (iP + 1) (P iP :: acc) frags
+     | P _ :: _ -> fail "Inconsistent parameter style."
+     | frag :: frags -> loop iP (frag :: acc) frags
+    in
+    loop 0 [] atoms
+
+  let expression =
+    let stop =
+      peek_char >>= function
+       | None | Some ';' -> return ()
+       | _ -> fail "unterminated"
+    in
+    fix (fun p -> (stop *> return []) <|> (List.cons <$> atom <*> p))
+      >>= reindex >>| (function [q] -> q | qs -> S qs)
+
+  let expression_with_semi =
+    let stop =
+      peek_char >>= function
+       | None -> return ()
+       | _ -> fail "unterminated"
+    in
+    fix (fun p -> (stop *> return []) <|> (List.cons <$> atom_or_semi <*> p))
+      >>= reindex >>| (function [q] -> q | qs -> S qs)
+
+  let expression_list =
+    let white =
+      many (take_while1 is_space <|> (string "--" *> take_till ((=) '\n')))
+        <* commit
+    in
+    white *> many (expression <* char ';' <* white)
+end
+
+let angstrom_parser = Angstrom_parsers.expression
+let angstrom_parser_with_semicolon = Angstrom_parsers.expression_with_semi
+let angstrom_list_parser = Angstrom_parsers.expression_list
+
+module Parse_error = struct
+  type t = {
+    position: int;
+    message: string;
+  }
+
+  let create position message = {position; message}
+
+  let position err = err.position
+  let message err = err.message
+
+  let pp ppf err =
+    Format.fprintf ppf "Parse error at byte %d: %s" err.position err.message
+end
+
+exception Parse_error of Parse_error.t
+
+let parse_result s =
+  let open Angstrom.Unbuffered in
+  (match parse angstrom_parser_with_semicolon with
+   | Partial {committed = 0; continue} ->
+      let len = String.length s in
+      let bs = Bigstringaf.of_string ~off:0 ~len s in
+      (match continue bs ~off:0 ~len Complete with
+       | Done (committed, q) when committed = len -> Ok q
+       | Done (committed, _) | Partial {committed; _} ->
+          let msg = "Expression cannot contain semicolon." in
+          Error (Parse_error.create committed msg)
+       | Fail (committed, _, msg) ->
+          Error (Parse_error.create committed msg))
+   | Partial _ | Done _ | Fail _ ->
+      assert false)
+
+let parse s =
+  (match parse_result s with
+   | Ok q -> q
+   | Error err -> raise (Parse_error err))
+
+module Infix = struct
+  let (@++) = cat
+  let (^++) pfx q = cat (lit pfx) q
+  let (++^) q sfx = cat q (lit sfx)
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-template/query.mli

@@ -0,0 +1,285 @@
+(* 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.
+ *)
+
+(** This module provides templating of database query strings.  It helps
+    mitigate differences between database systems, and provides additional
+    functionality such as variable substitution and safe embedding of values.
+    The representation is also suited for dynamic construction.
+
+    There are three ways to construct a template:
+
+      - Using the parser ({!parse}, {!parse_result}, etc.) if the query template
+        is known at compile time.
+
+      - Using the {{!query_construction} constructors} of the current module.
+
+      - Using the {!Query_fmt} module, which provides an alternative to the
+        previous option. *)
+
+(**/**)
+module Private : sig
+  type t =
+    | L of string
+    | V : 'a Field_type.t * 'a -> t
+    | Q of string
+    | P of int
+    | E of string
+    | S of t list
+end [@@alert caqti_private]
+(**/**)
+
+type t = Private.t [@@alert "-caqti_private"]
+(** [t] is an intermediate representation of a query string to be send to a
+    database, possibly combined with some hidden parameters used to safely embed
+    values.  Apart from embedding values, this representation provides indexed
+    parameter references, independent of the target database system.  For
+    databases which use linear parameter references (like [?] for MariaDB), the
+    driver will reshuffle, elide, and duplicate parameters as needed. *)
+
+(** {2:query_construction Construction} *)
+
+val empty : t
+(** [empty] is the empty query fragment; i.e. it expands to nothing. *)
+
+val lit : string -> t
+(** [lit frag] expands to [frag], literally; i.e. the argument is passed
+    unchanged to the database system as a substring of the query.
+    Do not use this to inject untrusted data into the query string, since it can
+    lead to an SQL injection vulnerability.
+    Even when it can be done safely, it is probably easier and more portable to
+    use the appropriate function from {!embeddingvalues} or the {!quote}
+    function. *)
+
+val quote : string -> t
+(** [quote str] expands to the literally quoted string [str] if an reliable
+    escape function is available from the driver library, otherwise [quote] is
+    equivalent to {!string}. *)
+
+val param : int -> t
+(** [param i] expands to a reference to parameter number [i], counting from
+    zero.  That is, [param 0] expands to ["$1"] for PostgreSQL and to ["?1"] for
+    SQLite3.  For MariaDB, [param i] expands to ["?"] for any [i]; the driver
+    will instead shuffle, elide, and duplicate the actual arguments to match
+    their order of reference in the query string. *)
+
+val var : string -> t
+(** [var v] expands to [subst v] where [subst] is the substitution function
+    passed to {!expand} or one of the connector functions. *)
+
+val concat : ?sep: string -> t list -> t
+(** [concat ?sep frags] concatenates [frags], optionally separated by [sep].
+    Returns the empty fragment on the empty list of fragments. *)
+
+val parens : t -> t
+(** [parens frag] wraps [frag] in paranthesis *)
+
+val cat : t -> t -> t
+(** [cat q1 q2] expands to the juxtaposition of the expansions of [q1] followed
+    by [q2].  This is an associative alternative to {!concat} when no separator
+    is needed. *)
+
+module Infix : sig
+  (** This module provides a terser way to compose queries.  As an example,
+      consider the dynamic construction of a simple SELECT-request which
+      extracts a list of named columns given a corresponding row type, and where
+      conditions are given as query templates with any values embedded:
+      {[
+        open Caqti_template.Create
+
+        type cond =
+          | Column_eq : string * 'a Caqti_template.Field_type.t * 'a -> cond
+
+        let query_of_cond = function
+         | Column_eq (col, t, v) ->
+            Q.lit col @++ " = " ^++ Q.const t v
+
+        let make_simple_select conds columns row_type =
+          let query =
+            "SELECT " ^++ Q.concat ~sep:", " (List.map Q.lit columns) @++
+            " FROM $.foo" ^++
+            " WHERE " ^++ Q.concat ~sep:" AND " (List.map query_of_cond conds)
+          in
+          direct_gen T.(unit -->* row_type) (fun _ -> query)
+      ]}
+      *)
+
+  val (@++) : t -> t -> t
+  (** An alias for {!Query.cat}. *)
+
+  val (^++) : string -> t -> t
+  (** [pfx ^++ q] is [q] prefixed with the literal fragment [pfx], i.e.
+      [cat (lit pfx) q]. *)
+
+  val (++^) : t -> string -> t
+  (** [q ++^ sfx] is [q] suffixed with the literal fragment [sfx], i.e.
+      [cat q (lit sfx)]. *)
+end
+
+(** {3:embeddingvalues Embedding Values}
+
+    The following functions can be used to embed values into a query, including
+    the generic {!const}, corresponding specialized variants.  Additionally
+    {!const_fields} can be used to extract fragments for multiple fields given a
+    row type and a value. *)
+
+val bool : bool -> t
+val int : int -> t
+val int16 : int -> t
+val int32 : int32 -> t
+val int64 : int64 -> t
+val float : float -> t
+val string : string -> t
+val octets : string -> t
+val pdate : Ptime.t -> t
+val ptime : Ptime.t -> t
+val ptime_span : Ptime.span -> t
+
+val const : 'a Field_type.t -> 'a -> t
+(** [const t x] is a fragment representing the value [x] of field type [t],
+    using driver-dependent serialization and escaping mechanisms.
+    Drivers will typically expand this to a parameter reference which will
+    receive the value [x] when executed, though the value may also be embedded
+    in the query if it is deemed safe. *)
+
+val const_fields : 'a Row_type.t -> 'a -> t list
+(** [const_fields t x] returns a list of fragments corresponding to the
+    single-field projections of the value [x] as described by the type
+    descriptor [t].  Each element of the returned list will be either a
+    {!const}-fragment containing the projected value, or [lit "NULL"] if
+    the projection is [None].
+
+    The result can be turned into a comma-separated list with {!concat}, except
+    values of unitary types, i.e. types having no fields, may require special
+    care. *)
+
+
+(** {2 Normalization and Equality} *)
+
+val normal : t -> t
+(** [normal q] rewrites [q] to a normal form, flattening nested concatenations
+    and removing empty fragments from the internal representation.
+    This function can be used to post-process queries before using {!equal} and
+    {!hash}. *)
+
+val equal : t -> t -> bool
+(** [equal q1 q2] is true iff [q1] and [q2] has the same internal
+    representation.
+    It may be necessary to pre-process the query templates with {!normal} if
+    they are not constructed by a common deterministic algorithm. *)
+
+val hash : t -> int
+(** [hash q] computes a hash over the internal representation of [q] which is
+    compatible with {!equal}.
+    The hash function may change across minor versions and may depend on
+    architecture.
+    It may be necessary to pre-process the query template with {!normal}, unless
+    the hash is to be used among a collection of query templates constructed by
+    a common deterministic algorithm. *)
+
+
+(** {2 Parsing, Expansion, and Printing} *)
+
+val pp : Format.formatter -> t -> unit
+(** [pp ppf q] prints a {e human}-readable representation of [q] on [ppf].
+    The printed string is {e not suitable for sending to an SQL database}; doing
+    so may lead to an SQL injection vulnerability. *)
+
+val show : t -> string
+(** [show q] is the same {e human}-readable representation of [q] as printed by
+    {!pp}.
+    The returned string is {e not suitable for sending to an SQL database};
+    doing so may lead to an SQL injection vulnerability. *)
+
+module Expand_error : sig
+  type t
+
+  val pp : Format.formatter -> t -> unit
+  (** Formats a human-readable error message. *)
+end
+(** A description of the error caused during {!expand} if the environment lookup
+    function returns an invalid result or fails to provide a value for a
+    variable when the expansion is final. *)
+
+exception Expand_error of Expand_error.t
+(** The exception raised by {!expand} when there are issues expanding an
+    environment variable using the provided callback. *)
+
+type subst = string -> t
+(** A partial mapping from variable names to query fragments, which raises
+    [Not_found] for undefined variables.  This is used by {!expand} to resolve
+    variable references, with the special handling of a final period in the
+    variable names described in {{!query_template} The Syntax of Query
+    Templates}. *)
+
+val expand : ?final: bool -> subst -> t -> t
+(** [expand subst query] replaces the occurrence of each variable [var] with
+    [subst var] where it is defined, otherwise if [final] is [false], the
+    variable is left unchanged, otherwise raises {!exception-Expand_error}.
+    The result of the substitution function may not contain variable references.
+
+    @param final
+      Whether this is the final expansion, as when invoked by the drivers.
+      Defaults to [false].
+
+    @raise exception-Expand_error
+      if the substitution function is invalid or if it is incomplete for a final
+      expansion. *)
+
+val angstrom_parser : t Angstrom.t
+(** Matches a single expression terminated by the end of input or a semicolon
+    lookahead. The accepted languages is described in {{!query_template} The
+    Syntax of Query Templates}. *)
+
+val angstrom_parser_with_semicolon : t Angstrom.t
+(** A variant of [angstrom_parser] which accepts unquoted semicolons as part of
+    the single statement, as is valid in some cases like in SQLite3 trigger
+    definitions.  This is the parser used by {!Caqti_template.Request}, where
+    it's assumed that the input is a single SQL statement. *)
+
+val angstrom_list_parser : t list Angstrom.t
+(** Matches a sequence of statements while ignoring surrounding white space and
+    end-of-line comments starting with ["--"].  This parser can be used to load
+    schema files with support for environment expansions, like substituting the
+    name of the database schema. *)
+
+module Parse_error : sig
+  type t
+
+  val position : t -> int
+  (** The byte position of the string at which the parser failed. *)
+
+  val message : t -> string
+  (** A message describing the problem. *)
+
+  val pp : Format.formatter -> t -> unit
+  (** Formats a human-readable error message. *)
+end
+(** Describes errors from the high-level parsing functions. *)
+
+exception Parse_error of Parse_error.t
+(** The exception which may be raised by {!parse}. *)
+
+val parse : string -> t
+(** Parses a single expression using {!angstrom_parser_with_semicolon}.  The
+    error indicates the byte position of the input string where the parse
+    failure occurred in addition to an error message. See {{!query_template} The
+    Syntax of Query Templates} for how the input string is interpreted.
+
+    @raise exception-Parse_error if the argument is syntactically invalid. *)
+
+val parse_result : string -> (t, Parse_error.t) result
+(** Variant of {!parse} which returns a result instead of raising.  *)

unikernel/duniverse/ocaml-caqti/caqti/lib-template/query_fmt.ml

@@ -0,0 +1,158 @@
+(* Copyright (C) 2023--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+type 'a t = Format.formatter -> 'a -> unit
+
+type Format.stag += Stag_query of Query.t
+
+let query ppf q =
+  Format.pp_open_stag ppf (Stag_query q);
+  Format.pp_print_string ppf "... SQL FRAGMENT ...";
+  Format.pp_close_stag ppf ()
+
+let quote ppf q = query ppf (Query.quote q)
+let env ppf e = query ppf (Query.var e)
+let param ppf p = query ppf (Query.param p)
+
+type mode = Mode_literal | Mode_ignore | Mode_raw of (string -> Query.t)
+
+let kqprintf k fmt =
+  (* The formatter can be in three different modes, which is determined
+     depending on the currently open tags (we exploit the fact that
+     [mark_open_stag] and [mark_close_tag] are called immediately before the tag
+     would actually be output to the formatter, and so can we can effectively
+     use them as control directives for the behavior of [output_string]).
+
+     Internally, the formatter holds a list of query elements in the reverse
+     order that they have been produced in. Once we have finished parsing, that
+     list is reversed, wrapped into the [S] constructor, and returned. We will
+     call this list of elements we are building "the queue" in the following.
+
+     Initially, the formatter starts in literal mode. In literal mode, we simply
+     push each string that we receive from the formatter into the queue
+     unmodified as a literal.
+
+     When we encounter a tag in literal mode, we enter one of two auxiliary
+     modes:
+
+      - If the tag is the string tag "Q" or "E" (denoting a nested quote or env
+        var format, respectively), we enter raw mode, parameterized by a
+        function that returns either [Q] or [E]. In raw mode, we accumulate the
+        content that gets printed into a buffer, and when exiting raw mode
+        (i.e. when the corresponding tag gets closed), we wrap the accumulated
+        content as a string into either the [Q] or [E] constructor, and push it
+        into the queue. Then, we exit go back to literal mode.
+
+      - If the tag is custom tag [Stag_query], added by the {!query} printer, we
+        push the embedded query without modifications onto the queue, then
+        switch to ignore mode. In ignore mode, we simply discard what is printed
+        until we exit ignore mode by closing the corresponding tag. This is
+        because, in ignore mode, the content that we are interested in is the
+        parameter of the [Stag_query], not the textual content within the tag.
+
+     Nesting of tags is not supported, so if we see one of the tags above in
+     either of these modes, we raise a [Failure] exception.
+  *)
+  let elems = ref [] in
+  let buf = Buffer.create 512 in
+
+  let push q = elems := q :: !elems in
+  let mode = ref Mode_literal in
+  let flush_raw () =
+    let mk = match !mode with Mode_raw f -> f | _ -> assert false in
+    push @@ mk @@ Buffer.contents buf;
+    Buffer.reset buf;
+    mode := Mode_literal
+  and flush_ignore () =
+    match !mode with Mode_ignore -> mode := Mode_literal | _ -> assert false
+  and flush_literal () =
+    (* Unlike the similar cases in [flush_raw] and [flush_ignore], it is actually
+       possible to call [flush_literal] while not in literal mode by nesting <Q>
+       and/or <E> semantic tags.
+
+       There is actually nothing to do here, because we push output strings into
+       the queue on the fly. *)
+    begin
+      match !mode with
+      | Mode_literal -> ()
+      | _ -> failwith "invalid nesting of query tags; did you forget a `@}`?"
+    end
+  and output_string s p n =
+    match !mode with
+    | Mode_literal ->
+      if n > 0 then
+        if p = 0 && n = String.length s then
+          push (Query.lit s)
+        else
+          push (Query.lit (String.sub s p n))
+    | Mode_raw _ -> Buffer.add_substring buf s p n
+    | Mode_ignore -> ()
+  in
+  let ppf = Format.make_formatter output_string flush_literal in
+  let Format.
+        { mark_open_stag; mark_close_stag; print_open_stag; print_close_stag } =
+    Format.pp_get_formatter_stag_functions ppf ()
+  in
+  (* Note that we call [flush_literal] when *opening* tags but the other [flush]
+     functions when *closing* tags.  Since [Format] enforces the
+     well-parenthesising of tags, we are guaranteed to always be in the correct
+     mode when calling [flush_raw] and [flush_ignore], but that is *not* the
+     case for [flush_litera].
+  *)
+  let mark_open_stag = function
+    | Format.String_tag "Q" ->
+        flush_literal ();
+        mode := Mode_raw (fun s -> Query.quote s);
+        ""
+    | Format.String_tag "E" ->
+        flush_literal ();
+        mode := Mode_raw (fun s -> Query.var s);
+        ""
+    | Stag_query q ->
+        flush_literal ();
+        push q;
+        mode := Mode_ignore;
+        ""
+    | t -> mark_open_stag t
+  and mark_close_stag = function
+    | Format.String_tag ("Q" | "E") ->
+        flush_raw ();
+        ""
+    | Stag_query _ ->
+        flush_ignore ();
+        ""
+    | t -> mark_close_stag t
+  in
+  Format.pp_set_formatter_stag_functions ppf
+    { mark_open_stag; mark_close_stag; print_open_stag; print_close_stag };
+  Format.pp_set_mark_tags ppf true;
+  Format.kfprintf
+    (fun ppf ->
+      Format.pp_print_flush ppf ();
+      k (Query.concat (List.rev !elems)))
+    ppf fmt
+
+let qprintf fmt = kqprintf Fun.id fmt
+
+let bool ppf x = query ppf (Query.bool x)
+let int ppf x = query ppf (Query.int x)
+let float ppf x = query ppf (Query.float x)
+let string ppf x = query ppf (Query.string x)
+let octets ppf x = query ppf (Query.octets x)
+let pdate ppf x = query ppf (Query.pdate x)
+let ptime ppf x = query ppf (Query.ptime x)
+let ptime_span ppf x = query ppf (Query.ptime_span x)

unikernel/duniverse/ocaml-caqti/caqti/lib-template/query_fmt.mli

@@ -0,0 +1,102 @@
+(* Copyright (C) 2023--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+(** Format-based query construction. *)
+
+type 'a t = Format.formatter -> 'a -> unit
+(** The type of a function which formats values of type ['a] or fragments based
+    on an input of type ['a]. *)
+
+val qprintf : ('a, Format.formatter, unit, Query.t) format4 -> 'a
+(** {!qprintf} allows building Caqti queries using a printf-style interface.
+
+    When using {!qprintf}, you can use the {!query}, {!quote}, {!env} and
+    {!param} printers from this module to generate the corresponding query
+    fragments.
+
+    In addition, you can use the "Q" and "E" string tags to delimit portions of
+    the formatting string that should be interpreted as quotes and environment
+    variables, respectively. The "Q" and "E" tags can not be nested: within the
+    tags, {!qprintf} behaves no differently than {!Format.asprintf} and will
+    generate a string, not a query (only when the tag is closed does the string
+    get converted into a query).
+
+    The two following calls to {!qprintf}:
+    {@ocaml skip[
+      qprintf "FUNC(@{<Q>Quoted value with %d format(s)})" 1
+    ]}
+    and
+    {@ocaml skip[
+      qprintf "FUNC(%a)" quote (Format.asprintf "Quoted value with %d format(s)" 1)
+    ]}
+    are functionally equivalent. Both compute
+    {@ocaml skip[
+      S [L "FUNC("; Q "Quoted value with 1 format(s)"; L ")"]
+    ]}
+    but the first one is nicer to work with.
+
+    @raise Failure if the "Q" and "E" tags are nested.
+*)
+
+val kqprintf : (Query.t -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b
+(** {!kqprintf} is the continuation-passing version of {!qprintf} (like
+    {!Format.kasprintf} for {!Format.asprintf}).
+
+    You usually want [qprintf] instead. *)
+
+val param : int t
+(** {!param} is a formatter that includes the corresponding parameter in a
+    query built by {!qprintf}.
+
+    Note that to include a parameter in a query, {!param} *must* be used: using
+    literal ["$"] or ["?"] will be sent as-is to the SQL driver and will not be
+    processed by Caqti.
+*)
+
+val env : string t
+(** {!env} is a formatter that includes the corresponding environment variable
+    in a query built by {!qprintf}.
+
+    Note that to include an environment variable in a query, {!env} *must* be
+    used: using literal ["$(...)"] will be sent as-is to the SQL driver and
+    will not be processed by Caqti. *)
+
+val quote : string t
+(** {!quote} is a formatter that includes a TEXT literal in a query built by
+    {!qprintf}. *)
+
+val query : Query.t t
+(** {!query} can be used with {!qprintf} to embed a query that was already
+    parsed in the format string. Direct use of {!query} should be rare, and
+    {!param}, {!env}, or {!quote} should be used instead when possible.
+
+    Using {!query} with any other formatter will ignore the query and instead
+    print a dummy value (currently ["... SQL FRAGMENT ..."]) instead. *)
+
+(** {2 Value Formatters}
+
+    The following formatters emit values of basic field types by passing them as
+    parameters. *)
+
+val bool : bool t
+val int : int t
+val float : float t
+val string : string t
+val octets : string t
+val pdate : Ptime.t t
+val ptime : Ptime.t t
+val ptime_span : Ptime.span t

unikernel/duniverse/ocaml-caqti/caqti/lib-template/request.ml

@@ -0,0 +1,92 @@
+(* 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.
+ *)
+
+[@@@alert "-caqti_private"]
+
+module Log = (val Logs.src_log (Logs.Src.create "caqti"))
+
+type prepare_policy =
+  | Direct
+  | Dynamic
+  | Static
+
+type ('a, 'b, +'m) t = {
+  id: int option;
+  prepare_policy: prepare_policy;
+  query: Dialect.t -> Query.t;
+  param_type: 'a Row_type.t;
+  row_type: 'b Row_type.t;
+  row_mult: 'm Row_mult.t;
+} constraint 'm = [< `Zero | `One | `Many]
+
+let last_id = ref (-1)
+
+let create prepare_policy (param_type, row_type, row_mult) query =
+  let id =
+    (match prepare_policy with
+     | Direct -> None
+     | Static | Dynamic -> incr last_id; Some !last_id)
+  in
+  {id; prepare_policy; query; param_type; row_type; row_mult}
+
+let prepare_policy request = request.prepare_policy
+let param_type request = request.param_type
+let row_type request = request.row_type
+let row_mult request = request.row_mult
+
+let query_id request = request.id
+let query request = request.query
+
+let empty_subst _ = raise Not_found
+
+let default_dialect = Dialect.create_unknown ~purpose:`Printing ()
+
+let make_pp ?(dialect = default_dialect) ?(subst = empty_subst) () ppf req =
+  let query = Query.expand subst (req.query dialect) in
+  Format.fprintf ppf "(%a -->%s %a) {|%a|}"
+    Row_type.pp req.param_type
+    (match Row_mult.expose req.row_mult with
+     | `Zero -> "."
+     | `One -> ""
+     | `Zero_or_one -> "?"
+     | `Zero_or_more -> "*")
+    Row_type.pp req.row_type
+    Query.pp query
+
+let pp ppf = make_pp () ppf
+
+let pp_with_param_enabled =
+  (match Sys.getenv "CAQTI_DEBUG_PARAM" with
+   | "true" -> true
+   | "false" -> false
+   | s ->
+      Log.err (fun f ->
+        f "Invalid value %s for CAQTI_DEBUG_PARAM, assuming false." s);
+      false
+   | exception Not_found -> false)
+
+let make_pp_with_param ?dialect ?subst () ppf (req, param) =
+  let pp = make_pp ?subst ?dialect () in
+  pp ppf req;
+  if pp_with_param_enabled then
+    Format.fprintf ppf " %a" (Row.pp req.param_type) param
+
+type liveness_witness = int option
+
+let liveness_witness request =
+  assert (request.id <> None);
+  request.id

unikernel/duniverse/ocaml-caqti/caqti/lib-template/request.mli

@@ -0,0 +1,146 @@
+(* 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.
+ *)
+
+(** Request template.
+
+    A request template combines a function to generate an SQL query template
+    with type descriptors use to encode parameters and decode result rows.
+    The function will receive information about the SQL dialect when called by
+    the chosen database driver library.
+
+    Requests are passed to {!Caqti_connection_sig.S.call} or one of its shortcut
+    methods provided by a database connection handle, and will be turned into a
+    prepared query, cached by the connection handle, if prepared queries are
+    supported by the driver and unless explicitly disabled, see {!create} for
+    details on the latter. *)
+
+(** {2 Primitive Constructor and Accessors} *)
+
+type prepare_policy =
+  | Direct
+    (** The query string is sent to the database on each request, or if the
+        driver only supports prepared queries, the preprepared query will be
+        released after each use.
+        Most importantly nothing is retained by the driver related to request
+        template created with this policy, so this is a safe option for
+        dynamically generated request templates.
+        This option is only a suitable choice when it is known in advance that
+        the request will be executed at most once, or very rarely, such as
+        schema updates. *)
+  | Dynamic
+    (** The query string is prepared once per connection and scheduled for
+        release after the request object has been garbage collected. *)
+  | Static
+    (** The query string is prepared once per connection on not released before
+        the connection is closed.
+        This policy will cause a resource leak on long-lived connections if the
+        template is dynamically generated.
+        As the name suggest, this policy should only be used when the request
+        template has static lifetime. *)
+(** The prepare policy decides whether Caqti drivers use prepared queries and,
+    if so, the expected lifetime of the template. *)
+
+type ('a, 'b, +'m) t constraint 'm = [< `Zero | `One | `Many]
+(** A request specification embedding a query generator, parameter encoder, and
+    row decoder.
+    - ['a] is the type of the expected parameter bundle.
+    - ['b] is the type of a returned row.
+    - ['m] is the possible multiplicities of returned rows. *)
+
+val create :
+  prepare_policy -> ('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
+  ('a, 'b, 'm) t
+(** [create prepare_policy (arg_type, row_type, row_mult) f] is a request
+    template
+
+      - whose query will be prepared (or not) according to [prepare_policy],
+      - which takes parameters of type [arg_type],
+      - which returns rows of type [row_type] with multiplicity [row_mult], and
+      - which submits a query string rendered from the {!Query.t} returned by
+        [f di], where [di] is the {!Dialect.t} supplied by the driver library of
+        the connection.
+
+    The driver is responsible for turning parameter references into a form
+    accepted by the database system, while other dialectical differences must be
+    handled by [f]. *)
+
+val prepare_policy : (_, _, _) t -> prepare_policy
+(** [prepare_policy req] is the prepare policy of [req]. *)
+
+val param_type : ('a, _, _) t -> 'a Row_type.t
+(** [param_type req] is the type of parameter bundles expected by [req]. *)
+
+val row_type : (_, 'b, _) t -> 'b Row_type.t
+(** [row_type req] is the type of rows returned by [req]. *)
+
+val row_mult : (_, _, 'm) t -> 'm Row_mult.t
+(** [row_mult req] indicates how many rows [req] may return.  This is asserted
+    when constructing the query. *)
+
+val query : ('a, 'b, 'm) t -> Dialect.t -> Query.t
+(** [query req] is the function which generates the query of this request
+    possibly tailored for the given driver. *)
+
+
+(** {2 Formatting} *)
+
+val make_pp :
+  ?dialect: Dialect.t ->
+  ?subst: Query.subst ->
+  unit -> Format.formatter -> ('a, 'b, 'm) t -> unit
+(** [make_pp ?subst ?dialect ()] is a pretty-printer for a request, which
+    expands the query using [subst] and [dialect].
+
+    @param subst
+      Used to partially expand the query string. Defaults to the empty
+      substitution.
+
+    @param dialect
+      The driver info to pass to the call-back which returns the query.
+      Defaults to {!Dialect.Unknown}. *)
+
+val pp : Format.formatter -> ('a, 'b, 'm) t -> unit
+(** [pp ppf req] prints [req] on [ppf] in a form suitable for human
+    inspection. *)
+
+val make_pp_with_param :
+  ?dialect: Dialect.t ->
+  ?subst: Query.subst ->
+  unit -> Format.formatter -> ('a, 'b, 'm) t * 'a -> unit
+(** [make_pp_with_param ?subst ?dialect ()] is a pretty-printer for a
+    request and parameter pair.  See {!make_pp} for the optional arguments.
+    This functions is meant for debugging; the output is neither guaranteed to
+    be consistent across releases nor to contain a complete record of the data.
+    Lost database records cannot be reconstructed from the logs.
+
+    Due to concerns about exposure of sensitive data in debug logs, this
+    function only prints the parameter values if [CAQTI_DEBUG_PARAM] is set to
+    [true].  If you enable it for applications which do not consistenly annotate
+    sensitive parameters with {!Row_type.redacted}, make sure your debug logs
+    are well-secured. *)
+
+(**/**)
+[@@@alert "-caqti_private"]
+
+val query_id : ('a, 'b, 'm) t -> int option
+[@@alert caqti_private]
+
+type liveness_witness
+[@@alert caqti_private]
+
+val liveness_witness : (_, _, _) t -> liveness_witness
+[@@alert caqti_private]

unikernel/duniverse/ocaml-caqti/caqti/lib-template/request_type.ml

@@ -0,0 +1,29 @@
+(* 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.
+ *)
+
+type ('a, 'b, 'm) t = 'a Row_type.t * 'b Row_type.t * 'm Row_mult.t
+
+module Infix = struct
+  let ( -->. ) t u = (t, u, Row_mult.zero)
+  let ( -->! ) t u = (t, u, Row_mult.one)
+  let ( -->? ) t u = (t, u, Row_mult.zero_or_one)
+  let ( -->* ) t u = (t, u, Row_mult.zero_or_more)
+end
+
+let param_type (t, _, _) = t
+let row_type (_, u, _) = u
+let row_mult (_, _, m) = m

unikernel/duniverse/ocaml-caqti/caqti/lib-template/request_type.mli

@@ -0,0 +1,40 @@
+(* 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.
+ *)
+
+(** Type descriptors for requests. *)
+
+type ('a, 'b, +'m) t = 'a Row_type.t * 'b Row_type.t * 'm Row_mult.t
+
+module Infix : sig
+
+  val ( -->. ) :
+    'a Row_type.t -> unit Row_type.t -> ('a, unit, Row_mult.zero) t
+
+  val ( -->! ) :
+    'a Row_type.t -> 'b Row_type.t -> ('a, 'b, Row_mult.one) t
+
+  val ( -->? ) :
+    'a Row_type.t -> 'b Row_type.t -> ('a, 'b, Row_mult.zero_or_one) t
+
+  val ( -->* ) :
+    'a Row_type.t -> 'b Row_type.t -> ('a, 'b, Row_mult.zero_or_more) t
+
+end
+
+val param_type : ('a, _, _) t -> 'a Row_type.t
+val row_type : (_, 'b, _) t -> 'b Row_type.t
+val row_mult : (_, _, 'm) t -> 'm Row_mult.t

unikernel/duniverse/ocaml-caqti/caqti/lib-template/row.ml

@@ -0,0 +1,100 @@
+(* 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.
+ *)
+
+(* equal *)
+
+let rec equal_poly : type a. a Row_type.t -> a -> a -> bool =
+  (function
+   | Field ft ->
+      Field_type.equal_value ft
+   | Option t ->
+      let equal_t = equal_poly t in
+      fun x y ->
+        (match x, y with
+         | None, None -> true
+         | Some x, Some y -> equal_t x y
+         | None, Some _ | Some _, None -> false)
+   | Product (_, pt) -> equal_product pt
+   | Annot (_, t) -> equal_poly t)
+
+and equal_product : type i a. (i, a) Row_type.product -> a -> a -> bool =
+  (function
+   | Proj_end -> fun _ _ -> true
+   | Proj (t, p, pt) ->
+      let equal_t = equal_poly t in
+      let equal_pt = equal_product pt in
+      fun x y -> equal_t (p x) (p y) && equal_pt x y)
+
+let equal (t : _ Row_type.t) = equal_poly t
+
+(* pp *)
+
+type pp_state = {
+  mutable field_num: int;
+}
+
+let pp_field_sep state ppf () =
+  if state.field_num > 0 then
+    begin
+      Format.pp_print_char ppf ',';
+      Format.pp_print_space ppf ()
+    end;
+  state.field_num <- state.field_num + 1
+
+let pp_rep_lit n lit state =
+  fun ppf () ->
+    for _ = 1 to n do
+      pp_field_sep state ppf ();
+      Format.pp_print_string ppf lit
+    done
+
+let rec pp_poly
+  : type a. a Row_type.t -> pp_state -> Format.formatter -> a -> unit =
+  (function
+   | Field ft ->
+      fun state ppf x ->
+        pp_field_sep state ppf ();
+        Field_type.pp_value ppf (ft, x)
+   | Option t ->
+      let pp_t = pp_poly t in
+      let length_t = Row_type.length t in
+      fun state ->
+        let case_none = pp_rep_lit length_t "NONE" state in
+        let case_some = pp_t state in
+        fun ppf ->
+          (function None -> case_none ppf () | Some x -> case_some ppf x)
+   | Product (_, pt) -> pp_product pt
+   | Annot (`Redacted, t) ->
+      let length_t = Row_type.length t in
+      fun state ppf _ -> pp_rep_lit length_t "#redacted#" state ppf ())
+
+and pp_product
+  : type i a. (i, a) Row_type.product -> pp_state ->
+    Format.formatter -> a -> unit =
+  (function
+   | Proj_end -> fun _state _ppf _x -> ()
+   | Proj (t, p, pt) ->
+      let pp_t = pp_poly t in
+      let pp_pt = pp_product pt in
+      fun state ->
+        let pp_t_state = pp_t state in
+        let pp_pt_state = pp_pt state in
+        fun ppf x ->
+          pp_t_state ppf (p x);
+          pp_pt_state ppf x)
+
+let pp (t : _ Row_type.t) = pp_poly t {field_num = 1}

unikernel/duniverse/ocaml-caqti/caqti/lib-template/row.mli

@@ -0,0 +1,25 @@
+(* 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.
+ *)
+
+val equal : 'a Row_type.t -> 'a -> 'a -> bool
+(** [equal_value t] is the equality predicate for values of row type [t]. *)
+
+val pp : 'a Row_type.t -> Format.formatter -> 'a -> unit
+(** [pp_value ppf (t, v)] prints a human representation of [v] given the type
+    descriptor [t]. This function is meant for debugging; the output is neither
+    guaranteed to be consistent across releases nor to contain a complete record
+    of the data. *)

unikernel/duniverse/ocaml-caqti/caqti/lib-template/row_mult.ml

@@ -0,0 +1,56 @@
+(* Copyright (C) 2017--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.
+ *)
+
+(** Multiplicities of zero, one, and many. *)
+
+type +'m t = (* not GADT due to variance *)
+ | Zero
+ | One
+ | Zero_or_one
+ | Zero_or_more
+constraint 'm = [< `Zero | `One | `Many]
+
+type zero = [`Zero]
+type one = [`One]
+type zero_or_one = [`Zero | `One]
+type zero_or_more = [`Zero | `One | `Many]
+
+let zero : [> `Zero] t = Zero
+let one : [> `One] t = One
+let zero_or_one : [> `Zero | `One] t = Zero_or_one
+let zero_or_more : ([> `Zero | `One | `Many] as 'a) t = Zero_or_more
+
+let only_zero : [< `Zero] t -> unit =
+  function Zero -> () | _ -> assert false
+let only_one : [< `One] t -> unit =
+  function One -> () | _ -> assert false
+let only_zero_or_one : [< `Zero | `One] t -> unit =
+  function Zero | One -> () | _ -> assert false
+
+let expose = function
+ | Zero -> `Zero
+ | One -> `One
+ | Zero_or_one -> `Zero_or_one
+ | Zero_or_more -> `Zero_or_more
+
+let can_be_zero = function
+ | One -> false
+ | Zero | Zero_or_one | Zero_or_more -> true
+
+let can_be_many = function
+ | Zero | One | Zero_or_one -> false
+ | Zero_or_more -> true

unikernel/duniverse/ocaml-caqti/caqti/lib-template/row_mult.mli

@@ -0,0 +1,39 @@
+(* Copyright (C) 2017--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.
+ *)
+
+(** Row multiplicity. *)
+
+type +'m t constraint 'm = [< `Zero | `One | `Many]
+
+type zero = [`Zero]
+type one = [`One]
+type zero_or_one = [`Zero | `One]
+type zero_or_more = [`Zero | `One | `Many]
+
+val zero : [> `Zero] t
+val one : [> `One] t
+val zero_or_one : [> `Zero | `One] t
+val zero_or_more : [> `Zero | `One | `Many] t
+
+val only_zero : [< `Zero] t -> unit
+val only_one : [< `One] t -> unit
+val only_zero_or_one : [< `Zero | `One] t -> unit
+
+val expose : 'm t -> [`Zero | `One | `Zero_or_one | `Zero_or_more]
+
+val can_be_zero : 'm t -> bool
+val can_be_many : 'm t -> bool

unikernel/duniverse/ocaml-caqti/caqti/lib-template/row_type.ml

@@ -0,0 +1,817 @@
+(* 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 Shims
+
+type annot = [`Redacted] (* TODO: Consider open type. *)
+
+module Private = struct
+  type _ t =
+    | Field : 'a Field_type.t -> 'a t
+    | Option : 'a t -> 'a option t
+    | Product : ('i, 'a) Constructor.t * ('i, 'a) product -> 'a t
+    | Annot : annot * 'a t -> 'a t
+  and (_, _) product =
+    | Proj_end : ('a Constructor.return, 'a) product
+    | Proj : 'b t * ('a -> 'b) * ('i, 'a) product -> ('b -> 'i, 'a) product
+end
+open Private
+
+type 'a t = 'a Private.t
+type ('i, 'a) product = ('i, 'a) Private.product
+
+type any = Any : 'a t -> any
+
+let rec unify : type a b. a t -> b t -> (a, b) Type.eq option =
+  fun t1 t2 ->
+  (match t1, t2 with
+   | Field ft1, Field ft2 -> Field_type.unify ft1 ft2
+   | Field _, _ | _, Field _ -> None
+   | Option t1, Option t2 ->
+      (match unify t1 t2 with
+       | None -> None
+       | Some Equal -> Some Equal)
+   | Option _, _ | _, Option _ -> None
+   | Product (name1, pt1), Product (name2, pt2) ->
+      (match Constructor.unify name1 name2 with
+       | Some dep -> unify_product pt1 pt2 dep
+       | None -> None)
+   | Product _, _ | _, Product _ -> None
+   | Annot (`Redacted, t1), Annot (`Redacted, t2) -> unify t1 t2)
+and unify_product
+  : type i j a b. (i, a) product -> (j, b) product ->
+    (i, j) Constructor.unifier -> (a, b) Type.eq option =
+  fun pt1 pt2 deq ->
+  (match pt1, pt2, deq with
+   | Proj_end, Proj_end, Equal -> Some Type.Equal
+   | Proj (t1, _, pt1), Proj (t2, _, pt2), Assume dep ->
+      Option.bind (unify t1 t2) (fun p -> unify_product pt1 pt2 (dep p))
+   | _ -> .)
+
+(* length *)
+
+let rec length : type a. a t -> int =
+  (function
+   | Field _ -> 1
+   | Option t -> length t
+   | Product (_, pt) -> length_product pt
+   | Annot (_, t) -> length t)
+and length_product : type a i. (i, a) product -> int =
+  (function
+   | Proj_end -> 0
+   | Proj (t, _, pt) -> length t + length_product pt)
+
+(* pp *)
+
+let rec pp : type a. a t -> int -> Format.formatter -> unit -> unit =
+  (function
+   | Field ft ->
+      let string_of_ft = Field_type.to_string ft in
+      fun _ ppf () -> Format.pp_print_string ppf string_of_ft
+   | Option t ->
+      let pp_t = pp t 1 in
+      fun _ ppf () -> Format.fprintf ppf "@[%a@ option@]" pp_t ()
+   | Product (_, Proj_end) ->
+      fun _ ppf () -> Format.pp_print_string ppf "unit"
+   | Product (_, Proj (t0, _, pt)) ->
+      let pp_t0 = pp t0 1 in
+      let pp_pt = pp_product_tail pt in
+      fun prec ->
+        fun ppf () ->
+          if prec > 0 then Format.pp_print_char ppf '(';
+          pp_t0 ppf ();
+          pp_pt ppf ();
+          if prec > 0 then Format.pp_print_char ppf ')'
+   | Annot (`Redacted, t) ->
+      let pp_t = pp t 1 in
+      fun _prec ppf () ->
+        pp_t ppf ();
+        Format.pp_print_string ppf " redacted")
+and pp_product_tail
+  : type a i. (i, a) product -> Format.formatter -> unit -> unit =
+  (function
+   | Proj_end -> fun _ () -> ()
+   | Proj (t, _, pt) ->
+      let pp_t = pp t 1 in
+      let pp_pt = pp_product_tail pt in
+      fun ppf () ->
+        Format.pp_print_string ppf " × ";
+        pp_t ppf ();
+        pp_pt ppf ())
+
+let pp ppf t = pp t 1 ppf ()
+let pp_any ppf (Any t) = pp ppf t
+let show t = Format.asprintf "%a" pp t
+
+let field ft = Field ft
+
+module type STD = sig
+  val bool : bool t
+  val int : int t
+  val int16 : int t
+  val int32 : int32 t
+  val int64 : int64 t
+  val float : float t
+  val string : string t
+  val octets : string t
+  val pdate : Ptime.t t
+  val ptime : Ptime.t t
+  val ptime_span : Ptime.span t
+  val option : 'a t -> 'a option t
+  val redacted : 'a t -> 'a t
+  val unit : unit t
+  val t2 : 'a1 t -> 'a2 t -> ('a1 * 'a2) t
+  val elim_t2 : ('a1 * 'a2) t -> ('a1 t * 'a2 t) option
+  val t3 : 'a1 t -> 'a2 t -> 'a3 t -> ('a1 * 'a2 * 'a3) t
+  val elim_t3 : ('a1 * 'a2 * 'a3) t -> ('a1 t * 'a2 t * 'a3 t) option
+  val t4 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> ('a1 * 'a2 * 'a3 * 'a4) t
+  val elim_t4 :
+    ('a1 * 'a2 * 'a3 * 'a4) t -> ('a1 t * 'a2 t * 'a3 t * 'a4 t) option
+  val t5 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5) t
+  val elim_t5 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t) option
+  val t6 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t
+  val elim_t6 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t) option
+  val t7 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) t
+  val elim_t7 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t) option
+  val t8 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) t
+  val elim_t8 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t) option
+  val t9 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) t
+  val elim_t9 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t)
+      option
+  val t10 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t -> 'a10 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) t
+  val elim_t10 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
+      * 'a10 t) option
+  val t11 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t -> 'a10 t -> 'a11 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) t
+  val elim_t11 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
+      * 'a10 t * 'a11 t) option
+  val t12 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t -> 'a10 t -> 'a11 t -> 'a12 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12) t
+  val elim_t12 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11
+      * 'a12) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
+      * 'a10 t * 'a11 t * 'a12 t) option
+end
+
+let option t = Option t
+
+let rec product_unifier
+  : type a i. (i, a) product -> (i, i) Constructor.unifier =
+  let open Constructor in
+  (function
+   | Proj_end -> Equal
+   | Proj (_, _, prod) -> Assume (fun Type.Equal -> product_unifier prod))
+
+exception Reject of string
+
+let product : type i a. i -> (i, a) product -> a t =
+  fun intro prod ->
+    let open struct
+      open Constructor
+      type (_, _) tag += Tag : (i, a) tag
+      let unify_tag : type j b. (j, b) tag -> (i, j) unifier option =
+        (function
+         | Tag -> Some (product_unifier prod)
+         | _ -> None)
+      let ctor = {tag = Tag; unify_tag; construct = intro}
+    end in
+    Product (ctor, prod)
+
+let product' ctor prod = Product (ctor, prod)
+
+let proj t p prod = Proj (t, p, prod)
+let proj_end = Proj_end
+
+let enum ~encode ~decode name =
+  product decode
+    @@ proj (Field (Enum name)) encode
+    @@ proj_end
+
+let unit = product (Ok ()) proj_end
+
+type (_, _) Constructor.tag +=
+  | T2 : (
+      'a0 -> 'a1 -> ('a0 * 'a1) Constructor.return,
+      'a0 * 'a1
+    ) Constructor.tag
+  | T3 : (
+      'a0 -> 'a1 -> 'a2 -> ('a0 * 'a1 * 'a2) Constructor.return,
+      'a0 * 'a1 * 'a2
+    ) Constructor.tag
+  | T4 : (
+      'a0 -> 'a1 -> 'a2 -> 'a3 ->
+      ('a0 * 'a1 * 'a2 * 'a3) Constructor.return,
+      'a0 * 'a1 * 'a2 * 'a3
+    ) Constructor.tag
+  | T5 : (
+      'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 ->
+      ('a0 * 'a1 * 'a2 * 'a3 * 'a4) Constructor.return,
+      'a0 * 'a1 * 'a2 * 'a3 * 'a4
+    ) Constructor.tag
+  | T6 : (
+      'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 ->
+      ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5) Constructor.return,
+      'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5
+    ) Constructor.tag
+  | T7 : (
+      'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 ->
+      ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) Constructor.return,
+      'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6
+    ) Constructor.tag
+  | T8 : (
+      'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 ->
+      ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) Constructor.return,
+      'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7
+    ) Constructor.tag
+  | T9 : (
+      'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 ->
+      ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8)
+        Constructor.return,
+      'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8
+    ) Constructor.tag
+  | T10 : (
+      'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 ->
+      ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9)
+        Constructor.return,
+      'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9
+    ) Constructor.tag
+  | T11 : (
+      'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 ->
+      'a10 ->
+      ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10)
+        Constructor.return,
+      'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10
+    ) Constructor.tag
+  | T12 : (
+      'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 ->
+      'a10 -> 'a11 ->
+      ('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11)
+        Constructor.return,
+      'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11
+    ) Constructor.tag
+
+let t2 =
+  let unify_tag
+    : type j b a0 a1.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> (a0 * a1) Constructor.return, j) Constructor.unifier option =
+    (function
+     | T2 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal)))
+     | _ -> None)
+  in
+  let construct x0 x1 = Ok (x0, x1) in
+  fun t0 t1 ->
+    product' {tag = T2; unify_tag; construct}
+    @@ proj t0 fst
+    @@ proj t1 snd
+    @@ proj_end
+
+let elim_t2 : type a0 a1. (a0 * a1) t -> (a0 t * a1 t) option =
+  (function
+   | Product ({tag = T2; _}, Proj (t0, _, Proj (t1, _, Proj_end))) ->
+      Some (t0, t1)
+   | _ -> None)
+
+let t3 =
+  let unify_tag
+    : type j b a0 a1 a2.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> (a0 * a1 * a2) Constructor.return, j)
+        Constructor.unifier option =
+    (function
+     | T3 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal))))
+     | _ -> None)
+  in
+  let construct x0 x1 x2 = Ok (x0, x1, x2) in
+  fun t0 t1 t2 ->
+    product' {tag = T3; unify_tag; construct}
+    @@ proj t0 (fun (x, _, _) -> x)
+    @@ proj t1 (fun (_, x, _) -> x)
+    @@ proj t2 (fun (_, _, x) -> x)
+    @@ proj_end
+
+let elim_t3 : type a0 a1 a2. (a0 * a1 * a2) t -> (a0 t * a1 t * a2 t) option =
+  (function
+   | Product ({tag = T3; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _, Proj_end)))) ->
+      Some (t0, t1, t2)
+   | _ -> None)
+
+let t4 =
+  let unify_tag
+    : type j b a0 a1 a2 a3.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> a3 -> (a0 * a1 * a2 * a3) Constructor.return, j)
+        Constructor.unifier option =
+    (function
+     | T4 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal)))))
+     | _ -> None)
+  in
+  let construct x0 x1 x2 x3 = Ok (x0, x1, x2, x3) in
+  fun t0 t1 t2 t3 ->
+    product' {tag = T4; unify_tag; construct}
+    @@ proj t0 (fun (x, _, _, _) -> x)
+    @@ proj t1 (fun (_, x, _, _) -> x)
+    @@ proj t2 (fun (_, _, x, _) -> x)
+    @@ proj t3 (fun (_, _, _, x) -> x)
+    @@ proj_end
+
+let elim_t4
+  : type a0 a1 a2 a3.
+    (a0 * a1 * a2 * a3) t -> (a0 t * a1 t * a2 t * a3 t) option =
+  (function
+   | Product ({tag = T4; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _,
+        Proj (t3, _, Proj_end))))) ->
+      Some (t0, t1, t2, t3)
+   | _ -> None)
+
+let t5 =
+  let unify_tag
+    : type j b a0 a1 a2 a3 a4.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> a3 -> a4 ->
+       (a0 * a1 * a2 * a3 * a4) Constructor.return, j)
+        Constructor.unifier option =
+    (function
+     | T5 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal))))))
+     | _ -> None)
+  in
+  let construct x0 x1 x2 x3 x4 = Ok (x0, x1, x2, x3, x4) in
+  fun t0 t1 t2 t3 t4 ->
+    product' {tag = T5; unify_tag; construct}
+    @@ proj t0 (fun (x, _, _, _, _) -> x)
+    @@ proj t1 (fun (_, x, _, _, _) -> x)
+    @@ proj t2 (fun (_, _, x, _, _) -> x)
+    @@ proj t3 (fun (_, _, _, x, _) -> x)
+    @@ proj t4 (fun (_, _, _, _, x) -> x)
+    @@ proj_end
+
+let elim_t5
+  : type a0 a1 a2 a3 a4.
+    (a0 * a1 * a2 * a3 * a4) t -> (a0 t * a1 t * a2 t * a3 t * a4 t) option =
+  (function
+   | Product ({tag = T5; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _,
+        Proj (t3, _,
+        Proj (t4, _, Proj_end)))))) ->
+      Some (t0, t1, t2, t3, t4)
+   | _ -> None)
+
+let t6 =
+  let unify_tag
+    : type j b a0 a1 a2 a3 a4 a5.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> a3 -> a4 -> a5 ->
+       (a0 * a1 * a2 * a3 * a4 * a5) Constructor.return, j)
+        Constructor.unifier option =
+    (function
+     | T6 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal)))))))
+     | _ -> None)
+  in
+  fun t0 t1 t2 t3 t4 t5 ->
+    let construct x0 x1 x2 x3 x4 x5 = Ok (x0, x1, x2, x3, x4, x5) in
+    product' {tag = T6; unify_tag; construct}
+    @@ proj t0 (fun (x, _, _, _, _, _) -> x)
+    @@ proj t1 (fun (_, x, _, _, _, _) -> x)
+    @@ proj t2 (fun (_, _, x, _, _, _) -> x)
+    @@ proj t3 (fun (_, _, _, x, _, _) -> x)
+    @@ proj t4 (fun (_, _, _, _, x, _) -> x)
+    @@ proj t5 (fun (_, _, _, _, _, x) -> x)
+    @@ proj_end
+
+let elim_t6
+  : type a0 a1 a2 a3 a4 a5.
+    (a0 * a1 * a2 * a3 * a4 * a5) t ->
+    (a0 t * a1 t * a2 t * a3 t * a4 t * a5 t) option =
+  (function
+   | Product ({tag = T6; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _,
+        Proj (t3, _,
+        Proj (t4, _,
+        Proj (t5, _, Proj_end))))))) ->
+      Some (t0, t1, t2, t3, t4, t5)
+   | _ -> None)
+
+let t7 t0 t1 t2 t3 t4 t5 t6 =
+  let unify_tag
+    : type j b a0 a1 a2 a3 a4 a5 a6.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 ->
+       (a0 * a1 * a2 * a3 * a4 * a5 * a6) Constructor.return, j)
+        Constructor.unifier option =
+    (function
+     | T7 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal))))))))
+     | _ -> None)
+  in
+  let construct x0 x1 x2 x3 x4 x5 x6 = Ok (x0, x1, x2, x3, x4, x5, x6) in
+  product' {tag = T7; unify_tag; construct}
+  @@ proj t0 (fun (x, _, _, _, _, _, _) -> x)
+  @@ proj t1 (fun (_, x, _, _, _, _, _) -> x)
+  @@ proj t2 (fun (_, _, x, _, _, _, _) -> x)
+  @@ proj t3 (fun (_, _, _, x, _, _, _) -> x)
+  @@ proj t4 (fun (_, _, _, _, x, _, _) -> x)
+  @@ proj t5 (fun (_, _, _, _, _, x, _) -> x)
+  @@ proj t6 (fun (_, _, _, _, _, _, x) -> x)
+  @@ proj_end
+
+let elim_t7
+  : type a0 a1 a2 a3 a4 a5 a6.
+    (a0 * a1 * a2 * a3 * a4 * a5 * a6) t ->
+    (a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t) option =
+  (function
+   | Product ({tag = T7; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _,
+        Proj (t3, _,
+        Proj (t4, _,
+        Proj (t5, _,
+        Proj (t6, _, Proj_end)))))))) ->
+      Some (t0, t1, t2, t3, t4, t5, t6)
+   | _ -> None)
+
+let t8 t0 t1 t2 t3 t4 t5 t6 t7 =
+  let unify_tag
+    : type j b a0 a1 a2 a3 a4 a5 a6 a7.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 ->
+       (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7) Constructor.return, j)
+        Constructor.unifier option =
+    (function
+     | T8 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal)))))))))
+     | _ -> None)
+  in
+  let construct x0 x1 x2 x3 x4 x5 x6 x7 = Ok (x0, x1, x2, x3, x4, x5, x6, x7) in
+  product' {tag = T8; unify_tag; construct}
+  @@ proj t0 (fun (x, _, _, _, _, _, _, _) -> x)
+  @@ proj t1 (fun (_, x, _, _, _, _, _, _) -> x)
+  @@ proj t2 (fun (_, _, x, _, _, _, _, _) -> x)
+  @@ proj t3 (fun (_, _, _, x, _, _, _, _) -> x)
+  @@ proj t4 (fun (_, _, _, _, x, _, _, _) -> x)
+  @@ proj t5 (fun (_, _, _, _, _, x, _, _) -> x)
+  @@ proj t6 (fun (_, _, _, _, _, _, x, _) -> x)
+  @@ proj t7 (fun (_, _, _, _, _, _, _, x) -> x)
+  @@ proj_end
+
+let elim_t8
+  : type a0 a1 a2 a3 a4 a5 a6 a7.
+    (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7) t ->
+    (a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t) option =
+  (function
+   | Product ({tag = T8; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _,
+        Proj (t3, _,
+        Proj (t4, _,
+        Proj (t5, _,
+        Proj (t6, _,
+        Proj (t7, _, Proj_end))))))))) ->
+      Some (t0, t1, t2, t3, t4, t5, t6, t7)
+   | _ -> None)
+
+let t9 t1 t2 t3 t4 t5 t6 t7 t8 t9 =
+  let unify_tag
+    : type j b a0 a1 a2 a3 a4 a5 a6 a7 a8.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 ->
+       (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8) Constructor.return, j)
+        Constructor.unifier option =
+    (function
+     | T9 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal))))))))))
+     | _ -> None)
+  in
+  let construct x0 x1 x2 x3 x4 x5 x6 x7 x8 =
+    Ok (x0, x1, x2, x3, x4, x5, x6, x7, x8)
+  in
+  product' {tag = T9; unify_tag; construct}
+  @@ proj t1 (fun (x, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t2 (fun (_, x, _, _, _, _, _, _, _) -> x)
+  @@ proj t3 (fun (_, _, x, _, _, _, _, _, _) -> x)
+  @@ proj t4 (fun (_, _, _, x, _, _, _, _, _) -> x)
+  @@ proj t5 (fun (_, _, _, _, x, _, _, _, _) -> x)
+  @@ proj t6 (fun (_, _, _, _, _, x, _, _, _) -> x)
+  @@ proj t7 (fun (_, _, _, _, _, _, x, _, _) -> x)
+  @@ proj t8 (fun (_, _, _, _, _, _, _, x, _) -> x)
+  @@ proj t9 (fun (_, _, _, _, _, _, _, _, x) -> x)
+  @@ proj_end
+
+let elim_t9
+  : type a0 a1 a2 a3 a4 a5 a6 a7 a8.
+    (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8) t ->
+    (a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t * a8 t) option =
+  (function
+   | Product ({tag = T9; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _,
+        Proj (t3, _,
+        Proj (t4, _,
+        Proj (t5, _,
+        Proj (t6, _,
+        Proj (t7, _,
+        Proj (t8, _, Proj_end)))))))))) ->
+      Some (t0, t1, t2, t3, t4, t5, t6, t7, t8)
+   | _ -> None)
+
+let t10 t0 t1 t2 t3 t4 t5 t6 t7 t8 t9 =
+  let unify_tag
+    : type j b a0 a1 a2 a3 a4 a5 a6 a7 a8 a9.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 ->
+       (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9)
+         Constructor.return, j) Constructor.unifier option =
+    (function
+     | T10 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal)))))))))))
+     | _ -> None)
+  in
+  let construct x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 =
+    Ok (x0, x1, x2, x3, x4, x5, x6, x7, x8, x9)
+  in
+  product' {tag = T10; unify_tag; construct}
+  @@ proj t0 (fun (x, _, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t1 (fun (_, x, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t2 (fun (_, _, x, _, _, _, _, _, _, _) -> x)
+  @@ proj t3 (fun (_, _, _, x, _, _, _, _, _, _) -> x)
+  @@ proj t4 (fun (_, _, _, _, x, _, _, _, _, _) -> x)
+  @@ proj t5 (fun (_, _, _, _, _, x, _, _, _, _) -> x)
+  @@ proj t6 (fun (_, _, _, _, _, _, x, _, _, _) -> x)
+  @@ proj t7 (fun (_, _, _, _, _, _, _, x, _, _) -> x)
+  @@ proj t8 (fun (_, _, _, _, _, _, _, _, x, _) -> x)
+  @@ proj t9 (fun (_, _, _, _, _, _, _, _, _, x) -> x)
+  @@ proj_end
+
+let elim_t10
+  : type a0 a1 a2 a3 a4 a5 a6 a7 a8 a9.
+    (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9) t ->
+    (a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t * a8 t * a9 t)
+      option =
+  (function
+   | Product ({tag = T10; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _,
+        Proj (t3, _,
+        Proj (t4, _,
+        Proj (t5, _,
+        Proj (t6, _,
+        Proj (t7, _,
+        Proj (t8, _,
+        Proj (t9, _, Proj_end))))))))))) ->
+      Some (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9)
+   | _ -> None)
+
+let t11 t0 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 =
+  let unify_tag
+    : type j b a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 ->
+       (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9 * a10)
+         Constructor.return, j) Constructor.unifier option =
+    (function
+     | T11 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal))))))))))))
+     | _ -> None)
+  in
+  let construct x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 =
+    Ok (x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10)
+  in
+  product' {tag = T11; unify_tag; construct}
+  @@ proj t0  (fun (x, _, _, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t1  (fun (_, x, _, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t2  (fun (_, _, x, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t3  (fun (_, _, _, x, _, _, _, _, _, _, _) -> x)
+  @@ proj t4  (fun (_, _, _, _, x, _, _, _, _, _, _) -> x)
+  @@ proj t5  (fun (_, _, _, _, _, x, _, _, _, _, _) -> x)
+  @@ proj t6  (fun (_, _, _, _, _, _, x, _, _, _, _) -> x)
+  @@ proj t7  (fun (_, _, _, _, _, _, _, x, _, _, _) -> x)
+  @@ proj t8  (fun (_, _, _, _, _, _, _, _, x, _, _) -> x)
+  @@ proj t9  (fun (_, _, _, _, _, _, _, _, _, x, _) -> x)
+  @@ proj t10 (fun (_, _, _, _, _, _, _, _, _, _, x) -> x)
+  @@ proj_end
+
+let elim_t11
+  : type a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
+    (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9 * a10) t ->
+    (a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t * a8 t * a9 t
+      * a10 t) option =
+  (function
+   | Product ({tag = T11; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _,
+        Proj (t3, _,
+        Proj (t4, _,
+        Proj (t5, _,
+        Proj (t6, _,
+        Proj (t7, _,
+        Proj (t8, _,
+        Proj (t9, _,
+        Proj (t10, _, Proj_end)))))))))))) ->
+      Some (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10)
+   | _ -> None)
+
+let t12 t0 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 =
+  let unify_tag
+    : type j b a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11.
+      (j, b) Constructor.tag ->
+      (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 ->
+        (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9 * a10 * a11)
+          Constructor.return, j) Constructor.unifier option =
+    (function
+     | T12 ->
+        Some (Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal ->
+              Assume (fun Type.Equal -> Equal)))))))))))))
+     | _ -> None)
+  in
+  let construct x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 =
+    Ok (x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11)
+  in
+  product' {tag = T12; unify_tag; construct}
+  @@ proj t0  (fun (x, _, _, _, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t1  (fun (_, x, _, _, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t2  (fun (_, _, x, _, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t3  (fun (_, _, _, x, _, _, _, _, _, _, _, _) -> x)
+  @@ proj t4  (fun (_, _, _, _, x, _, _, _, _, _, _, _) -> x)
+  @@ proj t5  (fun (_, _, _, _, _, x, _, _, _, _, _, _) -> x)
+  @@ proj t6  (fun (_, _, _, _, _, _, x, _, _, _, _, _) -> x)
+  @@ proj t7  (fun (_, _, _, _, _, _, _, x, _, _, _, _) -> x)
+  @@ proj t8  (fun (_, _, _, _, _, _, _, _, x, _, _, _) -> x)
+  @@ proj t9  (fun (_, _, _, _, _, _, _, _, _, x, _, _) -> x)
+  @@ proj t10 (fun (_, _, _, _, _, _, _, _, _, _, x, _) -> x)
+  @@ proj t11 (fun (_, _, _, _, _, _, _, _, _, _, _, x) -> x)
+  @@ proj_end
+
+let elim_t12
+  : type a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11.
+    (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9 * a10 * a11) t ->
+    (a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t * a8 t * a9 t
+      * a10 t * a11 t) option =
+  (function
+   | Product ({tag = T12; _},
+        Proj (t0, _,
+        Proj (t1, _,
+        Proj (t2, _,
+        Proj (t3, _,
+        Proj (t4, _,
+        Proj (t5, _,
+        Proj (t6, _,
+        Proj (t7, _,
+        Proj (t8, _,
+        Proj (t9, _,
+        Proj (t10, _,
+        Proj (t11, _, Proj_end))))))))))))) ->
+      Some (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11)
+   | _ -> None)
+
+let custom ~encode ~decode rep =
+  let encode' x =
+    (match encode x with
+     | Ok y -> y
+     | Error msg -> raise (Reject msg))
+  in
+  product decode @@ proj rep encode' @@ proj_end
+
+let redacted t = Annot (`Redacted, t)
+
+let bool = field Bool
+let int = field Int
+let int16 = field Int16
+let int32 = field Int32
+let int64 = field Int64
+let float = field Float
+let string = field String
+let octets = field Octets
+let pdate = field Pdate
+let ptime = field Ptime
+let ptime_span = field Ptime_span

unikernel/duniverse/ocaml-caqti/caqti/lib-template/row_type.mli

@@ -0,0 +1,346 @@
+(* Copyright (C) 2018--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.
+ *)
+
+(** Database row types, also used for parameters. *)
+
+[@@@alert "-caqti_private"]
+
+open Shims
+
+type annot = [`Redacted] (* TODO: Consider open type. *)
+
+(**/**)
+module Private : sig
+
+  type _ t =
+    | Field : 'a Field_type.t -> 'a t
+    | Option : 'a t -> 'a option t
+    | Product : ('i, 'a) Constructor.t * ('i, 'a) product -> 'a t
+    | Annot : annot * 'a t -> 'a t
+  and (_, _) product =
+    | Proj_end : ('a Constructor.return, 'a) product
+    | Proj : 'b t * ('a -> 'b) * ('i, 'a) product -> ('b -> 'i, 'a) product
+end
+[@@alert caqti_private
+  "This module exposes the internal representation of row types, which may \
+   change between minor relases without prior notice."]
+(**/**)
+
+(** {2:row_types Row Types} *)
+
+type 'a t = 'a Private.t
+(** Type descriptor for row types. *)
+
+type ('i, 'a) product = ('i, 'a) Private.product
+(** Type descriptor used for building cartesian products of row types. *)
+
+type any = Any : 'a t -> any
+(** {!t} with existentially wrapped static type. *)
+
+val unify : 'a t -> 'b t -> ('a, 'b) Type.eq option
+(** If [t1] and [t2] are the same row type representations, then [unify t1 t2]
+    is the witness of the unification of their static type parameters, otherwise
+    it is [None]. *)
+
+val length : 'a t -> int
+(** [length t] is the number of fields used to represent [t]. *)
+
+val pp : Format.formatter -> 'a t -> unit
+(** [pp ppf t] prints a human presentation of [t] on [ppf]. *)
+
+val pp_any : Format.formatter -> any -> unit
+(** [pp_any ppf t] prints a human presentation of [t] on [ppf]. *)
+
+val show : 'a t -> string
+(** [show t] is a human presentation of [t]. *)
+
+val field : 'a Field_type.t -> 'a t
+(** [field ft] is a row of a single field of type [ft]. This function can be
+    used when adding new field types; use the below functions otherwise. *)
+
+exception Reject of string
+(** Implementers of {!val-product} types may raise this exception to signal that
+    a conversion cannot be carried out. *)
+
+val product : 'i -> ('i, 'a) product -> 'a t
+val product' : ('i, 'a) Constructor.t -> ('i, 'a) product -> 'a t
+val proj : 'b t -> ('a -> 'b) -> ('i, 'a) product -> ('b -> 'i, 'a) product
+val proj_end : ('a Constructor.return, 'a) product
+(** Given a set of projection functions [p1 : t -> t1], ..., [pN : t -> tN] and
+    a function [intro : t1 -> ... -> tN -> t] to reconstruct values of [t] from
+    the projections,
+    {@ocaml skip[
+      product intro
+        @@ proj t1 p1
+        @@ ...
+        @@ proj tN pN
+        @@ proj_end
+    ]}
+    defines a Caqti type for [t], which on the database side will be represented
+    by a consecutive list of fields corresponding to the types [t1], ..., [tN],
+    each of which may be represented by multiple fields.
+    That is, [intro [project1 x] ...  [projectN x]] is equivalent to [x]
+    according to an enforced or effective abstraction of [t] deemed adequate for
+    the application logic.
+
+    [intro] may raise {!Reject} to indicate that a value cannot be constructed
+    from the given arguments.
+    Projection operators may also raise this exception to indicate that an
+    object cannot be represented in the database, e.g. due to an overflow.
+
+    The above only states that [intro] is a left (pseudo-)inverse of the
+    projections, which is what matters for a faithful representation of OCaml
+    values.
+    The opposite (projection functions being the left inverse of [intro]) may
+    be relevant if the application needs preserve the database representation
+    when updating objects. *)
+
+val enum :
+  encode: ('a -> string) ->
+  decode: (string -> ('a, string) result) ->
+  string -> 'a t
+(** [enum ~encode ~decode name] creates an enum type which on the SQL side is
+    named [name], with cases which are converted with [encode] and [decode]
+    functions. This is implemented in terms of the {!Field_type.Enum} field
+    type. *)
+
+val custom :
+  encode: ('a -> ('b, string) result) ->
+  decode: ('b -> ('a, string) result) ->
+  'b t -> 'a t
+(** [custom ~encode ~decode rep] creates a custom type represented by [rep],
+    where [encode] is used to encode parameters into [rep] and [decode] is used
+    to decode result rows from [rep]. *)
+
+(** Standard type descriptors to use for request construction. *)
+module type STD = sig
+
+  (** {3 Field Types}
+
+      The following types correspond to what usually fits in a single field of a
+      result row or input parameter set. *)
+
+  val bool : bool t
+  (** A [bool] mapped to [boolean] on the SQL side if supported, otherwise
+      mapped to an integer. *)
+
+  val int : int t
+  (** An [int] mapped to a sufficiently wide integer on the SQL side. *)
+
+  val int16 : int t
+  (** An [int] mapped to a [smallint] (16 bits) on the SQL side. *)
+
+  val int32 : int32 t
+  (** An [int32] mapped to an [integer] (32 bits) on the SQL side. *)
+
+  val int64 : int64 t
+  (** An [int64] mapped to a [bigint] (64 bits) on the SQL side. *)
+
+  val float : float t
+  (** A [float] mapped to [double precision] or (best alternative) on the SQL
+      side. Serialization may be lossy (e.g. base 10 may be used), so even if
+      both sides support IEEE 754 double precision numbers, there may be
+      discrepancies in the last digits of the binary representaton. *)
+
+  val string : string t
+  (** An UTF-8 string. The database should accept UTF-8 if non-ASCII characters
+      are present. *)
+
+  val octets : string t
+  (** A [string] mapped to whichever type is used to represent binary data on
+      the SQL side. *)
+
+  val pdate : Ptime.t t
+  (** A time truncated to a date and mapped to the SQL [date] type. *)
+
+  val ptime : Ptime.t t
+  (** An absolute time with driver-dependent precision. This corresponds to an
+      SQL [timestamp with time zone] or a suitable alternative where not
+      available:
+
+        - MariaDB has [datetime] which is similar to the SQL [timestamp] and
+          [timestamp] which is similar to the SQL [timestamp with time zone],
+          but the driver does not make the distinction.  Caqti sets the session
+          time zone to UTC to avoid misinterpretation, since time values are
+          passed in both directions without time zones.  Values have microsecond
+          precision, but you will need to specify the desired precision in the
+          database schema to avoid truncation.
+
+        - PostgreSQL supports this type and it's a good option to avoid any time
+          zone issues if used conistently both on the client side, in SQL
+          expressions, and in the database schema.
+          Note that [timestamp with time zone] is stored as UTC without time
+          zone, taking up no more space then [timestamp].
+          The PostgreSQL [timestamp] type is problematic since how conversions
+          work and the manual indicate that it is meant to be a local time, and
+          since database columns of this type stores the value without
+          conversion to UTC, it becomes prone to time zone changes.
+          To mitigate the issue, Caqti sets the time zone of sessions to UTC.
+
+        - Sqlite3 does not have a dedicated type for absolute time.  The date
+          and time is sent as strings expressed at the UTC time zone using same
+          format that the SQLite {{:https://sqlite.org/lang_datefunc.html}
+          datetime} function and [CURRENT_TIMESTAMP] return, except for an
+          additional three decimals to achive millisecond precision.
+
+          It might seem better to use standard RFC3339 format, since it is
+          accepted by the SQLite functions, but that would misorder some time
+          values if mixed with the results of these functions, even just the "Z"
+          suffix would misorder values with different precision.
+
+      Date and time values which comes from the database without time zone are
+      interpreted as UTC. This is not necessarily correct, and it is highly
+      recommended to use SQL types which are transmitted with time zone
+      information, even if this is UTC. *)
+
+  val ptime_span : Ptime.span t
+  (** A period of time. If the database lacks a dedicated representation, the
+      integer number of seconds is used. *)
+
+
+  (** {3 Composite Types} *)
+
+  val option : 'a t -> 'a option t
+  (** [option t] turns a set of fields encoded as [t] into a correspending set
+      of nullable fields.  The encoder will encode [None] as into a tuple of
+      [NULL] values and the decoder will return [None] if all fields are [NULL].
+
+      If the type [t] itself is [option t'] for some [t'], or contains nested
+      tuples and options such that all field types are nested under an option
+      type, then it would have been possible to decode an all-[NULL] segment of
+      a row as [Some x] where [x] is a corresponding tuple-option-tree
+      terminating in [None] values.  The above paragraph resolves this ambiguity
+      since it implies that the outermost option possible will be decoded as
+      [None]. *)
+
+  val redacted : 'a t -> 'a t
+  (** [redacted t] is the same type as [t] but sealed as potentially containing
+      sensitive information to be redacted from pretty-printers and logs. *)
+
+
+  (** {3 Tuple Types}
+
+      As a common case of composite types, constructors for tuples up to 12
+      components are predefined here.  Higher tuples can be created with
+      {!Row_type.val-product}. *)
+
+  val unit : unit t
+  (** A type holding no fields. This is used to pass no parameters and as the
+      result for queries which does not return any rows. It can also be nested
+      in tuples, in which case it will not contribute to the total number of
+      fields. *)
+
+  val t2 : 'a1 t -> 'a2 t -> ('a1 * 'a2) t
+  (** Creates a pair type. *)
+
+  val elim_t2 : ('a1 * 'a2) t -> ('a1 t * 'a2 t) option
+
+  val t3 : 'a1 t -> 'a2 t -> 'a3 t -> ('a1 * 'a2 * 'a3) t
+  (** Creates a 3-tuple type. *)
+
+  val elim_t3 : ('a1 * 'a2 * 'a3) t -> ('a1 t * 'a2 t * 'a3 t) option
+
+  val t4 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> ('a1 * 'a2 * 'a3 * 'a4) t
+  (** Creates a 4-tuple type. *)
+
+  val elim_t4 :
+    ('a1 * 'a2 * 'a3 * 'a4) t -> ('a1 t * 'a2 t * 'a3 t * 'a4 t) option
+
+  val t5 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5) t
+  (** Creates a 5-tuple type. *)
+
+  val elim_t5 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t) option
+
+  val t6 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t
+  (** Creates a 6-tuple type. *)
+
+  val elim_t6 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t) option
+
+  val t7 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) t
+  (** Creates a 7-tuple type. *)
+
+  val elim_t7 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t) option
+
+  val t8 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) t
+  (** Creates a 8-tuple type. *)
+
+  val elim_t8 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t) option
+
+  val t9 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) t
+  (** Creates a 9-tuple type. *)
+
+  val elim_t9 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t)
+      option
+
+  val t10 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t -> 'a10 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) t
+  (** Creates a 10-tuple type. *)
+
+  val elim_t10 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
+      * 'a10 t) option
+
+  val t11 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t -> 'a10 t -> 'a11 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) t
+  (** Creates a 11-tuple type. *)
+
+  val elim_t11 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
+      * 'a10 t * 'a11 t) option
+
+  val t12 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t -> 'a10 t -> 'a11 t -> 'a12 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12) t
+  (** Creates a 12-tuple type. *)
+
+  val elim_t12 :
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11
+      * 'a12) t ->
+    ('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
+      * 'a10 t * 'a11 t * 'a12 t) option
+
+end
+
+include STD

unikernel/duniverse/ocaml-caqti/caqti/lib-template/shims.5.1.ml

@@ -0,0 +1,20 @@
+(* 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 Type = struct
+  type ('a, 'b) eq = ('a, 'b) Stdlib.Type.eq = Equal : ('a, 'a) eq
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-template/shims.5.1.mli

@@ -0,0 +1,26 @@
+(* 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.
+ *)
+
+(** Compatibility shims.
+
+    The documentation of this interface is generated for OCaml 5.1 and later.
+    It depends on recent additions to the standard library.
+    For older compilers, an equivalent implementation is provided. *)
+
+module Type : sig
+  type ('a, 'b) eq = ('a, 'b) Stdlib.Type.eq = Equal : ('a, 'a) eq
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-template/shims.fallback.ml

@@ -0,0 +1,20 @@
+(* Copyright (C) 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 = struct
+  type (_, _) eq = Equal : ('a, 'a) eq (* OCaml 5.1 *)
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-template/shims.fallback.mli

@@ -0,0 +1,28 @@
+(* Copyright (C) 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.
+ *)
+
+(** Compatibility shims.
+
+    This is the fallback implementation providing replacements for recent
+    additions to the standard library. *)
+
+module Type : sig
+  type (_, _) eq = Equal : ('a, 'a) eq
+  (** Type equality witness.  This will eventually be replaced by the equavalent
+      definition available in [Stdlib.Type] since OCaml 5.1, but for now, we
+      must keep backwards compatibility with older compilers. *)
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-template/version.ml

@@ -0,0 +1,106 @@
+(* Copyright (C) 2024--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.
+ *)
+
+type t = string
+
+let is_known v = v <> ""
+
+let rec skip_zeros_from s i =
+  if i = String.length s || s.[i] <> '0' then i else
+  skip_zeros_from s (i + 1)
+
+let rec skip_digits_from s i =
+  if i = String.length s then i else
+  (match s.[i] with
+   | '0'..'9' -> skip_digits_from s (i + 1)
+   | _ -> i)
+
+let rec compare_with_empty v i j =
+  if i = j then 0 else
+  (match v.[i] with
+   | '~' -> -1
+   | '0' | '.' | '-' -> compare_with_empty v (i + 1) j
+   | _ -> 1)
+
+let compare_char chL chR =
+  if chL = chR then 0 else
+  if chL = '~' then -1 else
+  if chR = '~' then +1 else
+  Char.compare chL chR
+
+let skip_group s i =
+  (match String.index_from_opt s i '-' with
+   | None -> String.length s
+   | Some j -> j)
+
+let compare vL vR =
+  let nL, nR = String.length vL, String.length vR in
+  let rec start iL iR =
+    if iL = nL && iR = nR then 0 else
+    if iL = nL then - compare_with_empty vR iR nR else
+    if iR = nR then + compare_with_empty vL iL nL else
+    (match vL.[iL], vR.[iR] with
+     | '.', '.' -> start (iL + 1) (iR + 1)
+     | '-', '-' -> start (iL + 1) (iR + 1)
+     | '.', '-' ->
+        let jL = skip_group vL (iL + 1) in
+        let c = compare_with_empty vL (iL + 1) jL in
+        if c <> 0 then +c else start jL iR
+     | '-', '.' ->
+        let jR = skip_group vR (iR + 1) in
+        let c = compare_with_empty vR (iR + 1) jR in
+        if c <> 0 then -c else start iL jR
+     | '0'..'9', '0'..'9' ->
+        let iL = skip_zeros_from vL iL in
+        let iR = skip_zeros_from vR iR in
+        let kL = skip_digits_from vL iL in
+        let kR = skip_digits_from vR iR in
+        if kL - iL < kR - iR then -1 else
+        if kL - iL > kR - iR then +1 else
+        let c = digits iL iR (kL - iL) in
+        if c < 0 then -1 else
+        if c > 0 then +1 else
+        start kL kR
+     | chL, chR ->
+        let c = compare_char chL chR in
+        if c < 0 then -1 else
+        if c > 0 then +1 else
+        start (iL + 1) (iR + 1))
+  and digits iL iR n =
+    if n = 0 then start iL iR else
+    let c = Char.compare vL.[iL] vR.[iR] in
+    if c < 0 then -1 else
+    if c > 0 then +1 else
+    digits (iL + 1) (iR + 1) (n - 1)
+  in
+  start 0 0
+
+let equal vL vR = compare vL vR = 0
+
+let pp ppf version =
+  Format.pp_print_string ppf (if is_known version then version else "[unknown]")
+
+let of_string_unsafe version = version
+
+module Infix = struct
+  let ( =* ) v1 v2 = compare v1 v2 = 0
+  let ( <>* ) v1 v2 = compare v1 v2 <> 0
+  let ( <* ) v1 v2 = compare v1 v2 < 0
+  let ( <=* ) v1 v2 = compare v1 v2 <= 0
+  let ( >* ) v1 v2 = compare v1 v2 > 0
+  let ( >=* ) v1 v2 = compare v1 v2 >= 0
+end

unikernel/duniverse/ocaml-caqti/caqti/lib-template/version.mli

@@ -0,0 +1,84 @@
+(* Copyright (C) 2024--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.
+ *)
+
+(** Opaque version strings with comparison.
+
+    This version number module is intended for dispatching on details about an
+    SQL intepreter or other relevant aspects of a relational database system.
+    The only constructor is private, instead the {!Infix} module provides direct
+    comparison to strings for ideomatic usage in the query-returning callback of
+    request templates.
+
+    Some care is needed to match ranges of versions correctly:
+
+      - A version provided by {!Dialect} may by unknown.  An unknown version
+        compares like the empty string, meaning that it compares before any
+        other (sensible) version.  If another logic is desired, {!is_known} can
+        be used to distinugish it.
+
+      - A version provided by {!Dialect} may also include build numbers,
+        distribution details, etc.  Therefore it seldom makes sense to compare
+        it agains the exact version of the software release.  Such versions will
+        instead compare between the version of the corresponding software
+        release and the next possible version using a normal decimal-dotted
+        versioning scheme. *)
+
+type t
+
+val is_known : t -> bool
+(** Tests whether a version from the database server is available. *)
+
+val compare : t -> t -> int
+(** Compares two versions lexicographically group-by-group and
+    component-by-component, using common conventions for comparing version
+    numbers:
+
+      - Groups of components are separated by ['-'].
+      - Components are separated by ['.'].
+      - Continuous sequences of digits are compared numerically, i.e. after
+        skipping leading zeros, longer such sequences compare after shorter
+        ones.
+      - ['~'] compares before anything else, including the empty suffix.
+
+    The ordering subject to change if we should encounter problematic
+    differences with versioning schemes used by supported database systems. *)
+
+val equal : t -> t -> bool
+(** [equal x y] is equivalent to [compare x y = 0]. *)
+
+module Infix : sig
+  val ( =* ) : t -> string -> bool
+  val ( <>* ) : t -> string -> bool
+  val ( <* ) : t -> string -> bool
+  val ( <=* ) : t -> string -> bool
+  val ( >* ) : t -> string -> bool
+  val ( >=* ) : t -> string -> bool
+end
+(** Asymmetric infix oparator for testing version ranges.  The first argument is
+    a version number, typically obtained from the [server_version] fields of
+    {!Dialect.t}, and the second argument is a string representation of the
+    version to compare against.
+
+    An unknown version compares before other versions.  Use {!Version.is_known}
+    to implement a different logic.  See {!Version.compare} for details about
+    the comparison algorithm. *)
+
+val pp : Format.formatter -> t -> unit
+
+(**/**)
+val of_string_unsafe : string -> t
+[@@alert caqti_private "For use by Caqti drivers."]

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_connect_config.ml

@@ -0,0 +1,65 @@
+(* Copyright (C) 2023--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+(* Map Implementation *)
+
+type 'a tag = ..
+
+module type KEY = sig
+  type value
+  type 'a tag += Tag : value tag
+  val name : string [@@warning "-32"]
+  val default : value
+end
+
+type 'a key = (module KEY with type value = 'a)
+
+let create_key (type a) name (default : a) : a key =
+  let module Key = struct
+    type value = a
+    type _ tag += Tag : value tag
+    let name = name
+    let default = default
+  end in
+  (module Key : KEY with type value = a)
+
+module String_map = Map.Make (String)
+
+type binding = Binding : 'a tag * 'a -> binding
+
+type t = binding String_map.t
+
+let default = String_map.empty
+
+let mem_name key_name = String_map.mem key_name
+
+let get : type a. a key -> t -> a = fun (module Key) m ->
+  (match String_map.find_opt Key.name m with
+   | Some (Binding (Key.Tag, v)) -> v
+   | _ -> Key.default)
+
+let set : type a. a key -> a -> t -> t = fun (module Key) v m ->
+  String_map.add Key.name (Binding (Key.Tag, v)) m
+
+let reset : type a. a key -> t -> t = fun (module Key) m ->
+  String_map.remove Key.name m
+
+(* Configuration Keys *)
+
+let tweaks_version : (int * int) key = create_key "tweaks_version" (1, 7)
+
+let dynamic_prepare_capacity = create_key "dynamic_prepare_capacity" 32

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_connect_config.mli

@@ -0,0 +1,51 @@
+(* Copyright (C) 2023--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+(** Configuration passed to connect functions. *)
+
+type _ key
+
+type t
+
+(** {2 Construction and Lookup} *)
+
+val default : t
+(** The configuration with all keys set to their default values. *)
+
+val get : 'a key -> t -> 'a
+(** [get key cfg] is the value associated with [key] in [cfg], which may be a
+    default value if the key has not been explicitly {!set} or if it has been
+    {!reset}. *)
+
+val set : 'a key -> 'a -> t -> t
+(** [set key value cfg] associates [key] with [value] in [cfg]. *)
+
+val reset : 'a key -> t -> t
+(** [reset key cfg] associates [key] with its default value in [cfg]. *)
+
+(** {2 Configuration Keys} *)
+
+val tweaks_version : (int * int) key
+(** Declares compatibility with {{!tweaks} database tweaks} introduced up to the
+    given version of Caqti.  Defaults to a conservative value. *)
+
+val dynamic_prepare_capacity : int key
+(** The maximum number of dynamic queries to keep in the prepare-cache. *)
+
+(**/**) (* for internal use *)
+val create_key : string -> 'a -> 'a key
+val mem_name : string -> t -> bool

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_connect_sig.ml

@@ -0,0 +1,141 @@
+(* 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.
+ *)
+
+(** Signatures providing functions for establishing database connections. *)
+
+module type S = sig
+
+  type +'a fiber
+  (** The type of a deferred value of type ['a]. *)
+
+  type +'a with_switch
+  (** Adds a switch argument to the type if relevant for the platform. *)
+
+  type +'a with_stdenv
+  (** Adds environment argument(s) to the type if relevant for the platform. *)
+
+  type (+'a, +'e) stream
+  (** A stream implementation. *)
+
+  type ('a, +'e) pool
+  (** A pool implementation for the current concurrency library. *)
+
+  type connection
+  (** Shortcut for the connection module when passed as a value. *)
+
+  val connect :
+    ?subst: (Caqti_template.Dialect.t -> Caqti_template.Query.subst) ->
+    ?env: (Caqti_driver_info.t -> string -> Caqti_query.t) ->
+    ?config: Caqti_connect_config.t ->
+    ?tweaks_version: int * int ->
+    (Uri.t -> (connection, [> Caqti_error.load_or_connect]) result fiber)
+    with_stdenv with_switch
+  (** [connect uri] locates and loads a driver which can handle [uri], passes
+      [uri] to the driver, which establish a connection and returns a
+      first-class module implementing {!Caqti_connection_sig.S}.
+
+      [connect uri] connects to the database at [uri] and returns a first class
+      module implementing {!Caqti_connection_sig.S} for the given database
+      system.  In case of preemptive threading, the connection must only be used
+      from the thread where it was created.
+
+      The correct driver for the database system is inferred from the schema of
+      [uri]; see the respective drivers for the supported schemas and related
+      URI syntax.  A driver can either be linked in to the application or, if
+      supported, dynamically linked using the [caqti.plugin] package.
+
+      @param subst
+        Alternative to [env] when using the new experimental API.
+
+      @param env
+        If provided, this function will do a final expansion of environment
+        variables which occurs in the query templates of the requests executed
+        on the connection.
+
+      @param config
+        Configuration parameters related to the interaction with the database.
+
+      @param tweaks_version
+        @deprecated This should now be passed via the [config] parameter using
+        the {!Caqti_connect_config.tweaks_version} key. *)
+
+  val with_connection :
+    ?subst: (Caqti_template.Dialect.t -> Caqti_template.Query.subst) ->
+    ?env: (Caqti_driver_info.t -> string -> Caqti_query.t) ->
+    ?config: Caqti_connect_config.t ->
+    ?tweaks_version: int * int ->
+    (Uri.t ->
+     (connection ->
+      ('a, [> Caqti_error.load_or_connect] as 'e) result fiber) ->
+     ('a, 'e) result fiber)
+    with_stdenv
+  (** [with_connection uri f] calls {!connect} on [uri]. If {!connect} evaluates
+      to [Ok connection], [with_connection] passes the connection to [f]. Once
+      [f] either evaluates to a [result], or raises an exception,
+      [with_connection] closes the database connection.
+
+      @param subst Passed to {!connect}.
+      @param env Passed to {!connect}.
+      @param config Passed to {!connect}.
+      @param tweaks_version
+        @deprecated This should now be passed via the [config] parameter using
+        the {!Caqti_connect_config.tweaks_version} key. *)
+
+  val connect_pool :
+    ?pool_config: Caqti_pool_config.t ->
+    ?post_connect: (connection -> (unit, 'connect_error) result fiber) ->
+    ?subst: (Caqti_template.Dialect.t -> Caqti_template.Query.subst) ->
+    ?env: (Caqti_driver_info.t -> string -> Caqti_query.t) ->
+    ?config: Caqti_connect_config.t ->
+    ?tweaks_version: int * int ->
+    (Uri.t ->
+     ((connection, [> Caqti_error.connect] as 'connect_error) pool,
+      [> Caqti_error.load]) result)
+    with_stdenv with_switch
+  (** [connect_pool uri] is a pool of database connections constructed by
+      [connect uri].
+
+      Do not use pooling for connections to volatile resources like
+      [sqlite3::memory:] and beware of temporary tables or other objects which
+      may not be shared across connections to the same URI.
+
+      If you use preemptive threading, note that the connection pool must only
+      be used from the thread where it was created. Use thread local storage to
+      create a separate pool per thread if necessary.
+
+      @param pool_config
+        Provides tuning parameters for the pool.  The default is the result of a
+        fresh call of {!Caqti_pool_config.default_from_env}.
+
+      @param post_connect
+        A task to run after establishing a new connection and before the
+        connection becomes available to the application.  This function can be
+        used to customize to the database session.
+
+      @param config
+        Passed to {!connect} when creating new connections.
+
+      @param subst
+        Passed to {!connect} when creating new connections.
+
+      @param env
+        Passed to {!connect} when creating new connections.
+
+      @param tweaks_version
+        @deprecated This should now be passed via the [config] parameter using
+        the {!Caqti_connect_config.tweaks_version} key. *)
+end

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_connection_sig.ml

@@ -0,0 +1,256 @@
+(* 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.
+ *)
+
+(** Signature of connection handles.
+
+    The main signature {!S} of this module represents a database connection
+    handle.  This is obtained by {{!Caqti_connect_sig} connection functions}
+    implemented in the subpackages [caqti-async], [caqti-eio], [caqti-lwt], and
+    [caqti-mirage].
+
+    While values of {!Caqti_request.t} hold SQL code to be sent to the database,
+    connection handles defined here provide the means to execute them with
+    actual parameters on an RDBMS.  So, there is a separation between
+    preparation and execution.  This is motivated by the common support for
+    prepared queries in database client libraries, and by the desire to keep the
+    possibly deeply nested data-processing code uncluttered by strings of SQL
+    code.  For this separation to be reasonably safe, the request declares the
+    types of parameters and result, and these type declarations are placed right
+    next to the SQL code, so that we can rely on OCaml's powers of refactoring
+    large code bases safely.
+
+    The result type of {!Caqti_request.t} only describes how to decode {e
+    individual rows}, leaving the decision of how to process multiple rows to
+    the execution interface.  Therefore, for each request constructor from
+    {!Caqti_request.Infix}, there are one or more matching retrieval functions
+    in the present signature. *)
+
+type driver_connection = ..
+(** This type is only to be extended by drivers. *)
+
+(** Essential connection signature implemented by drivers. *)
+module type Base = sig
+  type +'a fiber
+  type (+'a, +'err) stream
+
+  (** {2 Query} *)
+
+  module Response : Caqti_response_sig.S
+    with type 'a fiber := 'a fiber
+     and type ('a, 'err) stream := ('a, 'err) stream
+
+  val call :
+    f: (('b, 'm) Response.t -> ('c, 'e) result fiber) ->
+    ('a, 'b, 'm) Caqti_request.t -> 'a ->
+    ('c, [> Caqti_error.call] as 'e) result fiber
+  (** [call ~f request params] executes [request] with parameters [params]
+      invoking [f] to process the result; except the driver may postpone the
+      request until [f] attempts to retrieve the result.
+
+      One of the {{!Response.result_retrieval} result retrieval}
+      functions must be called exactly once before [f] returns a non-error
+      result.  If a result retrieval function is not called, it is unspecified
+      whether the database query has been issued.
+
+      The argument of [f] is only valid during the call to [f], and must not be
+      returned or operated on by other threads. *)
+
+  val set_statement_timeout :
+    float option -> (unit, [> Caqti_error.call]) result fiber
+  (** Set or clear the timeout after which a running SQL statement will be
+      terminated if supported by the driver.
+      This is currently supported for MariaDB (using [max_statement_time]) and
+      PostgreSQL (using [statement_timeout]) and has no effect for SQLite3. *)
+
+
+  (** {2 Transactions} *)
+
+  val start : unit -> (unit, [> Caqti_error.transact]) result fiber
+  (** Starts a transaction if supported by the underlying database, otherwise
+      does nothing. *)
+
+  val commit : unit -> (unit, [> Caqti_error.transact]) result fiber
+  (** Commits the current transaction if supported by the underlying database,
+      otherwise does nothing. *)
+
+  val rollback : unit -> (unit, [> Caqti_error.transact]) result fiber
+  (** Rolls back a transaction if supported by the underlying database,
+      otherwise does nothing. *)
+
+
+  (** {2 Disconnection and Reuse} *)
+
+  val deallocate :
+    ('a, 'b, 'm) Caqti_request.t -> (unit, [> Caqti_error.call]) result fiber
+  (** [deallocate req] deallocates the prepared query for [req] if it was
+      allocated. The request must not be oneshot. *)
+
+  val disconnect : unit -> unit fiber
+  (** Calling [disconnect ()] closes the connection to the database and frees
+      up related resources. *)
+
+  val validate : unit -> bool fiber
+  (** For internal use by pool implementations.  Tries to ensure the validity of
+      the connection and must return [false] if unsuccessful. *)
+
+  val check : (bool -> unit) -> unit
+  (** For internal use by pool implementations.  Called after a connection has
+      been used.  [check f] must call [f ()] exactly once with an argument
+      indicating whether to keep the connection in the pool or discard it. *)
+
+end
+
+module type Convenience = sig
+  type +'a fiber
+
+  (** {2 Retrieval Convenience}
+
+      Each of these shortcuts combine [call] with the correspondingly named
+      retrieval function from {!Caqti_response_sig.S}. *)
+
+  val exec :
+    ('a, unit, [< `Zero]) Caqti_request.t -> 'a ->
+    (unit, [> Caqti_error.call_or_retrieve]) result fiber
+  (** [exec req x] performs [req] with parameters [x] and checks that no rows
+      are returned.
+      See also {!Caqti_response_sig.S.exec}. *)
+
+  val exec_with_affected_count :
+    ('a, unit, [< `Zero]) Caqti_request.t -> 'a ->
+    (int, [> Caqti_error.call_or_retrieve | `Unsupported]) result fiber
+  (** [exec_with_affected_count req x] performs [req] with parameters [x],
+      checks that no rows are returned, and returns the number of affected rows.
+
+      See also {!Caqti_response_sig.S.exec} and
+      {!Caqti_response_sig.S.affected_count}. *)
+
+  val find :
+    ('a, 'b, [< `One]) Caqti_request.t -> 'a ->
+    ('b, [> Caqti_error.call_or_retrieve]) result fiber
+  (** [find req x] performs [req] with parameters [x], checks that a single row
+      is retured, and returns it.
+
+      See also {!Caqti_response_sig.S.find}. *)
+
+  val find_opt :
+    ('a, 'b, [< `Zero | `One]) Caqti_request.t -> 'a ->
+    ('b option, [> Caqti_error.call_or_retrieve]) result fiber
+  (** [find_opt req x] performs [req] with parameters [x] and returns either
+      [None] if no rows are returned or [Some y] if a single now [y] is returned
+      and fails otherwise.
+
+      See also {!Caqti_response_sig.S.find_opt}. *)
+
+  val fold :
+    ('a, 'b, [< `Zero | `One | `Many]) Caqti_request.t ->
+    ('b -> 'c -> 'c) ->
+    'a -> 'c -> ('c, [> Caqti_error.call_or_retrieve]) result fiber
+  (** [fold req f x acc] performs [req] with parameters [x] and passes [acc]
+      through the composition of [f y] across the result rows [y] in the order
+      of retrieval.
+
+      See also {!Caqti_response_sig.S.fold}. *)
+
+  val fold_s :
+    ('a, 'b, [< `Zero | `One | `Many]) Caqti_request.t ->
+    ('b -> 'c -> ('c, 'e) result fiber) ->
+    'a -> 'c -> ('c, [> Caqti_error.call_or_retrieve] as 'e) result fiber
+  (** [fold_s req f x acc] performs [req] with parameters [x] and passes [acc]
+      through the monadic composition of [f y] across the returned rows [y] in
+      the order of retrieval.
+
+      Please be aware of possible deadlocks when using resources from the
+      callback.  In particular, if the same connection pool is invoked as the
+      one used to obtain the current connection, it will deadlock if the pool
+      has just run out of connections.  An alternative is to collect the rows
+      first e.g. with {!fold} and do the nested queries after exiting.
+
+      See also {!Caqti_response_sig.S.fold_s}. *)
+
+  val iter_s :
+    ('a, 'b, [< `Zero | `One | `Many]) Caqti_request.t ->
+    ('b -> (unit, 'e) result fiber) ->
+    'a -> (unit, [> Caqti_error.call_or_retrieve] as 'e) result fiber
+  (** [iter_s req f x] performs [req] with parameters [x] and sequences calls to
+      [f y] for each result row [y] in the order of retrieval.
+
+      Please see the warning in {!fold_s} about resource usage in the callback.
+
+      See also {!Caqti_response_sig.S.iter_s}. *)
+
+  val collect_list :
+    ('a, 'b, [< `Zero | `One | `Many]) Caqti_request.t -> 'a ->
+    ('b list, [> Caqti_error.call_or_retrieve]) result fiber
+  (** [collect_list request x] performs a [req] with parameters [x] and returns
+      a list of rows in order of retrieval.  The accumulation is tail recursive
+      but slightly less efficient than {!rev_collect_list}. *)
+
+  val rev_collect_list :
+    ('a, 'b, [< `Zero | `One | `Many]) Caqti_request.t -> 'a ->
+    ('b list, [> Caqti_error.call_or_retrieve]) result fiber
+  (** [rev_collect_list request x] performs [request] with parameters [x] and
+      returns a list of rows in the reverse order of retrieval.  The
+      accumulation is tail recursive and slighly more efficient than
+      {!collect_list}. *)
+
+
+  (** {2 Transactions} *)
+
+  val with_transaction :
+    (unit -> ('a, 'e) result fiber) ->
+    ('a, [> Caqti_error.transact] as 'e) result fiber
+  (** [with_transaction f] wraps [f] in a transaction which is committed iff [f]
+      returns [Ok _]. *)
+end
+
+module type Populate = sig
+  type +'a fiber
+  type (+'a, +'err) stream
+
+  (** {2 Insertion} *)
+
+  val populate :
+    table: string ->
+    columns: string list ->
+    'a Caqti_type.t -> ('a, 'err) stream ->
+    (unit, [> Caqti_error.call_or_retrieve | `Congested of 'err]) result fiber
+  (** [populate table columns row_type seq] inputs the contents of [seq] into
+      the database in whatever manner is most efficient as decided by the
+      driver. *)
+end
+
+(** Full connection signature available to users. *)
+module type S = sig
+
+  val driver_info : Caqti_driver_info.t
+  (** Information about the driver providing this connection module. *)
+
+  val dialect : Caqti_template.Dialect.t
+  (** Information about the SQL dialect and other properties of the server. *)
+
+  val driver_connection : driver_connection option
+  (** The underlying connection object of the driver if available.  The open
+      variant constructor is defined in the driver library.  This is currently
+      only implemented for caqti-driver-sqlite3 for the purpose of defining
+      custom functions. *)
+
+  include Base
+  include Convenience with type 'a fiber := 'a fiber
+  include Populate
+     with type 'a fiber := 'a fiber
+      and type ('a, 'err) stream := ('a, 'err) stream
+end

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_driver_info.ml

@@ -0,0 +1,114 @@
+(* Copyright (C) 2017--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"]
+
+open Caqti_template
+
+type dialect_tag = [`Mysql | `Pgsql | `Sqlite | `Other]
+type sql_dialect_tag = [`Mysql | `Pgsql | `Sqlite]
+type parameter_style =
+  [ `None
+  | `Linear of string
+  | `Indexed of (int -> string) ]
+
+type t = {
+  uri_scheme: string;
+  dialect_tag: dialect_tag;
+  parameter_style: parameter_style;
+  can_transact: bool;
+  can_pool: bool;
+  can_concur: bool;
+  dummy_dialect: Dialect.t;
+}
+
+let create
+    ~uri_scheme
+    ?(dialect_tag = `Other)
+    ?(parameter_style = `None)
+    ~can_pool
+    ~can_concur
+    ~can_transact
+    ~dummy_dialect
+    () =
+  {
+    uri_scheme;
+    dialect_tag;
+    parameter_style;
+    can_transact;
+    can_pool;
+    can_concur;
+    dummy_dialect;
+  }
+
+let dummy = create
+  ~uri_scheme:"dummy"
+  ~can_pool:false ~can_concur:false ~can_transact:false
+  ~dummy_dialect:(Dialect.create_unknown ~purpose:`Dummy ())
+  ()
+
+let uri_scheme di = di.uri_scheme
+let dialect_tag di = di.dialect_tag
+let parameter_style di = di.parameter_style
+let can_pool di = di.can_pool
+let can_concur di = di.can_concur
+let can_transact di = di.can_transact
+
+let dummy_dialect di = di.dummy_dialect
+
+let of_dialect = function
+ | Dialect.Pgsql {client_library = `postgresql; _} as dialect ->
+    create
+      ~uri_scheme:"postgresql"
+      ~dialect_tag:`Pgsql
+      ~parameter_style:(`Indexed (fun i -> "$" ^ string_of_int (succ i)))
+      ~can_pool:true
+      ~can_concur:true
+      ~can_transact:true
+      ~dummy_dialect:dialect
+      ()
+ | Dialect.Pgsql {client_library = `pgx; _} as dialect ->
+    create
+      ~uri_scheme:"pgx"
+      ~dialect_tag:`Pgsql
+      ~parameter_style:(`Indexed (fun i -> "$" ^ string_of_int (succ i)))
+      ~can_pool:true
+      ~can_concur:true
+      ~can_transact:true
+      ~dummy_dialect:dialect
+      ()
+ | Dialect.Mysql _ as dialect ->
+    create
+      ~uri_scheme:"mariadb"
+      ~dialect_tag:`Mysql
+      ~parameter_style:(`Linear "?")
+      ~can_pool:true
+      ~can_concur:true
+      ~can_transact:true
+      ~dummy_dialect:dialect
+      ()
+ | Dialect.Sqlite _ as dialect ->
+    create
+      ~uri_scheme:"sqlite3"
+      ~dialect_tag:`Sqlite
+      ~parameter_style:(`Linear "?")
+      ~can_pool:true
+      ~can_concur:false
+      ~can_transact:true
+      ~dummy_dialect:dialect
+      ()
+ | _ -> dummy

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_driver_info.mli

@@ -0,0 +1,92 @@
+(* Copyright (C) 2017--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.
+ *)
+
+(** Information about a database, its driver, and its query language.
+
+    This module provides descriptions supplied by the driver to aid the
+    application in dealing with differences between database systems. *)
+
+type dialect_tag = private [> `Mysql | `Pgsql | `Sqlite]
+(** A tag used for easy dispatching between query languages. *)
+
+type sql_dialect_tag = [`Mysql | `Pgsql | `Sqlite]
+(** Subtype of the above which includes only known SQL dialects. *)
+
+type parameter_style = private [>
+  | `None
+  | `Linear of string
+  | `Indexed of (int -> string)
+]
+(** How parameters are named.  This is useful for SQL since the difference
+    between dialects typically have an intrusive effect on query strings.
+    This may also be useful for non-SQL languages which support some form of
+    variables or placeholders.
+    - [`None] means that non of the following parameter styles apply, or that
+      the driver does not support parameters at all.
+    - [`Linear s] means that occurrences of [s] bind to successive parameters.
+    - [`Indexed f] means that an occurrence of [f i] represents parameter
+      number [i], counting from 0. *)
+
+type t
+
+val create :
+  uri_scheme: string ->
+  ?dialect_tag: dialect_tag ->
+  ?parameter_style: parameter_style ->
+  can_pool: bool ->
+  can_concur: bool ->
+  can_transact: bool ->
+  dummy_dialect: Caqti_template.Dialect.t ->
+  unit -> t
+(** The function used by drivers to construct a description of themselves.  For
+    an explanation of the parameters, see the corresponding projections. *)
+
+val dummy : t
+(** A dummy driver info, useful for instantiating queries for inspection. *)
+
+val uri_scheme : t -> string
+(** The URI scheme this backend binds to. *)
+
+val dialect_tag : t -> dialect_tag
+(** A variant indicating the SQL dialect or other query language, used for easy
+    dispatching when constructing queries.  Can be omitted if non of the cases
+    applies, but this means clients must inspect the backend-info to identify
+    the language. *)
+
+val parameter_style : t -> parameter_style
+(** How to represent parameters in query strings. *)
+
+val can_pool : t -> bool
+(** Whether it makes sense to keep connections around for later reuse when using
+    this driver.  As hard requirements, the driver must clear any state which
+    could affect subsequent operation, and it must reliably detect whether the
+    connection is still in a usable state.  As a further indicator, the overhead
+    of establishing and closing connections should be high enough that it pays
+    of to keep connections around. *)
+
+val can_concur : t -> bool
+(** Whether the driver supports concurrent operation.  This is just a hint; it
+    is up to the driver to serialize connections with locking primitives or
+    other means. *)
+
+val can_transact : t -> bool
+(** Whether the database and driver supports transactions. *)
+
+(**/**)
+(* Needed to support the old interface. *)
+val dummy_dialect : t -> Caqti_template.Dialect.t
+val of_dialect : Caqti_template.Dialect.t -> t

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_error.ml

@@ -0,0 +1,281 @@
+(* Copyright (C) 2017--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.
+ *)
+
+(* Error Cause *)
+
+type integrity_constraint_violation = [
+  | `Restrict_violation
+  | `Not_null_violation
+  | `Foreign_key_violation
+  | `Unique_violation
+  | `Check_violation
+  | `Exclusion_violation
+  | `Integrity_constraint_violation__don't_match
+]
+
+type insufficient_resources = [
+  | `Disk_full
+  | `Out_of_memory
+  | `Too_many_connections
+  | `Configuration_limit_exceeded
+  | `Insufficient_resources__don't_match
+]
+
+type cause = [
+  | integrity_constraint_violation
+  | insufficient_resources
+  | `Unspecified__don't_match
+]
+
+let show_cause = function
+ | `Restrict_violation -> "RESTRICT violation"
+ | `Not_null_violation -> "NOT NULL constraint violation"
+ | `Foreign_key_violation -> "FOREIGN KEY constraint violation"
+ | `Unique_violation -> "UNIQUE constraint violation"
+ | `Check_violation -> "CHECK constraint violation"
+ | `Exclusion_violation -> "exclusion violation"
+ | `Integrity_constraint_violation__don't_match ->
+    "integrity constraint violation"
+ | `Disk_full -> "disk full"
+ | `Out_of_memory -> "out of memory"
+ | `Too_many_connections -> "too many connections"
+ | `Configuration_limit_exceeded -> "configuration limit exceeded"
+ | `Insufficient_resources__don't_match -> "insufficient resources"
+ | `Unspecified__don't_match -> "unknown cause"
+
+(* Driver *)
+
+type msg = ..
+
+type msg_impl = {
+  msg_pp: Format.formatter -> msg -> unit;
+  msg_cause: msg -> cause;
+}
+let msg_impl = Hashtbl.create 7
+
+let default_cause _ = `Unspecified__don't_match
+
+let define_msg ~pp ?(cause = default_cause) ec =
+  Hashtbl.add msg_impl ec {msg_pp = pp; msg_cause = cause}
+
+let find_impl msg =
+  let c = Obj.Extension_constructor.of_val msg in
+  try
+    Hashtbl.find msg_impl c
+  with Not_found ->
+    Printf.ksprintf failwith
+      "Missing call to Caqti_error.define_msg for (%s _ : Caqti_error.msg)]"
+      (Obj.Extension_constructor.name c)
+
+type msg += Msg : string -> msg
+
+let is_punct = function
+ | '.' | '!' | '?' -> true
+ | _ -> false
+
+let () =
+  let pp ppf = function
+   | Msg s ->
+      Format.pp_print_string ppf s;
+      if s <> "" && not (is_punct s.[String.length s - 1]) then
+        Format.pp_print_char ppf '.'
+   | _ -> assert false
+  in
+  define_msg ~pp ~cause:default_cause [%extension_constructor Msg]
+
+let pp_msg ppf msg =
+  (find_impl msg).msg_pp ppf msg
+
+(* We don't want to expose any DB password in error messages. *)
+let pp_uri ppf uri =
+  (match Uri.password uri with
+   | None -> Uri.pp_hum ppf uri
+   | Some _ -> Uri.pp_hum ppf (Uri.with_password uri (Some "_")))
+
+(* Records *)
+
+type load_error = {
+  uri: Uri.t;
+  msg: msg;
+}
+let pp_load_msg ppf fmt err =
+  Format.fprintf ppf fmt pp_uri err.uri;
+  Format.pp_print_string ppf ": ";
+  pp_msg ppf err.msg
+
+type connection_error = {
+  uri: Uri.t;
+  msg: msg;
+}
+let pp_connection_msg ppf fmt err =
+  Format.fprintf ppf fmt pp_uri err.uri;
+  Format.pp_print_string ppf ": ";
+  pp_msg ppf err.msg
+
+type query_error = {
+  uri: Uri.t;
+  query: string;
+  msg: msg;
+}
+
+let pp_query_msg ppf fmt err =
+  Format.fprintf ppf fmt pp_uri err.uri;
+  Format.pp_print_string ppf ": ";
+  pp_msg ppf err.msg;
+  Format.fprintf ppf " Query: %S." err.query
+
+type coding_error = {
+  uri: Uri.t;
+  typ: Caqti_type.any;
+  msg: msg;
+}
+let pp_coding_error ppf fmt err =
+  Format.fprintf ppf fmt Caqti_type.pp_any err.typ pp_uri err.uri;
+  Format.pp_print_string ppf ": ";
+  pp_msg ppf err.msg
+
+(* Load *)
+
+let load_rejected ~uri msg = `Load_rejected ({uri; msg} : load_error)
+let load_failed ~uri msg = `Load_failed ({uri; msg} : load_error)
+
+(* Connect *)
+
+let connect_rejected ~uri msg =
+  `Connect_rejected ({uri; msg} : connection_error)
+
+let connect_failed ~uri msg =
+  `Connect_failed ({uri; msg} : connection_error)
+
+(* Call *)
+
+let encode_missing ~uri ~field_type () =
+  let typ = Caqti_type.Any (Caqti_type.field field_type) in
+  let msg = Msg "Field type not supported and no fallback provided." in
+  `Encode_rejected ({uri; typ; msg} : coding_error)
+let encode_rejected ~uri ~typ msg =
+  let typ = Caqti_type.Any typ in
+  `Encode_rejected ({uri; typ; msg} : coding_error)
+let encode_failed ~uri ~typ msg =
+  let typ = Caqti_type.Any typ in
+  `Encode_failed ({uri; typ; msg} : coding_error)
+let request_failed ~uri ~query msg =
+  `Request_failed ({uri; query; msg} : query_error)
+
+(* Retrieve *)
+
+let decode_missing ~uri ~field_type () =
+  let typ = Caqti_type.Any (Caqti_type.field field_type) in
+  let msg = Msg "Field type not supported and no fallback provided." in
+  `Decode_rejected ({uri; typ; msg} : coding_error)
+let decode_rejected ~uri ~typ msg =
+  let typ = Caqti_type.Any typ in
+  `Decode_rejected ({uri; typ; msg} : coding_error)
+let response_failed ~uri ~query msg =
+  `Response_failed ({uri; query; msg} : query_error)
+let response_rejected ~uri ~query msg =
+  `Response_rejected ({uri; query; msg} : query_error)
+
+(* Common *)
+
+type call =
+  [ `Encode_rejected of coding_error
+  | `Encode_failed of coding_error
+  | `Request_failed of query_error
+  | `Response_rejected of query_error ]
+
+type retrieve =
+  [ `Decode_rejected of coding_error
+  | `Request_failed of query_error
+  | `Response_failed of query_error
+  | `Response_rejected of query_error ]
+
+type call_or_retrieve = [call | retrieve]
+
+type transact = call_or_retrieve
+
+type load =
+  [ `Load_rejected of load_error
+  | `Load_failed of load_error ]
+
+type connect =
+  [ `Connect_rejected of connection_error
+  | `Connect_failed of connection_error
+  | `Post_connect of call_or_retrieve ]
+
+type load_or_connect = [load | connect]
+
+type t = [load | connect | call | retrieve]
+
+let rec uri : 'a. ([< t] as 'a) -> Uri.t = function
+ | `Load_rejected ({uri; _} : load_error) -> uri
+ | `Load_failed ({uri; _} : load_error) -> uri
+ | `Connect_rejected ({uri; _} : connection_error) -> uri
+ | `Connect_failed ({uri; _} : connection_error) -> uri
+ | `Post_connect err -> uri err
+ | `Encode_rejected ({uri; _} : coding_error) -> uri
+ | `Encode_failed ({uri; _} : coding_error) -> uri
+ | `Request_failed ({uri; _} : query_error) -> uri
+ | `Decode_rejected ({uri; _} : coding_error) -> uri
+ | `Response_failed ({uri; _} : query_error) -> uri
+ | `Response_rejected ({uri; _} : query_error) -> uri
+
+let rec pp : 'a. _ -> ([< t] as 'a) -> unit = fun ppf -> function
+ | `Load_rejected err -> pp_load_msg ppf "Cannot load driver for <%a>" err
+ | `Load_failed err -> pp_load_msg ppf "Failed to load driver for <%a>" err
+ | `Connect_rejected err -> pp_connection_msg ppf "Cannot connect to <%a>" err
+ | `Connect_failed err -> pp_connection_msg ppf "Failed to connect to <%a>" err
+ | `Post_connect err ->
+    Format.pp_print_string ppf "During post-connect: ";
+    pp ppf err
+ | `Encode_rejected err -> pp_coding_error ppf "Cannot encode %a for <%a>" err
+ | `Encode_failed err -> pp_coding_error ppf "Failed to bind %a for <%a>" err
+ | `Decode_rejected err -> pp_coding_error ppf "Cannot decode %a from <%a>" err
+ | `Request_failed err -> pp_query_msg ppf "Request to <%a> failed" err
+ | `Response_failed err -> pp_query_msg ppf "Response from <%a> failed" err
+ | `Response_rejected err -> pp_query_msg ppf "Unexpected result from <%a>" err
+
+let show_of_pp pp err =
+  let buf = Buffer.create 128 in
+  let ppf = Format.formatter_of_buffer buf in
+  pp ppf err;
+  Format.pp_print_flush ppf ();
+  Buffer.contents buf
+
+let show err = show_of_pp pp err
+
+let cause = function
+ | `Request_failed err | `Response_failed err ->
+    (find_impl (err : query_error).msg).msg_cause err.msg
+
+type counit = |
+
+[@@@warning "-56"]
+let uncongested = function
+ | Error #t | Ok _ as x -> x
+ | Error (`Congested (nothingness : counit)) -> (match nothingness with _ -> .)
+[@@@warning "+56"]
+
+exception Exn of t
+
+let () = Printexc.register_printer @@ function
+ | Exn err ->
+    Some (show err)
+ | Caqti_query.Expand_error err ->
+    Some (show_of_pp Caqti_query.pp_expand_error err)
+ | _ ->
+    None

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_error.mli

@@ -0,0 +1,296 @@
+(* Copyright (C) 2017--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.
+ *)
+
+(** Error descriptors. *)
+
+
+(** {2 Error Causes}
+
+    The {!type:cause} type is an incomplete enumeration of consolidated causes
+    of errors between different database systems.  The selection includes the
+    causes which are believed to be useful to handle and excludes causes which
+    are specific to the implementation of a certain database system.
+
+    The causes are classified into subtypes to help matching them collectively.
+    Each subtype has a fall-back case which is used if the database system does
+    not clearly report one of the specific cases.  An condition which is
+    reported as the fall-back case may in a future version be reported as a
+    specific case, possibly adding a new case to the subtype.  Therefore, for
+    backwards compatibility you should match the full subtype rather than the
+    fall-back, e.g.
+    {[
+      (match Caqti_error.cause error with
+       | `Unique_violation -> handle_unique_violation ()
+       | #integrity_constraint_violation -> handle_other_constraint_violation ()
+       | _ -> handle_other_error ())
+    ]}
+    This ensures that your code stil compiles when a new case is added to
+    {!integrity_constraint_violation}, and that the error condition receiving
+    mapped to the new case is still handled by the subtype pattern when you link
+    to the new version of Caqti.
+
+    Currently we do not have access to the extended error codes from SQLite3,
+    meaning that all integrity constraint violation conditions will be reported
+    as [`Integrity_constraint_violation__don't_match].
+
+    Since the consolitation of each error condition requires some investitation
+    and testing, the selection made is very conservative.  If you need to handle
+    an error which is currently unlisted, please open an issue or create a pull
+    request.  A pull request should, if possible, include a extension of
+    [test_error_cause.ml] to demonstrate how the error is triggered by the
+    database systems. *)
+
+type integrity_constraint_violation = [
+  | `Restrict_violation
+      (** This is meant to indicate that a deletion or update would cause a
+          foreign key violation, although this may be reported as a
+          [`Foreign_key_violation]. *)
+  | `Not_null_violation
+      (** An insertion or update attempts to assign a [NULL] value to column
+          having a [NOT NULL] constraint. *)
+  | `Foreign_key_violation
+      (** An modification would cause a column to reference a non-existing key.
+          This cause may also be reported for cases which should have been
+          covered by [`Restrict_violation]. *)
+  | `Unique_violation
+      (** An insertion or update would duplicate a key as declared by a [UNIQUE]
+          or [PRIMARY KEY] constraint. *)
+  | `Check_violation
+      (** A requested change would violate a [CHECK] constraint. *)
+  | `Exclusion_violation
+      (** A requested insertion or update would cause an overlap of rows
+          according to an [EXCLUDE] constraint. *)
+  | `Integrity_constraint_violation__don't_match
+      (** An yet unclassified cause; match the full subtype instead. *)
+]
+(** A subtype of {!type:cause} informing about violation of SQL constraints. *)
+
+type insufficient_resources = [
+  | `Disk_full
+      (** The server is out of disk space. *)
+  | `Out_of_memory
+      (** The server is out of memory *)
+  | `Too_many_connections
+      (** The server does not accept establishing more connections. *)
+  | `Configuration_limit_exceeded
+      (** Some unspecific server limit is exceeded. *)
+  | `Insufficient_resources__don't_match
+      (** An yet unclassified cause; match the full subtype instead. *)
+]
+(** A subtype of {!type:cause} informing about insufficient resources on the
+    server side. *)
+
+type cause = [
+  | integrity_constraint_violation
+  | insufficient_resources
+  | `Unspecified__don't_match
+]
+(** The selection of causes of errors which have been mapped. *)
+
+val show_cause : [< cause] -> string
+
+
+(** {2 Messages} *)
+
+type msg = ..
+(** In this type, drivers can stash information about any errors in their own
+    format, which can later be used for pretty-printing and or future
+    operations. Drivers must call {!define_msg} on each constructor added to
+    this type. *)
+
+val define_msg :
+  pp: (Format.formatter -> msg -> unit) ->
+  ?cause: (msg -> cause) ->
+  extension_constructor -> unit
+(** Mandatory registration of pretty-printer for a driver-supplied error
+    descriptor.  *)
+
+val pp_msg : Format.formatter -> msg -> unit
+(** [pp_msg ppf msg] formats [msg] on [ppf]. *)
+
+type msg += Msg : string -> msg
+(** The shape of locally generated messages and messages from drivers without
+    dedicated error type. *)
+
+(**/**)
+val pp_uri : Format.formatter -> Uri.t -> unit
+(** Pretty printer of URIs which omits the password, used by drivers when
+    logging. *)
+(**/**)
+
+(** {2 Messages with Metadata}
+
+    {b Note.} Please consider the fields internal for now, they may still be
+    revised or hidden. *)
+
+type load_error = private {
+  uri: Uri.t;
+  msg: msg;
+}
+type connection_error = private {
+  uri: Uri.t;
+  msg: msg;
+}
+type query_error = private {
+  uri: Uri.t;
+  query: string;
+  msg: msg;
+}
+type coding_error = private {
+  uri: Uri.t;
+  typ: Caqti_type.any;
+  msg: msg;
+}
+
+
+(** {2 Documented Constructors} *)
+
+
+(** {3 Errors during Driver Loading} *)
+
+val load_rejected : uri: Uri.t -> msg -> [> `Load_rejected of load_error]
+(** [load_rejected ~uri msg] indicates that a driver could not be identified
+    from [uri]. *)
+
+val load_failed : uri: Uri.t -> msg -> [> `Load_failed of load_error]
+(** [load_failed ~uri msg] indicates that a driver for [uri] could not be
+    loaded. *)
+
+
+(** {3 Errors during Connect} *)
+
+val connect_rejected : uri: Uri.t -> msg ->
+  [> `Connect_rejected of connection_error]
+(** [connect_rejected ~uri msg] indicates that the driver rejected the URI. *)
+
+val connect_failed : uri: Uri.t -> msg ->
+  [> `Connect_failed of connection_error]
+(** [connect_failed ~uri msg] indicates that the driver failed to establish a
+    connection to the database. *)
+
+
+(** {3 Errors during Call} *)
+
+val encode_missing : uri: Uri.t -> field_type: 'a Caqti_type.Field.t -> unit ->
+  [> `Encode_rejected of coding_error]
+(** [encode_missing ~uri ~field_type ()] indicates that the driver does not
+    support [field_type] and no fallback encoding is available for the type. *)
+
+val encode_rejected : uri: Uri.t -> typ: 'a Caqti_type.t -> msg ->
+  [> `Encode_rejected of coding_error]
+(** [encode_rejected ~uri ~typ msg] indicates that encoding a value to [typ]
+    failed, e.g. due to being out of range. *)
+
+val encode_failed : uri: Uri.t -> typ: 'a Caqti_type.t -> msg ->
+  [> `Encode_failed of coding_error]
+(** [encode_failed ~uri ~typ msg] indicates that a parameter of type [typ] was
+    not accepted by the database client library. *)
+
+val request_failed : uri: Uri.t -> query: string -> msg ->
+  [> `Request_failed of query_error]
+(** [request_failed ~uri ~query msg] indicates that the request could not be
+    transmitted to the database, that the database was not ready to process the
+    request, or that something went wrong while processing the request. *)
+
+
+(** {3 Errors during Result Retrieval} *)
+
+val decode_missing : uri: Uri.t -> field_type: 'a Caqti_type.Field.t -> unit ->
+  [> `Decode_rejected of coding_error]
+(** [decode_missing ~uri ~field_type ()] indicates that the driver does not
+    support [field_type] for decoding result rows. *)
+
+val decode_rejected : uri: Uri.t -> typ: 'a Caqti_type.t -> msg ->
+  [> `Decode_rejected of coding_error]
+(** [decode_rejected ~uri ~typ msg] indicates that the driver could not decode a
+    field of type [typ] from the returned row, e.g. due to an invalid value or
+    limited range of the target type. *)
+
+val response_failed : uri: Uri.t -> query: string -> msg ->
+  [> `Response_failed of query_error]
+(** [response_failed ~uri ~query msg] indicates that something when wrong while
+    fetching a delayed part of the response. *)
+
+val response_rejected : uri: Uri.t -> query: string -> msg ->
+  [> `Response_rejected of query_error]
+(** [response_rejected ~uri ~query msg] indicates that the response from the
+    database was rejected due to requirements posed by client code. *)
+
+
+(** {2 Specific Error Types} *)
+
+type call =
+  [ `Encode_rejected of coding_error
+  | `Encode_failed of coding_error
+  | `Request_failed of query_error
+  | `Response_rejected of query_error ]
+
+type retrieve =
+  [ `Decode_rejected of coding_error
+  | `Request_failed of query_error
+  | `Response_failed of query_error
+  | `Response_rejected of query_error ]
+(** Errors which may occur during retrival of result rows.  This includes
+    [`Request_failed] since the request is fused with retrieval for the pgx
+    driver. *)
+
+type call_or_retrieve = [call | retrieve]
+
+type transact = [call | retrieve] (* TODO: Should be a subset. *)
+
+type load =
+  [ `Load_rejected of load_error
+  | `Load_failed of load_error ]
+
+type connect =
+  [ `Connect_rejected of connection_error
+  | `Connect_failed of connection_error
+  | `Post_connect of call_or_retrieve ]
+
+type load_or_connect = [load | connect]
+
+
+(** {2 Generic Error Type and Functions} *)
+
+type t = [load | connect | call | retrieve]
+(** The full union of errors used by Caqti. *)
+
+val uri : [< t] -> Uri.t
+(** [uri error] is the URI of the connection used where [error] occurred. *)
+
+val pp : Format.formatter -> [< t] -> unit
+(** [pp ppf error] prints an explanation of [error] on [ppf]. *)
+
+val show : [< t] -> string
+(** [show error] is an explanation of [error]. *)
+
+val cause :
+  [< `Request_failed of query_error | `Response_failed of query_error] -> cause
+(** A matchable representation of the cause of the error, if available. *)
+
+type counit = |
+(** An uninhabited type used by {!uncongested}. *)
+
+val uncongested :
+  ('a, [< t | `Congested of counit]) result ->
+  ('a, [> t]) result
+(** [uncongested r] eliminates an unused [`Congested] case from the error. *)
+
+exception Exn of t
+(** [Exn error] can be used when an exception is preferred over explicit error
+    handling.  The core Caqti API never raises exceptions which originate from
+    runtime errors. *)

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_mult.ml

@@ -0,0 +1,20 @@
+(* Copyright (C) 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.
+ *)
+
+(** Row multiplicity. *)
+
+include Caqti_template.Row_mult

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_pool_config.ml

@@ -0,0 +1,109 @@
+(* 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 Log = (val Logs.src_log (Logs.Src.create "caqti.config"))
+
+type t = {
+  max_size: int option;
+  max_idle_size: int option;
+  max_idle_age: Mtime.Span.t option option;
+  max_use_count: int option option;
+}
+
+type _ key =
+  | Max_size : int key
+  | Max_idle_size : int key
+  | Max_idle_age : Mtime.Span.t option key
+  | Max_use_count : int option key
+
+type any_key = Any : _ key -> any_key
+
+let keys = [
+  Any Max_size;
+  Any Max_idle_size;
+  Any Max_idle_age;
+  Any Max_use_count;
+]
+
+let create
+      ?max_size
+      ?max_idle_size
+      ?max_idle_age
+      ?max_use_count
+      () =
+  {max_size; max_idle_size; max_idle_age; max_use_count}
+
+let option_of_string f = function
+ | "" | "none" -> None
+ | s -> Some (f s)
+
+let mtime_span_of_string s =
+  let x = float_of_string s in
+  (match Mtime.Span.of_float_ns (x *. 1e9) with
+   | None -> failwith "Mtime.Span.of_float_ns"
+   | Some x -> x)
+
+let default = create ()
+
+let create_from_env pfx =
+  let get conv sfx =
+    let var = pfx ^ sfx in
+    (match Sys.getenv_opt var with
+     | None -> None
+     | Some str ->
+        (match conv str with
+         | value -> Some value
+         | exception Failure _ ->
+            Log.err (fun m -> m "Failed to parse $%s = %s." var str);
+            None))
+  in
+  {
+    max_size = get int_of_string "_MAX_SIZE";
+    max_idle_size = get int_of_string "_MAX_IDLE_SIZE";
+    max_idle_age = get (option_of_string mtime_span_of_string) "_MAX_IDLE_AGE";
+    max_use_count = get (option_of_string int_of_string) "_MAX_USE_COUNT";
+  }
+
+let default_from_env () = create_from_env "CAQTI_POOL"
+
+let max_size = Max_size
+let max_idle_size = Max_idle_size
+let max_idle_age = Max_idle_age
+let max_use_count = Max_use_count
+
+let get (type a) (k : a key) config : a option =
+  (match k with
+   | Max_size -> config.max_size
+   | Max_idle_size -> config.max_idle_size
+   | Max_idle_age -> config.max_idle_age
+   | Max_use_count -> config.max_use_count)
+
+let modify (type a) (k : a key) (v : a option) config =
+  (match k with
+   | Max_size -> {config with max_size = v}
+   | Max_idle_size -> {config with max_idle_size = v}
+   | Max_idle_age -> {config with max_idle_age = v}
+   | Max_use_count -> {config with max_use_count = v})
+
+let set k v config = modify k (Some v) config
+let unset k config = modify k None config
+
+let merge_left cL cR =
+  let add acc (Any k) =
+    match get k cL with None -> acc | Some v -> (set k v acc)
+  in
+  List.fold_left add cR keys

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_pool_config.mli

@@ -0,0 +1,86 @@
+(* 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.
+ *)
+
+(** Pool configuration. *)
+
+type _ key
+type t
+
+(** {2 Construction and Generic Operations} *)
+
+val create :
+  ?max_size: int ->
+  ?max_idle_size: int ->
+  ?max_idle_age: Mtime.Span.t option ->
+  ?max_use_count: int option ->
+  unit -> t
+(** Creates a configuration for the implementation of {!Caqti_pool_sig.S}.  The
+    main arguments populate the configuration with the corresponding settings,
+    which are explaind in {!cpck}. *)
+
+val default : t
+(** The configuration object with no setting, which gives the built-in defaults.
+    Alternatively, use {!default_from_env} for a configuration based on
+    environment variables. *)
+
+val default_from_env : unit -> t
+(** [default_from_env ()] is a configuration constructed from environment
+    variables of the form [CAQTI_POOL_<suffix>], with the upper-cased names of
+    the configuration keys substituted for [<suffix>]. *)
+
+val merge_left : t -> t -> t
+(** [merge_left cL cR] is the configuration [cL] with missing settings populated
+    by the corresponding present settings from [cR]. *)
+
+val get : 'a key -> t -> 'a option
+(** [get key config] is the value of [key] in [config] or [None] if unset. *)
+
+val set : 'a key -> 'a -> t -> t
+(** [set key value config] is [config] with [key] set to [value] regardless of
+    any previous mapping. *)
+
+val unset : 'a key -> t -> t
+(** [unset key config] is [config] without its mapping for [key] if any. *)
+
+
+(** {2:cpck Configuration Keys} *)
+
+val max_size : int key
+(** The maximum number of open connections associated with the pool.  When this
+    limit is hit, an attempt to use the pool will block until a connection
+    becomes available.  The value must be at least one.  If the selected driver
+    does not support concurrent connections, the value [1] is assumed. *)
+
+val max_idle_size : int key
+(** The maximum number of idle connections to put into the pool for reuse.  Must
+    be between [0] and {!max_size}.  If you set this, you must also ensure
+    {!max_size} is set so that the combination is valid.  Defaults to
+    {!max_size}.  For drivers which does not support concurrent connections, the
+    value will clipped to a maximum of [1]. *)
+
+val max_idle_age : Mtime.Span.t option key
+(** The maximum age of idle connections before they are scheduled to be
+    disconnected and removed from the pool, or [None] for no limit.  Where
+    possible, a timer will be used to trigger the cleanup.  For the
+    [caqti.blocking] library, the cleanup will only be done opportunistically
+    when the pool is used. *)
+
+val max_use_count : int option key
+(** The maximum number of times a pooled connection is reused, or [None] for no
+    limit.  The default is currently 100, but may be changed in the future based
+    on real-world experience.  The reason this setting was introduced is that we
+    have seen state being retained on the server side. *)

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_pool_sig.ml

@@ -0,0 +1,43 @@
+(* Copyright (C) 2017--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.
+ *)
+
+(** Resource pool signature. *)
+
+module type S = sig
+
+  type +'a fiber
+
+  type ('a, +'e) t
+
+  val size : ('a, 'e) t -> int
+  (** [size pool] is the current number of open resources in [pool]. *)
+
+  val use :
+    ?priority: float ->
+    ('a -> ('b, 'e) result fiber) -> ('a, 'e) t -> ('b, 'e) result fiber
+  (** [use f pool] calls [f] on a resource drawn from [pool], handing back the
+      resource to the pool when [f] exits.
+
+      @param priority
+        Requests for the resource are handled in decreasing order of priority.
+        The default priority is [0.0]. *)
+
+  val drain : ('a, 'e) t -> unit fiber
+  (** [drain pool] closes all resources in [pool]. The pool is still usable, as
+      new resources will be created on demand. *)
+
+end

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_query.ml

@@ -0,0 +1,40 @@
+(* Copyright (C) 2024--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
+
+include Caqti_template.Query
+include Caqti_template.Query.Private [@@alert "-caqti_private"]
+
+type expand_error = Query.Expand_error.t
+let pp_expand_error = Query.Expand_error.pp
+
+let of_string repr =
+  let conv err = `Invalid Query.Parse_error.(position err, message err) in
+  Query.parse_result repr |> Result.map_error conv
+
+let of_string_exn repr =
+  (try Query.parse repr with
+   | Query.Parse_error err -> Format.kasprintf failwith "%a" Parse_error.pp err)
+
+let concat sep = concat ~sep
+let qprintf = Query_fmt.qprintf
+let kqprintf = Query_fmt.kqprintf
+let param = Query_fmt.param
+let env = Query_fmt.env
+let quote = Query_fmt.quote
+let query = Query_fmt.query

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_query.mli

@@ -0,0 +1,204 @@
+(* Copyright (C) 2019--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.
+ *)
+
+(** Intermediate query string representation.
+
+    This module provides a common representation of database query strings.
+    This module can be used directly to construct queries dynamically, or
+    indirectly via the parser, as may be more convenient when the query string
+    is known at compile-time.  In the latter case, the input string is typically
+    very similar to the output string.  In either case the intermediate
+    representation serve to unify the syntax across database systems and to
+    provide additional functionality.
+
+    When using this module directly, it provides:
+
+      - flexible, pure, and efficient construction ({!S}, {!L}),
+      - uniform index-based parameter references ({!P}),
+      - expansion of fragments provided by an environment function ({!E}), and
+      - safe embedding of values in queries ({!V}, {!Q}). *)
+
+
+(** {2 Construction} *)
+
+type t = Caqti_template.Query.Private.t [@alert "-caqti_private"] =
+  | L of string
+    (** [L frag] translates to the literally inserted substring [frag].  The
+        [frag] argument must be trusted or verified to be secure to avoid SQL
+        injection attacks.  Use {!V}, {!Q}, or {!P} to safely insert strings or
+        other values. *)
+  | V : 'a Caqti_type.Field.t * 'a -> t
+    (** [V (t, v)] translates to a parameter of type [t] bound to the value [v].
+        That is, the query string will contain a parameter reference which does
+        not conflict with any {!P} nodes and bind [v] to the corresponding
+        parameter each time the query is executed.  This allows taking advantage
+        of driver-dependent serialization and escaping mechanisms to safely send
+        values to the database server. *)
+  | Q of string
+    (** [Q s] corresponds to a quoted string literal.  This is passed as part of
+        the query string if a suitable quoting function is available in the
+        client library, otherwise it is equivalent to
+        {!V}[(]{!Caqti_type.Field.String}[, s)]. *)
+  | P of int
+    (** [P i] refers to parameter number [i], counting from 0, so that e.g.
+        [P 0] translates to ["$1"] for PostgreSQL and ["?1"] for SQLite3. *)
+  | E of string
+    (** [E name] will be replaced by the fragment returned by an environment
+        lookup function, as passed directly to {!expand} or indirectly through
+        the [?env] argument found in higher-level functions.  An error will be
+        issued for any remaining [E]-nodes in the final translation to a query
+        string. *)
+  | S of t list
+    (** [S frags] is the concatenation of [frags].  Apart from combining
+        different kinds of nodes, this constructor can be nested according to
+        the flow of the generating code. *)
+(** [t] is an intermediate representation of a query string to be send to a
+    database, possibly combined with some hidden parameters used to safely embed
+    values.  Apart from embedding values, this representation provides indexed
+    parameter references, independent of the target database system.  For
+    databases which use linear parameter references (like [?] for MariaDB), the
+    driver will reshuffle, elide, and duplicate parameters as needed.
+
+    Please note that additional constructors may be added to this type across
+    minor releases. *)
+
+val concat : string -> t list -> t
+(** [concat sep frags] is [frags] interfixed with [sep] if [frags] is non-empty,
+    and the empty string if [frags] is empty. *)
+
+(** {3 Embedding Values}
+
+    The following are shortcuts for combining {!V} with some of the field types.
+    The values will be passed as hidden parameters. *)
+
+val bool : bool -> t
+val int : int -> t
+val float : float -> t
+val string : string -> t
+val octets : string -> t
+val pdate : Ptime.t -> t
+val ptime : Ptime.t -> t
+val ptime_span : Ptime.span -> t
+
+val const_fields : 'a Caqti_type.t -> 'a -> t list
+(** [const_fields t x] returns a list of fragments corresponding to the
+    single-field projections of the value [x] as described by the type
+    descriptor [t].  Each element of the returned list will be either a
+    {!V}-fragment containing the projected value, or the [L["NULL"]] fragment if
+    the projection is [None].
+
+    The result can be turned into a comma-separated list with {!concat}, except
+    values of unitary types, i.e. types having no fields, may require special
+    care. *)
+
+
+(** {2 Normalization and Equality} *)
+
+val normal : t -> t
+(** [normal q] rewrites [q] to a normal form containing at most one top-level
+    {!S} constructor, containing no empty literals, and no consecutive literals.
+    This function can be used to post-process queries before using {!equal} and
+    {!hash}. *)
+
+val equal : t -> t -> bool
+(** Equality predicate for {!t}. *)
+
+val hash : t -> int
+(** A hash function compatible with {!equal}.  The hash function may change
+    across minor versions and may depend on architecture. *)
+
+
+(** {2 Parsing, Expansion, and Printing} *)
+
+val pp : Format.formatter -> t -> unit
+(** [pp ppf q] prints a {e human}-readable representation of [q] on [ppf].
+    The printed string is {e not suitable for sending to an SQL database}; doing
+    so may lead to an SQL injection vulnerability. *)
+
+val show : t -> string
+(** [show q] is the same {e human}-readable representation of [q] as printed by
+    {!pp}.
+    The returned string is {e not suitable for sending to an SQL database};
+    doing so may lead to an SQL injection vulnerability. *)
+
+type expand_error
+(** A description of the error caused during {!expand} if the environment lookup
+    function returns an invalid result or raises [Not_found] for a variable when
+    the expansion is final. *)
+
+val pp_expand_error : Format.formatter -> expand_error -> unit
+(** Prints an informative error. *)
+
+exception Expand_error of expand_error
+(** The exception raised by {!expand} when there are issues expanding an
+    environment variable using the provided callback. *)
+
+val expand : ?final: bool -> (string -> t) -> t -> t
+(** [expand f q] replaces each occurrence of [E v] some some [v] with [f v] or
+    leaves it unchanged where [f v] raises [Not_found]. The [Not_found]
+    exception will not escape this call.
+
+    @param final
+      If [true], then an error is raised instead of leaving environment
+      references unexpended if [f] raises [Not_found].  This is used by drivers
+      for performing the final expansion.  Defaults to [false].
+
+    @raise Expand_error
+      if [~final:true] is passed and [f] raise [Not_found] or if [f] returns a
+      query containing environment references. *)
+
+val angstrom_parser : t Angstrom.t
+(** Matches a single expression terminated by the end of input or a semicolon
+    lookahead. The accepted languages is described in {{!query_template} The
+    Syntax of Query Templates}. *)
+
+val angstrom_parser_with_semicolon : t Angstrom.t
+(** A variant of [angstrom_parser] which accepts unquoted semicolons as part of
+    the single statement, as is valid in some cases like in SQLite3 trigger
+    definitions.  This is the parser used by {!Caqti_request}, where it's
+    assumed that the input is a single SQL statement. *)
+
+val angstrom_list_parser : t list Angstrom.t
+(** Matches a sequence of statements while ignoring surrounding white space and
+    end-of-line comments starting with ["--"].  This parser can be used to load
+    schema files with support for environment expansions, like substituting the
+    name of the database schema. *)
+
+val of_string : string -> (t, [`Invalid of int * string]) result
+(** Parses a single expression using {!angstrom_parser_with_semicolon}.  The
+    error indicates the byte position of the input string where the parse
+    failure occurred in addition to an error message. See {{!query_template} The
+    Syntax of Query Templates} for how the input string is interpreted. *)
+
+val of_string_exn : string -> t
+(** Like {!of_string}, but raises an exception on error.
+
+    @raise Failure if parsing failed. *)
+
+(**/**)
+val qprintf : ('a, Format.formatter, unit, t) format4 -> 'a
+[@@alert deprecated "Moved to Caqti_query_fmt."]
+val kqprintf : (t -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b
+[@@alert deprecated "Moved to Caqti_query_fmt."]
+val param : Format.formatter -> int -> unit
+[@@alert deprecated "Moved to Caqti_query_fmt."]
+val env : Format.formatter -> string -> unit
+[@@alert deprecated "Moved to Caqti_query_fmt."]
+val quote : Format.formatter -> string -> unit
+[@@alert deprecated "Moved to Caqti_query_fmt."]
+val query : Format.formatter -> t -> unit
+[@@alert deprecated "Moved to Caqti_query_fmt."]

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_query_fmt.ml

@@ -0,0 +1,18 @@
+(* Copyright (C) 2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+include Caqti_template.Query_fmt

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_query_fmt.mli

@@ -0,0 +1,20 @@
+(* Copyright (C) 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.
+ *)
+
+(** Format-based query construction. *)
+
+include module type of (struct include Caqti_template.Query_fmt end)

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_request.ml

@@ -0,0 +1,61 @@
+(* Copyright (C) 2024--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
+
+include Request
+
+let create ?(oneshot = false) pt rt rm make_query =
+  create (if oneshot then Direct else Static) (pt, rt, rm)
+    (fun dialect -> make_query (Caqti_driver_info.of_dialect dialect))
+
+let query req driver_info =
+  query req (Caqti_driver_info.dummy_dialect driver_info)
+
+let query_id = query_id
+
+module Infix = struct
+  let (-->.) t u ?oneshot f = create ?oneshot t u Row_mult.zero f
+  let (-->!) t u ?oneshot f = create ?oneshot t u Row_mult.one f
+  let (-->?) t u ?oneshot f = create ?oneshot t u Row_mult.zero_or_one f
+  let (-->*) t u ?oneshot f = create ?oneshot t u Row_mult.zero_or_more f
+
+  let (@:-) f s =
+    let q = Caqti_query.of_string_exn s in
+    f (fun _ -> q)
+
+  let (@@:-) f g =
+    f (fun d -> Caqti_query.of_string_exn (g (Caqti_driver_info.dialect_tag d)))
+
+  let (->.) t u ?oneshot s = create ?oneshot t u Row_mult.zero @:- s
+  let (->!) t u ?oneshot s = create ?oneshot t u Row_mult.one @:- s
+  let (->?) t u ?oneshot s = create ?oneshot t u Row_mult.zero_or_one @:- s
+  let (->*) t u ?oneshot s = create ?oneshot t u Row_mult.zero_or_more @:- s
+end
+
+let no_env _ _ = raise Not_found
+
+let make_pp ?(env = no_env) ?(driver_info = Caqti_driver_info.dummy) () =
+  let dialect = Caqti_driver_info.dummy_dialect driver_info in
+  make_pp ~subst:(env driver_info) ~dialect ()
+
+let make_pp_with_param
+      ?(env = no_env) ?(driver_info = Caqti_driver_info.dummy) () =
+  let dialect = Caqti_driver_info.dummy_dialect driver_info in
+  make_pp_with_param ~subst:(env driver_info) ~dialect ()

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_request.mli

@@ -0,0 +1,321 @@
+(* 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.
+ *)
+
+(** Request specification.
+
+    A Caqti request is a function to generate a query string from information
+    about the driver, along with type descriptors to encode parameters and
+    decode rows returned from the same query.  Requests are passed to
+    {!Caqti_connection_sig.S.call} or one of its shortcut methods provided by a
+    database connection handle.
+
+    The request often represent a prepared query, in which case it is static and
+    can be defined directly in a module scope.  However, an optional [oneshot]
+    parameter may be passed to indicate a dynamically generated query. *)
+
+(** {2 Primitives} *)
+
+type ('a, 'b, +'m) t = ('a, 'b, 'm) Caqti_template.Request.t
+(** A request specification embedding a query generator, parameter encoder, and
+    row decoder.
+    - ['a] is the type of the expected parameter bundle.
+    - ['b] is the type of a returned row.
+    - ['m] is the possible multiplicities of returned rows. *)
+
+val create :
+  ?oneshot: bool ->
+  'a Caqti_type.t -> 'b Caqti_type.t -> 'm Caqti_mult.t ->
+  (Caqti_driver_info.t -> Caqti_query.t) -> ('a, 'b, 'm) t
+(** [create arg_type row_type row_mult f] is a request which takes parameters of
+    type [arg_type], returns rows of type [row_type] with multiplicity
+    [row_mult], and which sends query strings generated from the query [f di],
+    where [di] is the {!Caqti_driver_info.t} of the target driver.  The driver
+    is responsible for turning parameter references into a form accepted by the
+    database, while other differences must be handled by [f].
+
+    @param oneshot
+      Disables caching of a prepared statements on connections for this query.
+
+        - If false (the default), the statement is prepared and a handle is
+          permanently attached to the connection object right before the first
+          time it is executed.
+
+        - If true, everything allocated in order to execute the statement is
+          released after use.
+
+      In other words, the default is suitable for queries which are bound to
+      static modules.  Conversely, you should pass [~oneshot:true] if the query
+      is dynamically generated, whether it is within a function or a dynamic
+      module, since there will otherwise be a memory leak associated with
+      long-lived connections.  You might as well also pass [~oneshot:true] if
+      you know that the query will only executed at most once (or a very few
+      times) on each connection. *)
+
+val param_type : ('a, _, _) t -> 'a Caqti_type.t
+(** [param_type req] is the type of parameter bundles expected by [req]. *)
+
+val row_type : (_, 'b, _) t -> 'b Caqti_type.t
+(** [row_type req] is the type of rows returned by [req]. *)
+
+val row_mult : (_, _, 'm) t -> 'm Caqti_mult.t
+(** [row_mult req] indicates how many rows [req] may return.  This is asserted
+    when constructing the query. *)
+
+(**/**)
+val query_id : ('a, 'b, 'm) t -> int option
+[@@alert deprecated
+  "This function is no longer used internally by Caqti and will be removed."]
+(**/**)
+
+val query : ('a, 'b, 'm) t -> Caqti_driver_info.t -> Caqti_query.t
+(** [query req] is the function which generates the query of this request
+    possibly tailored for the given driver. *)
+
+
+(** {2 Convenience Interface} *)
+
+module Infix : sig
+  (** The following operators provides a more visually appealing way of
+      expressing requests.  They are implemented in terms of {!create} and
+      {!Caqti_query.of_string_exn}, meaning the the query string arguments
+      accepts {{!query_template} The Syntax of Query Templates}.
+
+      The [?oneshot] argument defaults to [false], so when not constructing
+      one-shot queries, the full application [(pt -->! rt) f] can be written
+      [pt -->! rt @@ f], which motivates the {!(@:-)} and {!(@@:-)} shortcuts.
+
+      In the simplest case you can use this module directly together with
+      {!Caqti_type}:
+      {[
+        let bounds_upto_req =
+          let open Caqti_type.Std in
+          let open Caqti_request.Infix in
+          tup2 int32 float -->! option (tup2 float float) @:-
+          "SELECT min(y), max(y) FROM samples WHERE series_id = ? AND x < ?"
+      ]}
+      For more complex applications it may be convenient to provide a custom
+      module, to avoid the double open and to customize the operators, e.g.
+      {[
+        module Caqtireq = struct
+          include Caqti_type.Std
+          include Caqti_type_calendar (* if needed, link caqti-type-calendar *)
+          include Caqti_request.Infix
+
+          (* Any additional types. *)
+          let password = redacted string
+          let uri =
+            custom ~encode:(fun x -> Ok (Uri.to_string x))
+                   ~decode:(fun s -> Ok (Uri.of_string s)) string
+
+          (* Optionally define a custom environment providing two schema names.
+           * The references should only be assigned at startup. *)
+          let myapp_schema = ref "myapp"
+          let mylib_schema = ref "mylib"
+          let env = function
+           | "" -> Caqti_query.L !myapp_schema
+           | "mylib" -> Caqti_query.L !mylib_schema
+           | _ -> raise Not_found
+
+          (* Since we have a custom environment, override the definitions of the
+           * following operators to perform the substitution. *)
+          let (@:-) t qs =
+            let q = Caqti_query.expand env (Caqti_query.of_string_exn qs) in
+            t (fun _ -> q)
+          let (@@:-) t qsf =
+            t (fun driver_info ->
+              let qs = qsf (Caqti_driver_info.dialect_tag driver_info) in
+              Caqti_query.expand env (Caqti_query.of_string_exn qs))
+        end
+      ]}
+      If you don't like using global references, or you need to work with
+      different enviroments for different connections, you should instead pass
+      the environment function when connecting to the database.  We can now
+      simplify and schema-qualify the previous request,
+      {[
+        let bounds_upto_req =
+          let open Caqtireq in
+          tup2 int32 float -->! option (tup2 float float) @:-
+          "SELECT min(y), max(y) FROM $.samples WHERE series_id = ? AND x < ?"
+      ]}
+      {!section:indep} also provides alternative arrow operators for this common
+      case, which allows using short-from local open,
+      {[
+        let bounds_upto_req =
+          Caqtireq.(tup2 int32 float ->! option (tup2 float float))
+          "SELECT min(y), max(y) FROM $.samples WHERE series_id = ? AND x < ?"
+      ]}
+   *)
+
+  (** {2:indep Constructors for Driver-Independent Requests} *)
+
+  val ( ->. ) :
+    'a Caqti_type.t -> unit Caqti_type.t ->
+    ?oneshot: bool -> string -> ('a, unit, [`Zero]) t
+  (** [(pt ->. Caqti_type.unit) ?oneshot s] is the request which sends the
+      query string [s], encodes parameters according to [pt], and expects no
+      result rows. See {!create} for the meaning of [oneshot]. *)
+
+  val ( ->! ) :
+    'a Caqti_type.t -> 'b Caqti_type.t ->
+    ?oneshot: bool -> string -> ('a, 'b, [`One]) t
+  (** [(pt ->! rt) ?oneshot s] is the request which sends the query string [s],
+      encodes parameters according to [pt], and decodes a single result row
+      according to [rt]. See {!create} for the meaning of [oneshot]. *)
+
+  val ( ->? ) :
+    'a Caqti_type.t -> 'b Caqti_type.t ->
+    ?oneshot: bool -> string -> ('a, 'b, [`Zero | `One]) t
+  (** [(pt ->? rt) ?oneshot s] is the request which sends the query string [s],
+      encodes parameters according to [pt], and decodes zero or one result row
+      according to [rt]. See {!create} for the meaning of [oneshot]. *)
+
+  val ( ->* ) :
+    'a Caqti_type.t -> 'b Caqti_type.t ->
+    ?oneshot: bool -> string -> ('a, 'b, [`Zero | `One | `Many]) t
+  (** [(pt ->* rt) ?oneshot s] is the request which sends the query string [s],
+      encodes parameters according to [pt], and decodes any number of result
+      rows according to [rt]. See {!create} for the meaning of [oneshot]. *)
+
+  (** {2 Constructors for Driver-Dependent Requests}
+
+      The below arrow operators takes a function instead of a string as their
+      third argument.  The function receives information about the current
+      driver and returns a {!Caqti_query.t}.  This is the most general way of
+      providing the query string.
+
+      As an alternative to using plain application (or [@@]) for the third
+      positional argument, additional application operators are provided for
+      convenience. *)
+
+  val ( -->. ) :
+    'a Caqti_type.t -> unit Caqti_type.t ->
+    ?oneshot: bool -> (Caqti_driver_info.t -> Caqti_query.t) ->
+    ('a, unit, [`Zero]) t
+  (** [(pt -->. Caqti_type.unit) ?oneshot f] is the request which sends the
+      query string returned by [f], encodes parameters according to [pt], and
+      expects no result rows. See {!create} for the meaning of [oneshot]. *)
+
+  val ( -->! ) :
+    'a Caqti_type.t -> 'b Caqti_type.t ->
+    ?oneshot: bool -> (Caqti_driver_info.t -> Caqti_query.t) ->
+    ('a, 'b, [`One]) t
+  (** [(pt -->! rt) ?oneshot f] is the request which sends the query string
+      returned by [f], encodes parameters according to [pt], and decodes a
+      single result row according to [rt]. See {!create} for the meaning of
+      [oneshot]. *)
+
+  val ( -->? ) :
+    'a Caqti_type.t -> 'b Caqti_type.t ->
+    ?oneshot: bool -> (Caqti_driver_info.t -> Caqti_query.t) ->
+    ('a, 'b, [`Zero | `One]) t
+  (** [(pt -->? rt) ?oneshot f] is the request which sends the query string
+      returned by [f], encodes parameters according to [pt], and decodes zero or
+      one result row according to [rt]. See {!create} for the meaning of
+      [oneshot]. *)
+
+  val ( -->* ) :
+    'a Caqti_type.t -> 'b Caqti_type.t ->
+    ?oneshot: bool -> (Caqti_driver_info.t -> Caqti_query.t) ->
+    ('a, 'b, [`Zero | `One | `Many]) t
+  (** [(pt -->* rt) ?oneshot f] is the request which sends the query string
+      returned by [f], encodes parameters according to [pt], and decodes any
+      number of result rows according to [rt]. See {!create} for the meaning of
+      [oneshot]. *)
+
+  val ( @:- ) :
+    ((Caqti_driver_info.t -> Caqti_query.t) -> ('a, 'b, 'm) t) ->
+    string -> ('a, 'b, 'm) t
+  (** Applies a dialect-independent query string which is parsed with
+      {!Caqti_query.of_string_exn}.  Composition with arrow operators from this
+      section, gives the corresponding operators from {!section:indep}. *)
+
+  val ( @@:- ) :
+    ((Caqti_driver_info.t -> Caqti_query.t) -> ('a, 'b, 'm) t) ->
+    (Caqti_driver_info.dialect_tag -> string) -> ('a, 'b, 'm) t
+  (** Applies a dialect-dependent query string which is parsed with
+      {!Caqti_query.of_string_exn}. *)
+
+end
+
+
+(** {2 Printing} *)
+
+val make_pp :
+  ?env: (Caqti_driver_info.t -> string -> Caqti_query.t) ->
+  ?driver_info: Caqti_driver_info.t ->
+  unit -> Format.formatter -> ('a, 'b, 'm) t -> unit
+(** [make_pp ?env ?driver_info ()] is a pretty-printer for a request, which
+    expands the query using [env] and [driver_info].
+
+    @param env
+      Used to partially expand the query string.  Defaults to the empty
+      environment.
+
+    @param driver_info
+      The driver info to pass to the call-back which returns the query.
+      Defaults to {!Caqti_driver_info.dummy}. *)
+
+val pp : Format.formatter -> ('a, 'b, 'm) t -> unit
+(** [pp ppf req] prints [req] on [ppf] in a form suitable for human
+    inspection. *)
+
+val make_pp_with_param :
+  ?env: (Caqti_driver_info.t -> string -> Caqti_query.t) ->
+  ?driver_info: Caqti_driver_info.t ->
+  unit -> Format.formatter -> ('a, 'b, 'm) t * 'a -> unit
+(** [make_pp_with_param ?env ?driver_info ()] is a pretty-printer for a
+    request and parameter pair.  See {!make_pp} for the optional arguments.
+    This functions is meant for debugging; the output is neither guaranteed to
+    be consistent across releases nor to contain a complete record of the data.
+    Lost database records cannot be reconstructed from the logs.
+
+    Due to concerns about exposure of sensitive data in debug logs, this
+    function only prints the parameter values if [CAQTI_DEBUG_PARAM] is set to
+    [true].  If you enable it for applications which do not consistenly annotate
+    sensitive parameters with {!Caqti_type.redacted}, make sure your debug logs
+    are well-secured. *)
+
+(** {2 How to Dynamically Assemble Queries and Parameters}
+
+    In some cases, queries are constructed dynamically, e.g. when translating an
+    expression for searching a database into SQL.  In such cases the number of
+    parameters and their types will typically vary, as well.  A helper like the
+    following can be used to existentially pack the parameter types along with
+    the corresponding parameter values to allow collecing them incrementally:
+    {[
+      module Dynparam = struct
+        type t = Pack : 'a Caqti_type.t * 'a -> t
+        let empty = Pack (Caqti_type.unit, ())
+        let add t x (Pack (t', x')) = Pack (Caqti_type.tup2 t' t, (x', x))
+      end
+    ]}
+    Now, given a [param : Dynparam.t] and a corresponding query string [qs], one
+    can construct a request and execute it:
+    {[
+      let Dynparam.Pack (pt, pv) = param in
+      let req = Caqti_request.exec ~oneshot:true pt qs in
+      C.exec req pv
+    ]}
+    Note that dynamically constructed requests should have [~oneshot:true]
+    unless they are memoized.  Also note that it is natural to use {!create} for
+    dynamically constructed queries, since it accepts the easily composible
+    {!Caqti_query.t} type instead of plain strings.
+
+    This scheme can be specialized for particular use cases, including
+    generation of fragments of the [query], which reduces the risk of wrongly
+    matching up parameters with their uses in the query string.
+    *)

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_response_sig.ml

@@ -0,0 +1,89 @@
+(* 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.
+ *)
+
+(** Signature of a response from a database. *)
+
+module type S = sig
+  type +'b fiber
+
+  type (+'a, +'err) stream
+
+  type ('b, +'m) t
+  (** The type describing the response and containing returned data from a
+      request execution.
+      - ['b] is the type of a single row
+      - ['m] is the possible multiplicities of rows *)
+
+  (** {2 Result inspection} *)
+
+  val returned_count :
+    ('b, 'm) t -> (int, [> Caqti_error.retrieve | `Unsupported]) result fiber
+  (** [returned_count resp] is the number of rows returned by [resp].  This
+      function may not be available for all drivers. *)
+
+  val affected_count :
+    ('b, 'm) t -> (int, [> Caqti_error.retrieve | `Unsupported]) result fiber
+  (** [affected_count resp] is the number of rows affected by the updated the
+      produced [resp].  This function may not be available for all drivers. *)
+
+  (** {2:result_retrieval Result retrieval} *)
+
+  val exec :
+    (unit, [< `Zero]) t -> (unit, [> Caqti_error.retrieve]) result fiber
+  (** [exec resp] checks that [resp] succeeded with no result rows. *)
+
+  val find :
+    ('b, [< `One]) t -> ('b, [> Caqti_error.retrieve]) result fiber
+  (** [find resp] checks that [resp] succeeded with a single row, and returns
+      the decoded row. *)
+
+  val find_opt :
+    ('b, [< `Zero | `One]) t ->
+    ('b option, [> Caqti_error.retrieve]) result fiber
+  (** [find_opt resp] checks that [resp] succeeded with at most one row, and
+      returns the row if any. *)
+
+  val fold :
+    ('b -> 'c -> 'c) ->
+    ('b, 'm) t -> 'c -> ('c, [> Caqti_error.retrieve]) result fiber
+  (** [fold f resp] folds [f] over the decoded rows returned in [resp]. *)
+
+  val fold_s :
+    ('b -> 'c -> ('c, 'e) result fiber) ->
+    ('b, 'm) t -> 'c -> ('c, [> Caqti_error.retrieve] as 'e) result fiber
+  (** [fold_s f resp] folds [f] over the decoded rows returned by [resp] within
+      the IO and result monad.
+
+      {b Note.} Do not make nested queries in the callback to this function.  If
+      you use the same connection, it may lead to data corruption.  If you pull
+      a different connection from the same pool, it may deadlock if the pool
+      runs out of connections.  Also, some drivers may not support simpltaneous
+      connections. *)
+
+  val iter_s :
+    ('b -> (unit, 'e) result fiber) ->
+    ('b, 'm) t -> (unit, [> Caqti_error.retrieve] as 'e) result fiber
+  (** [iter_s f resp] iterates [f] over the decoded rows returned by [resp]
+      within the IO and result monad.
+
+      {b Note.} Do not make nested queries in the callback to this function.
+      Cf. {!fold_s}. *)
+
+  val to_stream : ('b, 'm) t -> ('b, [> Caqti_error.retrieve]) stream
+    (** [to_stream resp] returns a stream whose elements are the decoded rows
+        returned by [resp]. *)
+end

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_stream_sig.ml

@@ -0,0 +1,75 @@
+(* Copyright (C) 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.
+ *)
+
+(** Concurrent stream signature. *)
+
+module type S = sig
+  type +'a fiber
+
+  type ('a, 'err) t = unit -> ('a, 'err) node fiber
+  (** A stream, represented as a lazy chain of {!Cons}-nodes terminating in a
+      {!Nil} or an {!Error}. *)
+
+  and ('a, 'err) node =
+    | Nil                       (** The node of an empty stream *)
+    | Error of 'err             (** A node of a permanently failed stream. *)
+    | Cons of 'a * ('a, 'err) t
+        (** A node holding the next element and continuation of a stream. *)
+
+  val fold :
+    f: ('a -> 'state -> 'state) ->
+    ('a, 'err) t ->
+    'state ->
+    ('state, 'err) result fiber
+  (** [fold ~f stream acc] consumes the remainder elements [e1], ..., [eN] of
+      [stream] and returns [Ok (acc |> f e1 |> ... |> f eN)] if no error
+      occurred *)
+
+  val fold_s :
+    f: ('a -> 'state -> ('state, 'err) result fiber) ->
+    ('a, 'clog) t ->
+    'state ->
+    ('state, [> `Congested of 'clog ] as 'err) result fiber
+  (** [fold_s ~f stream acc] consumes the remainder of [stream], passing each
+      element in order to [f] along with the latest accumulation starting at
+      [acc], and returning the final accumulation if successful.  An error
+      result may be due to either the stream provider or the callback, as
+      distinguished with the [`Congested] constructor. *)
+
+  val iter_s :
+    f: ('a -> (unit, 'err) result fiber) ->
+    ('a, 'clog) t ->
+    (unit, [> `Congested of 'clog ] as 'err) result fiber
+  (** [iter_s ~f stream] consumes the remainder of [stream], passing each
+      element in order to [f].  An error result may be due to either the steram
+      provider or the callback, as distinguished with the [`Congested]
+      constructor. *)
+
+  val to_rev_list : ('a, 'err) t -> ('a list, 'err) result fiber
+  (** [to_rev_list stream] consumes the remainder of [stream], returning a list
+      of its element in reverse order of production. *)
+
+  val to_list : ('a, 'err) t -> ('a list, 'err) result fiber
+  (** [to_list stream] consumes the remainder of [stream], returning a list of
+      its element in order of production. *)
+
+  val of_list : 'a list -> ('a, 'err) t
+  (** [of_list xs] is a non-failing finite stream (re)producing the elements
+      [xs] in order of occurrence. *)
+
+  val map_result : f: ('a -> ('b, 'err) result) -> ('a, 'err) t -> ('b, 'err) t
+end

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_switch_sig.ml

@@ -0,0 +1,67 @@
+(* Copyright (C) 2023--2025  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+(** Switch implementation used where not available.
+
+    A switch provides scoped release of resources.  The signature here is
+    provided on platforms where we don't use its native implementation, either
+    because it does not exist or lacks functionality on which we rely. *)
+
+module type S = sig
+  type 'a fiber
+  type t
+  type hook
+
+  exception Off
+
+  (** {1 Explicit Construction and Release}
+
+      The following functions are resource-unsafe, since do not scope the
+      lifetime of constructed switches to a function call like {!run}.
+      They are nevertheless useful for applications which do not follow the
+      EIO-style resource handling discipline.
+      The [caqti-eio] package uses the native EIO switch implementation, which
+      excludes these functions. *)
+
+  val eternal : t
+  (** A switch which is never released. *)
+
+  val create : unit -> t
+  (** Create a fresh releasable switch which is initially on. *)
+
+  val release : t -> unit fiber
+  (** [release sw] calls all cleanup handlers on [sw] in reverse order of
+      registration and marks the switch as being off. *)
+
+  (** {1 EIO-Compatible Interface} *)
+
+  val run : (t -> 'a fiber) -> 'a fiber
+  (** [run f] calls [f] with a fresh switch which will be released upon exit or
+      in case of failure. *)
+
+  val check : t -> unit
+  (** [check sw] raises [Off] if [sw] has been turned off. *)
+
+  val on_release_cancellable : t -> (unit -> unit fiber) -> hook
+  (** [on_release_cancellable sw f] registers [f] to be called upon the evetual
+      release of [sw] unless {!remove_hook} is called on the returned hook
+      before that happen. *)
+
+  val remove_hook : hook -> unit
+  (** Given a [hook] returned by {!on_release_cancellable}, [remove_hook hook]
+      cancels the cleanup registered by that call. *)
+end

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_type.ml

@@ -0,0 +1,68 @@
+(* Copyright (C) 2024--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
+type ('a, 'b) eq = ('a, 'b) Caqti_template.Shims.Type.eq = Equal : ('a, 'a) eq
+module Field = Caqti_template.Field_type
+include Caqti_template.Row_type
+let equal_value = Caqti_template.Row.equal
+let pp_value ppf (t, v) = Caqti_template.Row.pp t ppf v
+
+type (_, _) product =
+  | Proj_end : ('a, 'a) product
+  | Proj : 'b t * ('a -> 'b) * ('a, 'i) product -> ('a, 'b -> 'i) product
+
+let field ft = Private.Field ft
+
+module Std = struct
+  include (Caqti_template.Row_type : Caqti_template.Row_type.STD)
+
+  (* moved away from STD signature *)
+  let enum = enum
+
+  type (_, _) rewritten_product =
+    | Rewritten_product :
+        ('i -> 'j) * ('j, 'a) Row_type.product ->
+        ('i, 'a) rewritten_product
+
+  let rec rewrite_product
+    : type i a. (a, i) product -> (i, a) rewritten_product =
+    (function
+     | Proj_end ->
+        Rewritten_product (Result.ok, Row_type.Private.Proj_end)
+     | Proj (t, p, tps) ->
+        let Rewritten_product (conv, ts') = rewrite_product tps in
+        let conv' f = fun x -> conv (f x) in
+        Rewritten_product (conv', Row_type.Private.Proj (t, p, ts')))
+
+  let product intro tps =
+    let Rewritten_product (conv, ts') = rewrite_product tps in
+    product (conv intro) ts'
+
+  let proj t p tps = Proj (t, p, tps)
+  let proj_end = Proj_end
+
+  let custom = custom
+
+  (* deprecated *)
+  let tup2 = t2
+  let tup3 = t3
+  let tup4 = t4
+end
+include Std

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_type.mli

@@ -0,0 +1,108 @@
+(* 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.
+ *)
+
+(** Type descriptors for fields and tuples. *)
+
+[@@@alert "-caqti_private"]
+open Caqti_template
+
+exception Reject of string
+
+type ('a, 'b) eq = ('a, 'b) Caqti_template.Shims.Type.eq = Equal : ('a, 'a) eq
+
+(** {2 Primitive Field Types}
+
+    The following is normally only needed for drivers and to define new field
+    types.  Everything needed for common usage is covered in {!row_types}. *)
+
+(** Facilities for extending and using primitive field types. *)
+module Field : sig
+  type 'a t = 'a Field_type.t =
+    | Bool : bool t
+    | Int : int t
+    | Int16 : int t
+    | Int32 : int32 t
+    | Int64 : int64 t
+    | Float : float t
+    | String : string t
+    | Octets : string t
+    | Pdate : Ptime.t t
+    | Ptime : Ptime.t t
+    | Ptime_span : Ptime.span t
+    | Enum : string -> string t
+
+  val unify : 'a t -> 'b t -> ('a, 'b) eq option
+
+  val equal_value : 'a t -> 'a -> 'a -> bool
+
+  val to_string : 'a t -> string
+
+  val pp : Format.formatter -> 'a t -> unit
+
+  val pp_value : Format.formatter -> 'a t * 'a -> unit
+end
+
+(** {2:row_types Row Types} *)
+
+type 'a t = 'a Row_type.t
+(** Type descriptor for row types. *)
+
+type ('a, 'i) product =
+  | Proj_end : ('a, 'a) product
+  | Proj : 'b t * ('a -> 'b) * ('a, 'i) product -> ('a, 'b -> 'i) product
+(** Type descriptor for building cartesian products of row types. *)
+
+(** {!t} with existentially wrapped static type. *)
+
+type any = Any : 'a t -> any
+
+val unify : 'a t -> 'b t -> ('a, 'b) eq option
+(** If [t1] and [t2] are the same row type representations, then [unify t1 t2]
+    is the witness of the unification of their static type parameters, otherwise
+    it is [None]. *)
+
+val equal_value : 'a t -> 'a -> 'a -> bool
+(** [equal_value t] is the equality predicate for values of row type [t]. *)
+
+val length : 'a t -> int
+(** [length t] is the number of fields used to represent [t]. *)
+
+val pp : Format.formatter -> 'a t -> unit
+(** [pp ppf t] prints a human presentation of [t] on [ppf]. *)
+
+val pp_any : Format.formatter -> any -> unit
+(** [pp_any ppf t] prints a human presentation of [t] on [ppf]. *)
+
+val pp_value : Format.formatter -> 'a t * 'a -> unit
+(** [pp_value ppf (t, v)] prints a human representation of [v] given the type
+    descriptor [t]. This function is meant for debugging; the output is neither
+    guaranteed to be consistent across releases nor to contain a complete record
+    of the data. *)
+
+val show : 'a t -> string
+(** [show t] is a human presentation of [t]. *)
+
+val field : 'a Field.t -> 'a t
+(** [field ft] is a row of a single field of type [ft]. This function can be
+    used when adding new field types; use the below functions otherwise. *)
+
+module Std : Caqti_type_sig.Std
+  with type 'a t := 'a t and type ('a, 'i) product := ('a, 'i) product
+(** Standard type descriptors provided as a submodule for easy inclusion. *)
+
+include Caqti_type_sig.Std
+  with type 'a t := 'a t and type ('a, 'i) product := ('a, 'i) product

unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_type_sig.ml

@@ -0,0 +1,252 @@
+(* Copyright (C) 2018--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.
+ *)
+
+(** Signatures for {!Caqti_type}. *)
+
+(** Standard type descriptors. *)
+module type Std = sig
+
+  type 'a t
+
+
+  (** {3 Field Types}
+
+      The following types correspond to what usually fits in a single field of a
+      result row or input parameter set. *)
+
+  val bool : bool t
+  (** A [bool] mapped to [boolean] on the SQL side if supported, otherwise
+      mapped to an integer. *)
+
+  val int : int t
+  (** An [int] mapped to a sufficiently wide integer on the SQL side. *)
+
+  val int16 : int t
+  (** An [int] mapped to a [smallint] (16 bits) on the SQL side. *)
+
+  val int32 : int32 t
+  (** An [int32] mapped to an [integer] (32 bits) on the SQL side. *)
+
+  val int64 : int64 t
+  (** An [int64] mapped to a [bigint] (64 bits) on the SQL side. *)
+
+  val float : float t
+  (** A [float] mapped to [double precision] or (best alternative) on the SQL
+      side. Serialization may be lossy (e.g. base 10 may be used), so even if
+      both sides support IEEE 754 double precision numbers, there may be
+      discrepancies in the last digits of the binary representaton. *)
+
+  val string : string t
+  (** An UTF-8 string. The database should accept UTF-8 if non-ASCII characters
+      are present. *)
+
+  val octets : string t
+  (** A [string] mapped to whichever type is used to represent binary data on
+      the SQL side. *)
+
+  val pdate : Ptime.t t
+  (** A time truncated to a date and mapped to the SQL [date] type. *)
+
+  val ptime : Ptime.t t
+  (** An absolute time with driver-dependent precision. This corresponds to an
+      SQL [timestamp with time zone] or a suitable alternative where not
+      available:
+
+        - MariaDB has [datetime] which is similar to the SQL [timestamp] and
+          [timestamp] which is similar to the SQL [timestamp with time zone],
+          but the driver does not make the distinction.  Caqti sets the session
+          time zone to UTC to avoid misinterpretation, since time values are
+          passed in both directions without time zones.  Values have microsecond
+          precision, but you will need to specify the desired precision in the
+          database schema to avoid truncation.
+
+        - PostgreSQL supports this type and it's a good option to avoid any time
+          zone issues if used conistently both on the client side, in SQL
+          expressions, and in the database schema.  Note that [timestamp with
+          time zone] is stored as UTC without time zone, taking up no more space
+          then [timestamp].  The PostgreSQL [timestamp] type is problematic
+          since how conversions work and the manual indicate that it is meant to
+          be a local time, and since database columns of this type stores the
+          value without conversion to UTC, it becomes prone to time zone
+          changes.  To mitigate the issue, Caqti sets the time zone of sessions
+          to UTC.
+
+        - Sqlite3 does not have a dedicated type for absolute time.  The date
+          and time is sent as strings expressed at the UTC time zone using same
+          format that the SQLite {{:https://sqlite.org/lang_datefunc.html}
+          datetime} function and [CURRENT_TIMESTAMP] return, except for an
+          additional three decimals to achive millisecond precision.
+
+          It might seem better to use standard RFC3339 format, since it is
+          accepted by the SQLite functions, but that would misorder some time
+          values if mixed with the results of these functions, even just the "Z"
+          suffix would misorder values with different precision.
+
+      Date and time values which comes from the database without time zone are
+      interpreted as UTC. This is not necessarily correct, and it is highly
+      recommended to use SQL types which are transmitted with time zone
+      information, even if this is UTC. *)
+
+  val ptime_span : Ptime.span t
+  (** A period of time. If the database lacks a dedicated representation, the
+      integer number of seconds is used. *)
+
+  val enum :
+    encode: ('a -> string) ->
+    decode: (string -> ('a, string) result) ->
+    string -> 'a t
+  (** [enum ~encode ~decode name] creates an enum type which on the SQL side is
+      named [name], with cases which are converted with [encode] and [decode]
+      functions. This is implemented in terms of the {!Caqti_type.Field.Enum}
+      field type. *)
+
+
+  (** {3 Composite Types} *)
+
+  type ('a, 'i) product
+  val product : 'i -> ('a, 'i) product -> 'a t
+  val proj : 'b t -> ('a -> 'b) -> ('a, 'i) product -> ('a, 'b -> 'i) product
+  val proj_end : ('a, 'a) product
+  (** Given a set of projection functions [p1 : t -> t1], ..., [pN : t -> tN]
+      and a function [intro : t1 -> ... -> tN -> t] to reconstruct values of [t]
+      from the projections,
+      {[
+        product intro
+          @@ proj t1 p1
+          @@ ...
+          @@ proj tN pN
+          @@ proj_end
+      ]}
+      defines a Caqti type for [t], which on the database side will be
+      represented by a consecutive list of fields corresponding to the types
+      [t1], ..., [tN], each of which may be represented by multiple fields.
+      That is, [intro [project1 x] ...  [projectN x]] is equivalent to [x]
+      according to an enforced or effective abstraction of [t] deemed adequate
+      for the application logic.
+
+      [intro] may raise {!Caqti_type.Reject} to indicate that a value cannot be
+      constructed from the given arguments.
+      Projection operators may also raise this exception to indicate that an
+      object cannot be represented in the database, e.g. due to an overflow.
+
+      The above only states that [intro] is a left (pseudo-)inverse of the
+      projections, which is what matters for a faithful representation of OCaml
+      values.
+      The opposite (projection functions being the left inverse of [intro]) may
+      be relevant if the application needs preserve the database representation
+      when updating objects. *)
+
+  val custom :
+    encode: ('a -> ('b, string) result) ->
+    decode: ('b -> ('a, string) result) ->
+    'b t -> 'a t
+  (** [custom ~encode ~decode rep] creates a custom type represented by [rep],
+      where [encode] is used to encode parameters into [rep] and [decode] is
+      used to decode result rows from [rep]. *)
+
+  val option : 'a t -> 'a option t
+  (** [option t] turns a set of fields encoded as [t] into a correspending set
+      of nullable fields.  The encoder will encode [None] as into a tuple of
+      [NULL] values and the decoder will return [None] if all fields are [NULL].
+
+      If the type [t] itself is [option t'] for some [t'], or contains nested
+      tuples and options such that all field types are nested under an option
+      type, then it would have been possible to decode an all-[NULL] segment of
+      a row as [Some x] where [x] is a corresponding tuple-option-tree
+      terminating in [None] values.  The above paragraph resolves this ambiguity
+      since it implies that the outermost option possible will be decoded as
+      [None]. *)
+
+  val redacted : 'a t -> 'a t
+  (** [redacted t] is the same type as [t] but sealed as potentially containing
+      sensitive information to be redacted from pretty-printers and logs. *)
+
+
+  (** {3 Tuple Types}
+
+      As a common case of composite types, constructors for tuples up to 12
+      components are predefined here.  Higher tuples can be created with
+      {!val-product}. *)
+
+  val unit : unit t
+  (** A type holding no fields. This is used to pass no parameters and as the
+      result for queries which does not return any rows. It can also be nested
+      in tuples, in which case it will not contribute to the total number of
+      fields. *)
+
+  val t2 : 'a1 t -> 'a2 t -> ('a1 * 'a2) t
+  (** Creates a pair type. *)
+
+  val t3 : 'a1 t -> 'a2 t -> 'a3 t -> ('a1 * 'a2 * 'a3) t
+  (** Creates a 3-tuple type. *)
+
+  val t4 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> ('a1 * 'a2 * 'a3 * 'a4) t
+  (** Creates a 4-tuple type. *)
+
+  val t5 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5) t
+  (** Creates a 5-tuple type. *)
+
+  val t6 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t
+  (** Creates a 6-tuple type. *)
+
+  val t7 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) t
+  (** Creates a 7-tuple type. *)
+
+  val t8 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) t
+  (** Creates a 8-tuple type. *)
+
+  val t9 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) t
+  (** Creates a 9-tuple type. *)
+
+  val t10 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t -> 'a10 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) t
+  (** Creates a 10-tuple type. *)
+
+  val t11 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t -> 'a10 t -> 'a11 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) t
+  (** Creates a 11-tuple type. *)
+
+  val t12 :
+    'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
+    'a9 t -> 'a10 t -> 'a11 t -> 'a12 t ->
+    ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12) t
+  (** Creates a 12-tuple type. *)
+
+
+  (**/**)
+  val tup2 : 'a1 t -> 'a2 t -> ('a1 * 'a2) t
+  [@@deprecated "Renamed to t2."]
+  val tup3 : 'a1 t -> 'a2 t -> 'a3 t -> ('a1 * 'a2 * 'a3) t
+  [@@deprecated "Renamed to t3."]
+  val tup4 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> ('a1 * 'a2 * 'a3 * 'a4) t
+  [@@deprecated "Renamed to t4."]
+end

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

@@ -0,0 +1,7 @@
+(library
+ (name caqti)
+ (public_name caqti)
+ (wrapped false)
+ (flags (:standard -alert -caqti_unstable))
+ (library_flags (:standard -linkall))
+ (libraries angstrom bigstringaf caqti.template logs mtime ptime uri))

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

@@ -0,0 +1,5 @@
+(test
+ (name main)
+ (package caqti)
+ (flags (:standard -alert -caqti_unstable))
+ (libraries alcotest caqti caqti.platform re.pcre))

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

@@ -0,0 +1,27 @@
+(* Copyright (C) 2021--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.
+ *)
+
+let tests = [
+  "heap", Test_heap.test_cases;
+  "query", Test_query.test_cases;
+  "request", Test_request.test_cases;
+  "request_cache", Test_request_cache.test_cases;
+  "switch", Test_switch.test_cases;
+  "version", Test_version.test_cases;
+]
+
+let () = Alcotest.V1.run "caqti" tests

unikernel/duniverse/ocaml-caqti/caqti/test/test_heap.ml

@@ -0,0 +1,35 @@
+(* Copyright (C) 2014--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.
+ *)
+
+module H =
+  Caqti_platform.Heap.Make (struct type t = int let compare = compare end)
+
+let test_push_pop_n n =
+  let a = Array.init n (fun _ -> Random.int n) in
+  let h = Array.fold_right H.push a H.empty in
+  Array.sort (fun i j -> compare j i) a;
+  let check_pop x h =
+    let x', h' = H.pop_e h in
+    assert (x = x'); h' in
+  let h' = Array.fold_right check_pop a h in
+  assert (H.is_empty h')
+
+let test_push_pop () = for i = 0 to 599 do test_push_pop_n i done
+
+let test_cases = [
+  "push, pop", `Quick, test_push_pop;
+]

unikernel/duniverse/ocaml-caqti/caqti/test/test_query.ml

@@ -0,0 +1,193 @@
+(* 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 Query = Caqti_template.Query
+module Query_fmt = Caqti_template.Query_fmt
+
+module A = struct
+  include Alcotest.V1
+
+  let query = testable Query.pp (fun x y -> Query.(equal (normal x) (normal y)))
+
+  let approx_query_string =
+    let pp ppf x = Format.fprintf ppf "%S" x in
+    let normalize =
+      let re = Re.Pcre.regexp {|\$([0-9]|[A-Za-z0-9_]*\.)|} in
+      let f g =
+        let s = Re.Group.get g 1 in
+        if s.[String.length s - 1] = '.' then "$(" ^ s ^ ")" else "?"
+      in
+      Re.replace re ~f
+    in
+    testable pp (fun x y -> String.equal (normalize x) (normalize y))
+end
+
+let random_letter () = Char.chr (Char.code 'a' + Random.int 26)
+
+let rec random_query n =
+  if n <= 1 then
+    if Random.bool ()
+      then Query.param (Random.int 8)
+      else Query.lit (String.init (Random.int 3) (fun _ -> random_letter ()))
+  else
+    Query.concat (random_queries n)
+and random_queries n =
+  if n = 0 then [] else
+  if Random.bool () then [random_query n] else
+  let m = Random.int (n + 1) in
+  random_queries m @ random_queries (n - m)
+
+let test_show_and_hash_once () =
+  let q1 = random_query (Random.int 8 + Random.int (1 lsl Random.int 8)) in
+  let q2 = random_query (Random.int 8 + Random.int (1 lsl Random.int 8)) in
+  let s1 = Query.show q1 in
+  let s2 = Query.show q2 in
+  if Query.equal q1 q2 then assert (Query.hash q1 = Query.hash q2);
+  assert ((s1 = s2) = (Query.(equal (normal q1) (normal q2))))
+
+let test_show_and_hash () =
+  try
+    for _ = 0 to 9999 do test_show_and_hash_once () done
+  with Failure msg ->
+    Printf.eprintf "%s\n" msg;
+    exit 1
+
+let random_query_string () =
+  let random_char _ = Char.chr (0x20 + Random.int 0x60) in
+  String.init (Random.int 128) random_char
+
+let test_parse_special_cases () =
+  let check_reject ~pos s =
+    (match Caqti_query.of_string s with
+     | Ok _ ->
+        A.failf "Invalid expression %S accepted by parser." s
+     | Error (`Invalid (pos', msg)) ->
+        if pos' <> pos then
+          A.failf "Position %d should be %d for error %S while parsing %s"
+                  pos' pos msg s)
+  in
+  let check_normal' s =
+    (match Caqti_query.of_string_exn s with
+     | q ->
+        A.(check string) "same" s (Caqti_query.show q)
+     | exception Failure msg ->
+        A.failf "Failed to parse %S: %s" s msg)
+  in
+  let check_normal s =
+    check_normal' s;
+    check_normal' (" " ^ s);
+    check_normal' (s ^ " ")
+  in
+  let check_expect q s =
+    A.(check query "same" q (Caqti_query.of_string_exn s))
+  in
+  check_reject ~pos:0 {|$0|}; check_reject ~pos:1 {|x$01|};
+  check_reject ~pos:1 {|?0|}; check_reject ~pos:2 {|x?1x|};
+  List.iter check_normal [
+    {||}; {|a|}; {|ab|}; {| a b |};
+    {|''|}; {|'a'|}; {|'''a''b'''|};
+    {|""|}; {|"a"|}; {|"""a""b"""|};
+    {|$(.)|}; {|$(a.)|}; {|$(ab.)|}; {|$(a)|}; {|$(ab)|};
+    {|$$ a $(x.) $(y) b $$|};
+    {|$$"$$|}; {|$$'$$|}; {|$QUOTE$ ' " $QUOTE$|};
+    {|$QUOTE$ a $x. $. $( z) b ?0 $QUOTE $$QUOTE$|};
+    (* Allowed by angstrom_parser_with_semicolon but not by angstrom_parser: *)
+    {|a;b|};
+  ];
+  check_expect
+    Query.(concat [lit "SELECT "; param 0; lit "::smallint"])
+    {|SELECT ?::smallint|};
+  check_expect
+    Query.(concat [lit "$$ "; var "x"; lit " $$"])
+    "$$ $(x) $$";
+  check_expect
+    Query.(concat [lit "$Q$ $(x) $Q$"])
+    "$Q$ $(x) $Q$";
+  check_expect
+    Query.(concat [param 0; lit " $$ ? $$ "; param 1; lit " "; param 2])
+    "? $$ ? $$ ? ?"
+
+let test_parse_random_strings () =
+  let check_normal_or_exn s =
+    (match Caqti_query.of_string s with
+     | Ok q ->
+        A.(check approx_query_string) "same" s (Caqti_query.show q)
+     | Error (`Invalid (_, "Inconsistent parameter style.")) -> ()
+     | Error (`Invalid (ok_len, _)) ->
+        if ok_len > 0 && ok_len < String.length s then begin
+          let s' = String.sub s 0 ok_len in
+          (match Caqti_query.of_string s' with
+           | Ok q ->
+              A.(check approx_query_string) "same" s' (Caqti_query.show q)
+           | Error (`Invalid (_, "Inconsistent parameter style.")) ->
+              () (* only checked after successful parse *)
+           | Error (`Invalid (pos, msg)) ->
+              A.failf "Supposed valid substring [0, %d) of %S fails at %d: %s"
+                ok_len s pos msg)
+        end)
+  in
+  for _ = 1 to 50_000 do
+    check_normal_or_exn (random_query_string ())
+  done
+
+let test_expand () =
+  let env1 = function
+   | "" -> Query.lit "default"
+   | "alt" -> Query.lit "other"
+   | _ -> raise Not_found
+  in
+  let env2 = function
+   | "." -> Query.lit "default."
+   | "alt." -> Query.lit "other."
+   | _ -> raise Not_found
+  in
+  let env3 = function
+   | "." -> Query.lit "dot"
+   | "cat" -> Query.lit "mouse"
+   | "cat." -> Query.lit "dog"
+   | _ -> raise Not_found
+  in
+  let q1 = Query.parse " $. $(.) $alt. $(alt.) $cat. $(cat) " in
+  let q1' = Query.parse " default. default. other. other. $cat. $(cat) " in
+  let q1'3 = Query.parse " dot dot $alt. $(alt.) dog mouse " in
+  A.(check query) "same" q1' (Caqti_query.expand env1 q1);
+  A.(check query) "same" q1' (Caqti_query.expand env2 q1);
+  A.(check query) "same" q1'3 (Caqti_query.expand env3 q1)
+
+let test_qprintf () =
+  let check_expect q1 q2 =
+    A.(check query "same" (Query.normal q1) (Query.normal q2))
+  in
+  check_expect
+    Query.(concat [
+      lit "SELECT "; param 0; lit " WHERE "; quote "quote"; lit " = "; var "env"
+    ])
+    Query_fmt.(
+      qprintf {|%a %a WHERE %a = %a|}
+        query (Query.lit "SELECT") param 0 quote "quote" env "env");
+  check_expect
+    Query.(concat [lit "WHERE "; var "tbl4"; lit ".name = "; quote "John Wayne"])
+    Query_fmt.(qprintf {|WHERE @{<E>tbl%d@}.name = @{<Q>%s Wayne@}|} 4 "John")
+
+
+let test_cases = [
+  A.test_case "show, hash" `Quick test_show_and_hash;
+  A.test_case "parse special cases" `Quick test_parse_special_cases;
+  A.test_case "parse random strings" `Quick test_parse_random_strings;
+  A.test_case "expand" `Quick test_expand;
+  A.test_case "qprintf" `Quick test_qprintf;
+]