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