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

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