unikernel/duniverse/ocaml-caqti/caqti-mirage/dune

@@ -0,0 +1 @@
+(dirs :standard \ unikernel)

unikernel/duniverse/ocaml-caqti/caqti-mirage/lib/caqti_mirage.ml

@@ -0,0 +1,260 @@
+(* Copyright (C) 2022--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Lwt.Infix
+open Caqti_platform
+
+module type SOCKET_OPS =
+  Caqti_platform.System_sig.SOCKET_OPS with type 'a fiber := 'a Lwt.t
+
+module Make
+  (STACK : Tcpip.Stack.V4V6)
+  (DNS : Dns_client_mirage.S) =
+struct
+  module TCP = STACK.TCP
+  module TLS = Tls_mirage.Make (TCP)
+  module TCP_channel = Mirage_channel.Make (TCP)
+  module TLS_channel = Mirage_channel.Make (TLS)
+
+  module System_core = struct
+    include Caqti_lwt.System_core
+
+    type stdenv = {
+      stack: STACK.t;
+      dns: DNS.t;
+    }
+  end
+
+  module Alarm = struct
+    type t = {cancel: unit -> unit}
+
+    let schedule ~sw ~stdenv:_ t f =
+      let t_now = Mtime_clock.now () in
+      let dt_ns =
+        if Mtime.is_later t ~than:t_now then 0L else
+        Mtime.Span.to_uint64_ns (Mtime.span t t_now)
+      in
+      let task = Mirage_sleep.ns dt_ns >|= f in
+      let hook =
+        Caqti_lwt.Switch.on_release_cancellable sw
+          (fun () -> Lwt.cancel task; Lwt.return_unit)
+      in
+      {cancel = (fun () -> Caqti_lwt.Switch.remove_hook hook; Lwt.cancel task)}
+
+    let unschedule alarm = alarm.cancel ()
+  end
+
+  module Pool = Caqti_platform.Pool.Make (System_core) (Alarm)
+
+  module System = struct
+    include System_core
+    module Pool = Pool
+
+    module Net = struct
+
+      module Sockaddr = struct
+        type t = [`Tcp of Ipaddr.t * int | `Unix of string]
+        let unix s = `Unix s
+        let tcp (host, port) = `Tcp (host, port)
+      end
+
+      let getaddrinfo_ipv4 dns host port =
+        let extract (_, ips) =
+          Ipaddr.V4.Set.elements ips
+            |> List.map (fun ip -> `Tcp (Ipaddr.V4 ip, port))
+        in
+        DNS.getaddrinfo dns Dns.Rr_map.A host >|= Result.map extract
+
+      let getaddrinfo_ipv6 dns host port =
+        let extract (_, ips) =
+          Ipaddr.V6.Set.elements ips
+            |> List.map (fun ip -> `Tcp (Ipaddr.V6 ip, port))
+        in
+        DNS.getaddrinfo dns Dns.Rr_map.Aaaa host >|= Result.map extract
+
+      let getaddrinfo ~stdenv:{stack; dns} host port =
+        let laddrs = STACK.IP.configured_ips (STACK.ip stack) in
+        (match
+          List.exists Ipaddr.(function V4 _ -> true | V6 _ -> false) laddrs,
+          List.exists Ipaddr.(function V4 _ -> false | V6 _ -> true) laddrs
+         with
+         | true, true ->
+            getaddrinfo_ipv4 dns host port >>= fun r4 ->
+            getaddrinfo_ipv6 dns host port >|= fun r6 ->
+            (match r4, r6 with
+             | Ok addrs4, Ok addrs6 -> Ok (addrs4 @ addrs6)
+             | Ok addrs, Error _ | Error _, Ok addrs -> Ok addrs
+             | Error (`Msg msg4), Error (`Msg msg6) ->
+                if String.equal msg4 msg6 then Error (`Msg msg4) else
+                Error (`Msg ("IPv4: " ^ msg4 ^ " IPv6: " ^ msg6)))
+         | true, false -> getaddrinfo_ipv4 dns host port
+         | false, true -> getaddrinfo_ipv6 dns host port
+         | false, false ->
+            Lwt.return (Error (`Msg "No IP address assigned to host.")))
+
+      let convert_io_exception = function
+       | Failure msg -> Some (Caqti_error.Msg msg) (* Channel.S.error *)
+       | _ -> None
+
+      module Make_stream_ops (Channel : Mirage_channel.S) = struct
+        type t = Channel.t
+
+        let output_char channel c =
+          Channel.write_char channel c;
+          Lwt.return_unit
+
+        let output_string channel s =
+          Channel.write_string channel s 0 (String.length s);
+          Lwt.return_unit
+
+        let flush channel =
+          Channel.flush channel >>= function
+           | Ok () -> Lwt.return_unit
+           | Error err ->
+              Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
+
+        let input_char channel =
+          Channel.read_char channel >>= function
+           | Ok (`Data c) -> Lwt.return c
+           | Ok `Eof -> Lwt.fail End_of_file
+           | Error err ->
+              Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
+
+        let really_input channel buf off len =
+          Channel.read_exactly ~len channel >>= function
+           | Ok (`Data bufs) ->
+              let content = Cstruct.copyv bufs in
+              Bytes.blit_string content 0 buf off len;
+              Lwt.return_unit
+           | Ok `Eof -> Lwt.fail End_of_file
+           | Error err ->
+              Lwt.fail_with (Format.asprintf "%a" Channel.pp_error err)
+
+        let close channel =
+          Channel.close channel >>= function
+           | Ok () -> Lwt.return_unit
+           | Error err ->
+              Lwt.fail_with (Format.asprintf "%a" Channel.pp_write_error err)
+      end
+
+      module TCP_stream_ops = Make_stream_ops (TCP_channel)
+      module TLS_stream_ops = Make_stream_ops (TLS_channel)
+
+      module Socket = struct
+        type t = V : {
+          tcp_flow: TCP_channel.flow option;
+          ops: (module SOCKET_OPS with type t = 'a);
+          channel: 'a;
+        } -> t
+
+        let output_char (V {ops = (module Ops); channel; _}) =
+          Ops.output_char channel
+        let output_string (V {ops = (module Ops); channel; _}) =
+          Ops.output_string channel
+        let flush (V {ops = (module Ops); channel; _}) =
+          Ops.flush channel
+        let input_char (V {ops = (module Ops); channel; _}) =
+          Ops.input_char channel
+        let really_input (V {ops = (module Ops); channel; _}) =
+          Ops.really_input channel
+        let close (V {ops = (module Ops); channel; _}) =
+          Ops.close channel
+      end
+
+      type tcp_flow = TCP_channel.flow
+      type tls_flow = Tls_flow : {
+        ops: (module SOCKET_OPS with type t = 'a);
+        channel: 'a;
+      } -> tls_flow
+
+      let connect_tcp ~sw:_ ~stdenv:{stack; _} sockaddr =
+        (match sockaddr with
+         | `Unix _ ->
+            Lwt.return_error
+              (Caqti_error.Msg "Unix sockets are not available under MirageOS.")
+         | `Tcp (ipaddr, port) ->
+            TCP.create_connection (STACK.tcp stack) (ipaddr, port) >|=
+            (function
+             | Ok flow ->
+                let channel = TCP_channel.create flow in
+                Ok (Socket.V {
+                  tcp_flow = Some flow;
+                  ops = (module TCP_stream_ops);
+                  channel;
+                })
+             | Error err ->
+                let msg = Format.asprintf "%a" TCP.pp_error err in
+                Error (Caqti_error.Msg msg)))
+
+      let tcp_flow_of_socket (Socket.V {tcp_flow; _}) = tcp_flow
+
+      let socket_of_tls_flow ~sw:_ (Tls_flow {ops; channel}) =
+        Socket.V {tcp_flow = None; ops; channel}
+
+      module type TLS_PROVIDER = Caqti_platform.System_sig.TLS_PROVIDER
+        with type 'a fiber := 'a Lwt.t
+         and type tcp_flow := tcp_flow
+         and type tls_flow := tls_flow
+
+      module Tls_provider = struct
+        type tls_config = Tls.Config.client
+
+        let tls_config_key = Caqti_tls.Config.client
+
+        let start_tls ~config ?host flow =
+          TLS.client_of_flow config ?host flow >|=
+          (function
+           | Ok tls_flow ->
+              Ok (Tls_flow {
+                ops = (module TLS_stream_ops);
+                channel = TLS_channel.create tls_flow;
+              })
+           | Error err ->
+              let msg = Format.asprintf "%a" TLS.pp_write_error err in
+              Error (Caqti_error.Msg msg))
+      end
+
+      let tls_providers_r : (module TLS_PROVIDER) list ref =
+        ref [(module Tls_provider : TLS_PROVIDER)]
+
+      let tls_providers _ = !tls_providers_r
+
+      let register_tls_provider p = tls_providers_r := p :: !tls_providers_r
+
+    end
+  end
+
+  module Loader = Caqti_platform.Driver_loader.Make (System)
+
+  include Connector.Make (System) (Pool) (Loader)
+
+  let connect
+        ?subst ?env ?config ?tweaks_version ?(sw = Caqti_lwt.Switch.eternal)
+        stack dns uri =
+    connect ?subst ?env ?config ?tweaks_version ~sw ~stdenv:{stack; dns} uri
+
+  let with_connection ?subst ?env ?config ?tweaks_version stack dns uri f =
+    with_connection ?subst ?env ?config ?tweaks_version ~stdenv:{stack; dns} uri f
+
+  let connect_pool
+        ?pool_config ?post_connect ?subst ?env ?config ?tweaks_version
+        ?(sw = Caqti_lwt.Switch.eternal) stack dns uri =
+    connect_pool
+      ?pool_config ?post_connect ?subst ?env ?config ?tweaks_version
+      ~sw ~stdenv:{stack; dns} uri
+
+end

unikernel/duniverse/ocaml-caqti/caqti-mirage/lib/caqti_mirage.mli

@@ -0,0 +1,41 @@
+(* Copyright (C) 2022--2023  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+(** Functions for connecting to databases from MirageOS unikernels
+
+    This module contains functions for connecting to databases using the
+    MirageOS platform libraries, providing support for PGX but not drivers based
+    on bindings.
+
+    See also {!Caqti_lwt} for basic Lwt support.
+
+    {b The caqti-mirage library is experimental at this point.}  Feedback from
+    MirageOS users on the current API is very welcome. *)
+
+module Make :
+  functor (STACK : Tcpip.Stack.V4V6) ->
+  functor (DNS : Dns_client_mirage.S) ->
+sig
+  module Pool : Caqti_pool_sig.S with type 'a fiber := 'a Lwt.t
+  include Caqti_connect_sig.S
+    with type 'a fiber := 'a Lwt.t
+     and type ('a, 'e) stream := ('a, 'e) Caqti_lwt.Stream.t
+     and type ('a, 'e) pool := ('a, 'e) Pool.t
+     and type connection := Caqti_lwt.connection
+     and type 'a with_switch := ?sw: Caqti_lwt.Switch.t -> 'a
+     and type 'a with_stdenv := STACK.t -> DNS.t -> 'a
+end

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

@@ -0,0 +1,19 @@
+(library
+ (name caqti_mirage)
+ (public_name caqti-mirage)
+ (libraries
+    caqti
+    caqti.platform
+    caqti-lwt
+    caqti-tls
+    dns-client
+    dns-client-mirage
+    domain-name
+    ipaddr
+    logs
+    logs.lwt
+    lwt
+    mirage-channel
+    mirage-sleep
+    tcpip
+    tls-mirage))

unikernel/duniverse/ocaml-caqti/caqti-mirage/unikernel/README.md

@@ -0,0 +1,33 @@
+## Synopsis
+
+This directory provides a MirageOS Unikernel which performs a simple query
+against a PostgreSQL database using the PGX driver.
+
+## Building
+
+This directory is not integrated in the normal Caqti build.  A regular
+executable can be built with
+```console
+$ opam switch create . 4.14.0
+$ export OPAMSWITCH=./mirage
+$ eval `opam config env`
+$ opam install mirage
+$ mirage configure -t unix
+$ opam install --deps-only ./mirage
+$ mirage build
+```
+See `mirage configure --help` for other targets (`-t`).
+
+## Running
+
+You can start a throw-away PostgreSQL instance in a Docker container with
+```console
+$ docker run --rm -it -e POSTGRES_PASSWORD=KWRIsr6TPjBX -p 127.0.0.1:15432:5432 postgres:13
+```
+and in a parallel shell run
+```console
+$ _build/default/caqti-test-unikernel --database-uri pgx://postgres:KWRIsr6TPjBX@127.0.0.1:15432
+```
+Other targets may require a hypervisor and direct access to a network
+interface.  Documentation can be found on the [MirageOS
+site](https://mirage.io/).

unikernel/duniverse/ocaml-caqti/caqti-mirage/unikernel/config.ml

@@ -0,0 +1,108 @@
+(* Copyright (C) 2022--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Mirage
+
+let pin =
+  let rec locate_top p =
+    let p, b = Filename.(dirname p, basename p) in
+    assert (p <> "/");
+    if b = "caqti-mirage" then p else locate_top p
+  in
+  let p =
+    if Filename.is_relative Sys.argv.(0)
+    then Filename.concat (Sys.getcwd ()) Sys.argv.(0)
+    else Sys.argv.(0)
+  in
+  locate_top p
+
+let pin_version =
+  let release_notes_header =
+    let ic = open_in "../../CHANGES.md" in
+    Fun.protect ~finally:(fun () -> close_in ic) (fun () -> input_line ic)
+  in
+  (match String.split_on_char ' ' release_notes_header with
+   | ["##"; version; "-"; _] when String.starts_with ~prefix:"v" version ->
+      String.sub version 1 (String.length version - 1)
+   | _ -> failwith "Cannot extract version from CHANGES.md.")
+
+(*
+let pin_version_from_git =
+  let fh = Unix.open_process_in "git describe" in
+  let v = input_line fh in
+  (match Unix.close_process_in fh with
+   | Unix.WEXITED 0 ->
+      let n = String.length v in
+      assert (n > 1 && v.[0] = 'v');
+      String.sub v 1 (n - 1)
+   | _ -> failwith "git describe failed")
+*)
+
+let packages = [
+  package "caqti" ~pin ~pin_version;
+  package "caqti-driver-pgx" ~pin ~pin_version;
+  package "caqti-mirage" ~pin ~pin_version;
+  package "caqti-lwt" ~pin ~pin_version;
+  package "caqti-tls" ~pin ~pin_version;
+  package "dns-client-mirage";
+  package "logs";
+  package "mirage-crypto-rng-mirage";
+  package "mirage-clock-unix";
+  package "mirage-logs";
+]
+
+let stack = generic_stackv4v6 default_network
+
+let nameservers =
+  let doc = Key.Arg.info ~doc:"Nameserver." ["nameserver"] in
+  Key.(create "nameserver" Arg.(opt_all string doc))
+
+let database_uri =
+  let doc =
+    Key.Arg.info ~doc:"URI for connecting to the database."
+      ["u"; "database-uri"]
+  in
+  Key.(create "database-uri" Arg.(required string doc))
+
+let x509_authenticator =
+  let doc =
+    Key.Arg.info ~doc:"X509 authenticator." ["x509-authenticator"]
+  in
+  (* TODO: Would be good to invoke X509.Authenticator.of_string to check the
+   * argument here. How do we specify the x509 dependency? *)
+  Key.(create "x509_authenticator" Arg.(opt (some string) None doc))
+
+let keys = [
+  Key.v nameservers;
+  Key.v database_uri;
+  Key.v x509_authenticator;
+]
+
+let unikernel_functor =
+  foreign "Unikernel.Make" ~keys ~packages
+    (random @-> time @-> pclock @-> mclock @-> stackv4v6 @-> dns_client @-> job)
+
+let unikernel =
+  unikernel_functor
+    $ default_random
+    $ default_time
+    $ default_posix_clock
+    $ default_monotonic_clock
+    $ stack
+    $ generic_dns_client ~nameservers stack
+
+let () = register "caqti-test-unikernel" [unikernel]

unikernel/duniverse/ocaml-caqti/caqti-mirage/unikernel/unikernel.ml

@@ -0,0 +1,81 @@
+(* Copyright (C) 2022--2024  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+open Lwt.Infix
+open Lwt.Syntax
+let ( let/? ) = Result.bind
+let ( let*? ) = Lwt_result.Syntax.( let* )
+let ( let+? ) = Lwt_result.Syntax.( let+ )
+let ( % ) f g x = f (g x)
+
+let minus_req =
+  Caqti_template.Create.(t2 int int ->! int) "SELECT ? - ?"
+
+module Make
+  (RANDOM : Mirage_random.S)
+  (TIME : Mirage_time.S)
+  (PCLOCK : Mirage_clock.PCLOCK)
+  (MCLOCK : Mirage_clock.MCLOCK)
+  (STACK : Tcpip.Stack.V4V6)
+  (DNS : Dns_client_mirage.S) =
+struct
+  module Caqti_mirage_connect =
+    Caqti_mirage.Make (RANDOM) (TIME) (MCLOCK) (PCLOCK) (STACK) (DNS)
+  module Logs_reporter = Mirage_logs.Make (PCLOCK)
+  module Log = (val Logs_lwt.src_log (Logs.Src.create "main"))
+
+  let pclock_now_opt () = Some (Ptime.v (PCLOCK.now_d_ps ()))
+
+  let connect stack dns =
+    let*? config =
+      let set_authenticator arg cfg =
+        let/? authenticator = X509.Authenticator.of_string arg in
+        let authenticator = authenticator pclock_now_opt in
+        let tls_cfg = Tls.Config.client ~authenticator () in
+        let cfg =
+          Caqti_connect_config.set Caqti_tls.Config.client (Some tls_cfg) cfg
+        in
+        Ok cfg
+      in
+      Caqti_connect_config.default
+        |> Option.fold ~none:Result.ok ~some:set_authenticator
+            (Key_gen.x509_authenticator ())
+        |> Lwt.return
+    in
+    let* () = Log.info (fun f -> f "Connecting to the database.") in
+    let db_uri = Uri.of_string (Key_gen.database_uri ()) in
+    Caqti_mirage_connect.connect ~config stack dns db_uri
+
+  let test (module C : Caqti_lwt.CONNECTION) =
+    let+? res = C.find minus_req (22, 17) in
+    assert (res = 5)
+
+  let start _random _time _pclock _mclock stack dns =
+    Logs.(set_level (Some Info));
+    Logs.set_reporter (Logs_reporter.create ());
+    begin
+      let* () = Log.info (fun f -> f "Running tests.") in
+      let*? (module C) = connect stack dns in
+      let*? () = test (module C) in
+      let+ () = C.disconnect () in
+      Ok ()
+    end >>= function
+     | Ok () -> Log.info (fun f -> f "Done.")
+     | Error (`Msg msg) -> Log.err (fun f -> f "%s" msg)
+     | Error (#Caqti_error.t as err) ->
+        Log.err (fun f -> f "%a" Caqti_error.pp err)
+end