diff --git a/Makefile b/Makefile index 31b40978..ce35131d 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# Generated by mirage.v4.10.3 +# Generated by mirage.v4.10.1 -include Makefile.user BUILD_DIR = unikernel/ diff --git a/README.md b/README.md index d84f96b2..bd1cb864 100644 --- a/README.md +++ b/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" diff --git a/dune-project b/dune-project index e06b4ae5..d020ffa9 100644 --- a/dune-project +++ b/dune-project @@ -4,4 +4,4 @@ (implicit_transitive_deps true) -;; Generated by mirage.v4.10.3 +;; Generated by mirage.v4.10.1 diff --git a/dune-workspace b/dune-workspace index 9f714f25..743ecfad 100644 --- a/dune-workspace +++ b/dune-workspace @@ -2,4 +2,4 @@ (context (default)) -;; Generated by mirage.v4.10.3 +;; Generated by mirage.v4.10.1 diff --git a/unikernel/config.ml b/unikernel/config.ml index 5051bfcb..89f8783b 100644 --- a/unikernel/config.ml +++ b/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; + ] diff --git a/unikernel/dune b/unikernel/dune index d336b137..acdbca06 100644 --- a/unikernel/dune +++ b/unikernel/dune @@ -1,3 +1,3 @@ -;; Generated by mirage.v4.10.3 +;; Generated by mirage.v4.10.1 (include dune.build) diff --git a/unikernel/server.ml b/unikernel/server.ml index 874cc8ec..0ce5576f 100644 --- a/unikernel/server.ml +++ b/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 diff --git a/unikernel/unikernel.ml b/unikernel/unikernel.ml index 853896e9..806afba7 100644 --- a/unikernel/unikernel.ml +++ b/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