Makefile

@@ -1,4 +1,4 @@
-# Generated by mirage.v4.10.1
+# Generated by mirage.v4.10.3
 
 -include Makefile.user
 BUILD_DIR = unikernel/

README.md

@@ -2,15 +2,11 @@
 
 
 build steps:
+-> todo pin caqti
 
-$ mirage configure -f unikernel/config.ml -t unix
-$ gen_tls.sh foo
-$ make
+gen_tls.sh foo
+
+mirage configure -f unikernel/config.ml -t unix && make
 
 run:
 ./unikernel/dist/mte --pg-database taler-exchange --pg-port 5432 --pg-hostname localhost --pg-user mte --pg-password xxx
-
-todo
-  - make a .opam file
-  - pin pgx to:
-    "git+https://github.com/pgx-ocaml/pgx.git#57c39ad93b712b4a9c1914be0c99172e050bc8e9"

dune-project

@@ -4,4 +4,4 @@
 
 (implicit_transitive_deps true)
 
-;; Generated by mirage.v4.10.1
+;; Generated by mirage.v4.10.3

dune-workspace

@@ -2,4 +2,4 @@
 
 (context (default))
 
-;; Generated by mirage.v4.10.1
+;; Generated by mirage.v4.10.3

unikernel/config.ml

@@ -4,11 +4,14 @@ let pgx_setup = runtime_arg ~pos:__POS__ "Unikernel.pgx_setup"
 
 let packages =
   [
-    package "digestif"; package ~min:"0.0.9" "mimic-happy-eyeballs";
-    package "hxd" ~sublibs:[ "core"; "string" ]; package "rresult";
-    package ~min:"0.13.0" "h2"; package ~min:"10.0.0" "dns-client";
-    package "pgx"; package "pgx_lwt"; package "pgx_lwt_mirage"; package "logs";
-    package "mirage-logs"; package "conduit"; package "duration";
+    package ~min:"0.0.9" "mimic-happy-eyeballs"; package ~min:"0.13.0" "h2";
+    package "logs"; package "mirage-logs";
+  ]
+  @
+  (* TODO pin caqti *)
+  [
+    package "caqti"; package "caqti-tls"; package "caqti-driver-pgx";
+    package "caqti-mirage"; package "caqti-lwt"; package "dns-client-mirage";
   ]
 
 let mte =
@@ -20,14 +23,13 @@ let mte =
     @-> tcpv4v6
     @-> http_server
     @-> stackv4v6
-    @-> happy_eyeballs
+    @-> dns_client
     @-> job)
 
 let stackv4v6 = generic_stackv4v6 default_network
 let tcpv4v6 = tcpv4v6_of_stackv4v6 stackv4v6
 let happy_eyeballs = generic_happy_eyeballs stackv4v6
-
-(*let dns = generic_dns_client stackv4v6 happy_eyeballs*)
+let dns = generic_dns_client stackv4v6 happy_eyeballs
 let certificates = crunch "../data/tls/certificates"
 let keys = crunch "../data/tls/keys"
 let assets = crunch "../data/assets"
@@ -43,7 +45,6 @@ let () =
       $ keys
       $ tcpv4v6
       $ http_server
-      (* TODO maybe we can avoid to repeat the stack? *)
       $ stackv4v6
-      $ happy_eyeballs;
+      $ dns;
     ]

unikernel/dune

@@ -1,3 +1,3 @@
-;; Generated by mirage.v4.10.1
+;; Generated by mirage.v4.10.3
 
 (include dune.build)

unikernel/unikernel.ml

@@ -1,4 +1,3 @@
-open Rresult
 open Cmdliner
 open Syntax
 
@@ -71,25 +70,34 @@ module Make
     (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t)
     (HTTP_server : Paf_mirage.S)
     (STACK : Tcpip.Stack.V4V6)
-    (Happy_eyeballs :
-      Happy_eyeballs_mirage.S
-        with type stack = STACK.t
-         and type flow = STACK.TCP.flow) =
+    (DNS : Dns_client_mirage.S) =
 struct
-  module Pgx_mirage = Pgx_lwt_mirage.Make (STACK) (Happy_eyeballs)
+  module Caqti_mirage_connect = Caqti_mirage.Make (STACK) (DNS)
 
   let map_err_to_string pp_err res =
-    Lwt.map (R.reword_error (R.msgf "%a" pp_err)) res
+    Lwt.map
+      (function Ok v -> Ok v | Error e -> Fmt.error_msg "%a" pp_err e)
+      res
+
+  let map_caqti_err_to_string res =
+    Lwt.map
+      (function
+        | Error (`Msg _) as err -> err
+        | Error (#Caqti_error.t as err) -> Fmt.error_msg "%a" Caqti_error.pp err
+        | Ok v -> Ok v)
+      res
 
   module Assets = struct
-    let map_err_to_string = map_err_to_string Assets_ro.pp_error
-
     let get_subdirs ro k =
-      let+? keys = Assets_ro.list ro k |> map_err_to_string in
+      let+? keys =
+        Assets_ro.list ro k |> map_err_to_string Assets_ro.pp_error
+      in
       List.filter (fun (_, t) -> t = `Dictionary) keys |> List.map fst
 
     let get_values ro k =
-      let+? keys = Assets_ro.list ro k |> map_err_to_string in
+      let+? keys =
+        Assets_ro.list ro k |> map_err_to_string Assets_ro.pp_error
+      in
       List.filter (fun (_, t) -> t = `Value) keys |> List.map fst
 
     let find keys name =
@@ -276,44 +284,66 @@ struct
     let (`Initialized th) = Paf.serve http_1_1_service http_server in
     th
 
-  let start assets_ro certificate_ro key_ro tcpv4v6 http_server stack
-      happy_eyeballs pgx_setup =
+  let connect stack dns
+      { pgx_database; pgx_port; pgx_hostname; pgx_user; pgx_password } =
+    Logs.info (fun m -> m "Connecting to the database.");
+    (* uri format:
+       pgx://<user>:<password>@<host-or-directory>:<port>/<database> *)
+    let db_uri =
+      Uri.of_string
+      @@ Fmt.str "pgx://%s:%s@%s:%d/%s" pgx_user pgx_password pgx_hostname
+           pgx_port pgx_database
+    in
+    Caqti_mirage_connect.connect stack dns db_uri
+
+  let test (module C : Caqti_lwt.CONNECTION) =
+    let minus_req =
+      let open Caqti_request.Infix in
+      (Caqti_type.(t2 int int) ->! Caqti_type.int) "SELECT ? - ?"
+    in
+    let+? res = C.find minus_req (22, 17) in
+    assert (res = 5)
+
+  let start assets_ro certificate_ro key_ro tcpv4v6 http_server stack dns
+      pgx_setup =
     Logs.set_reporter (Logs_fmt.reporter ());
     Logs.(set_level (Some Info));
     let open Lwt.Syntax in
-    let pgx = Pgx_mirage.connect (stack, happy_eyeballs) in
-    let module Pgx = (val pgx : Pgx_lwt.S) in
-    let { pgx_database; pgx_port; pgx_hostname; pgx_user; pgx_password } =
-      pgx_setup
+    let* caqti_res =
+      Logs.info (fun m -> m "Running caqti test.");
+      (* todo caqti: use Caqti_mirage_connect.with_connection ? *)
+      let*? (module C) =
+        connect stack dns pgx_setup |> map_caqti_err_to_string
+      in
+      let*? () = test (module C) |> map_caqti_err_to_string in
+      let+ () = C.disconnect () in
+      Ok ()
     in
-    Pgx.with_conn ~user:pgx_user ~host:pgx_hostname ~password:pgx_password
-      ~port:pgx_port ~database:pgx_database
-    @@ fun pgx_conn ->
-    let* () =
-      let+ alive = Pgx.alive pgx_conn in
-      match alive with
-      | false -> Fmt.failwith "Pgx connection failure: connection not alive"
-      | true -> Logs.info (fun m -> m "Pgx connection success")
-    in
-    let* assets_res = Assets.assets assets_ro in
-    match assets_res with
-    | Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
-    | Ok (_terms_etag, _privacy_etag, _lang_l, _ext_l) -> (
-        let* tls_res = tls certificate_ro key_ro in
-        match use_tls () with
-        | false -> run http_server
-        | true -> (
-            match tls_res with
-            | Error (`Msg m) ->
-                Fmt.failwith
-                  "A TLS server requires, at least, one certificate and one \
-                   private key. Received error %s."
-                  m
-            | Ok certificates -> (
-                let alpn_protocols = alpn () in
-                match Tls.Config.server ~certificates ~alpn_protocols () with
+    match caqti_res with
+    | Error (`Msg msg) -> Fmt.failwith "Caqti failure: %s." msg
+    | Ok () -> (
+        Logs.info (fun m -> m "Caqti test done.");
+        let* assets_res = Assets.assets assets_ro in
+        match assets_res with
+        | Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
+        | Ok (_terms_etag, _privacy_etag, _lang_l, _ext_l) -> (
+            let* tls_res = tls certificate_ro key_ro in
+            match use_tls () with
+            | false -> run http_server
+            | true -> (
+                match tls_res with
                 | Error (`Msg m) ->
-                    Fmt.failwith "TLS configuration error: %s." m
-                | Ok tls -> run_with_tls ~tls http_server (tls_port ()) tcpv4v6)
-            ))
+                    Fmt.failwith
+                      "A TLS server requires, at least, one certificate and \
+                       one private key. Received error %s."
+                      m
+                | Ok certificates -> (
+                    let alpn_protocols = alpn () in
+                    match
+                      Tls.Config.server ~certificates ~alpn_protocols ()
+                    with
+                    | Error (`Msg m) ->
+                        Fmt.failwith "TLS configuration error: %s." m
+                    | Ok tls ->
+                        run_with_tls ~tls http_server (tls_port ()) tcpv4v6))))
 end