pgx

Makefile

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

README.md

@@ -7,4 +7,10 @@ $ mirage configure -f unikernel/config.ml -t unix
 $ gen_tls.sh foo
 $ 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.3
+;; Generated by mirage.v4.10.1

dune-workspace

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

unikernel/config.ml

@@ -1,20 +1,33 @@
-(* mirage >= 4.9.0 & < 4.11.0 *)
 open Mirage
 
+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";
+  ]
+
 let mte =
-  main "Unikernel.Make" ~local_libs:[ "mte" ]
-    ~packages:
-      [
-        package "digestif"; package ~min:"0.0.9" "mimic-happy-eyeballs";
-        package "hxd" ~sublibs:[ "core"; "string" ]; package "rresult";
-        package "h2" ~min:"0.13.0"; package "base64" ~sublibs:[ "rfc2045" ];
-      ]
-    (kv_ro @-> kv_ro @-> kv_ro @-> tcpv4v6 @-> http_server @-> job)
+  main "Unikernel.Make" ~local_libs:[ "mte" ] ~packages
+    ~runtime_args:[ pgx_setup ]
+    (kv_ro
+    @-> kv_ro
+    @-> kv_ro
+    @-> tcpv4v6
+    @-> http_server
+    @-> stackv4v6
+    @-> happy_eyeballs
+    @-> job)
 
 let stackv4v6 = generic_stackv4v6 default_network
 let tcpv4v6 = tcpv4v6_of_stackv4v6 stackv4v6
-let he = generic_happy_eyeballs stackv4v6
-let dns = generic_dns_client stackv4v6 he
+let happy_eyeballs = generic_happy_eyeballs stackv4v6
+
+(*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"
@@ -22,4 +35,15 @@ let port = Runtime_arg.create ~pos:__POS__ "Unikernel.port"
 let http_server = paf_server ~port tcpv4v6
 
 let () =
-  register "mte" [ mte $ assets $ certificates $ keys $ tcpv4v6 $ http_server ]
+  register "mte"
+    [
+      mte
+      $ assets
+      $ certificates
+      $ keys
+      $ tcpv4v6
+      $ http_server
+      (* TODO maybe we can avoid to repeat the stack? *)
+      $ stackv4v6
+      $ happy_eyeballs;
+    ]

unikernel/dune

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

unikernel/server.ml

@@ -1,4 +1,4 @@
-let src = Logs.Src.create "server"
+let src = Logs.Src.create "unikernel server"
 
 module Log = (val Logs.src_log src : Logs.LOG)
 module Method = Mte.Method

unikernel/unikernel.ml

@@ -26,13 +26,58 @@ let alpn =
   Mirage_runtime.register_arg
     Arg.(value & opt_all (enum (List.map (fun v -> (v, v)) alpns)) alpns doc)
 
+let pgx_database =
+  let doc = Arg.info ~doc:"database to use" [ "pg-database" ] in
+  Arg.(value & opt string "postgres" doc)
+
+let pgx_port =
+  let doc = Arg.info ~doc:"port to use for postgresql" [ "pg-port" ] in
+  Arg.(value & opt int 5432 doc)
+
+let pgx_hostname =
+  let doc = Arg.info ~doc:"host for postgres database" [ "pg-hostname" ] in
+  Arg.(required & opt (some string) None doc)
+
+let pgx_user =
+  let doc = Arg.info ~doc:"postgres user" [ "pg-user" ] in
+  Arg.(required & opt (some string) None doc)
+
+let pgx_password =
+  let doc = Arg.info ~doc:"postgres password" [ "pg-password" ] in
+  Arg.(required & opt (some string) None doc)
+
+type t = {
+  pgx_database: string;
+  pgx_port: int;
+  pgx_hostname: string;
+  pgx_user: string;
+  pgx_password: string;
+}
+
+let pgx_setup =
+  Term.(
+    const (fun pgx_database pgx_port pgx_hostname pgx_user pgx_password ->
+        { pgx_database; pgx_port; pgx_hostname; pgx_user; pgx_password })
+    $ pgx_database
+    $ pgx_port
+    $ pgx_hostname
+    $ pgx_user
+    $ pgx_password)
+
 module Make
     (Assets_ro : Mirage_kv.RO)
     (Certificates_ro : Mirage_kv.RO)
     (Keys_ro : Mirage_kv.RO)
     (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t)
-    (HTTP_server : Paf_mirage.S) =
+    (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) =
 struct
+  module Pgx_mirage = Pgx_lwt_mirage.Make (STACK) (Happy_eyeballs)
+
   let map_err_to_string pp_err res =
     Lwt.map (R.reword_error (R.msgf "%a" pp_err)) res
 
@@ -67,7 +112,7 @@ struct
       in
       Lwt.return
       @@
-      let open Result.Syntax in
+      let ( let* ) = Result.bind in
       let* l =
         list_get_ok
         @@ List.map
@@ -127,7 +172,7 @@ struct
       let*? privacy_etag, privacy_lang_l, privacy_ext_l = get ro "privacy" in
       Lwt.return
       @@
-      let open Result.Syntax in
+      let ( let* ) = Result.bind in
       let* lang_l =
         match terms_lang_l = privacy_lang_l with
         | false ->
@@ -231,8 +276,25 @@ 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 =
+  let start assets_ro certificate_ro key_ro tcpv4v6 http_server stack
+      happy_eyeballs 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
+    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