From f7c1d7e77c2b9a493af2312c686c40b85972ff27 Mon Sep 17 00:00:00 2001 From: swrup Date: Sat, 8 Nov 2025 01:38:06 +0100 Subject: [PATCH] --- Makefile | 2 +- README.md | 12 ++-- dune-project | 2 +- dune-workspace | 2 +- unikernel/config.ml | 21 +++---- unikernel/dune | 2 +- unikernel/unikernel.ml | 122 +++++++++++++++++++++++++---------------- 7 files changed, 95 insertions(+), 68 deletions(-) diff --git a/Makefile b/Makefile index ce35131d..31b40978 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# Generated by mirage.v4.10.1 +# Generated by mirage.v4.10.3 -include Makefile.user BUILD_DIR = unikernel/ diff --git a/README.md b/README.md index bd1cb864..bec602b1 100644 --- a/README.md +++ b/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" diff --git a/dune-project b/dune-project index d020ffa9..e06b4ae5 100644 --- a/dune-project +++ b/dune-project @@ -4,4 +4,4 @@ (implicit_transitive_deps true) -;; Generated by mirage.v4.10.1 +;; Generated by mirage.v4.10.3 diff --git a/dune-workspace b/dune-workspace index 743ecfad..9f714f25 100644 --- a/dune-workspace +++ b/dune-workspace @@ -2,4 +2,4 @@ (context (default)) -;; Generated by mirage.v4.10.1 +;; Generated by mirage.v4.10.3 diff --git a/unikernel/config.ml b/unikernel/config.ml index 89f8783b..d2ce2cb2 100644 --- a/unikernel/config.ml +++ b/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; ] diff --git a/unikernel/dune b/unikernel/dune index acdbca06..d336b137 100644 --- a/unikernel/dune +++ b/unikernel/dune @@ -1,3 +1,3 @@ -;; Generated by mirage.v4.10.1 +;; Generated by mirage.v4.10.3 (include dune.build) diff --git a/unikernel/unikernel.ml b/unikernel/unikernel.ml index 806afba7..8aa0a626 100644 --- a/unikernel/unikernel.ml +++ b/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://:@:/ *) + 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