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))