From 3aa77601a1741d2c86cea308ccf9105c3b0e7b35 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 29 Jun 2023 21:38:21 +0200 Subject: [PATCH] Update to latest mirage --- applications/dns/config.ml | 14 +++--------- applications/dns/unikernel.ml | 9 +++++++- applications/docteur/config.ml | 6 +----- applications/docteur/unikernel.ml | 8 ++++++- applications/git/config.ml | 20 ++++++----------- applications/git/unikernel.ml | 15 +++++++++++-- applications/http/config.ml | 19 +--------------- applications/http/unikernel.ml | 24 ++++++++++++++++++--- applications/static_website_tls/config.ml | 13 +---------- applications/static_website_tls/dispatch.ml | 15 +++++++++++-- device-usage/http-fetch/config.ml | 6 +----- device-usage/http-fetch/unikernel.ml | 8 ++++++- device-usage/network/config.ml | 10 +-------- device-usage/network/unikernel.ml | 11 +++++++++- device-usage/prng/unikernel.ml | 14 +----------- tutorial/hello-key/config.ml | 11 +--------- tutorial/hello-key/unikernel.ml | 8 ++++++- 17 files changed, 102 insertions(+), 109 deletions(-) diff --git a/applications/dns/config.ml b/applications/dns/config.ml index 510b6277..2b86cf7b 100644 --- a/applications/dns/config.ml +++ b/applications/dns/config.ml @@ -1,22 +1,14 @@ open Mirage -let domain_name = - let doc = Key.Arg.info ~doc:"The domain-name to resolve." [ "domain-name" ] in - Key.(create "domain-name" Arg.(required ~stage:`Run string doc)) - let nameservers = let doc = Key.Arg.info ~doc:"Nameserver." [ "nameserver" ] in - Key.(create "nameserver" Arg.(opt_all string doc)) + Key.(create "nameserver" Arg.(opt_all ~stage:`Run string doc)) let timeout = let doc = Key.Arg.info ~doc:"Timeout of DNS requests." [ "timeout" ] in - Key.(create "timeout" Arg.(opt (some int64) None doc)) - -let unikernel = - foreign "Unikernel.Make" - ~keys:[ Key.v domain_name; Key.v nameservers ] - (dns_client @-> job) + Key.(create "timeout" Arg.(opt ~stage:`Run (some int64) None doc)) +let unikernel = foreign "Unikernel.Make" (dns_client @-> job) let stackv4v6 = generic_stackv4v6 default_network let () = diff --git a/applications/dns/unikernel.ml b/applications/dns/unikernel.ml index 0a33379b..6ba5ae6e 100644 --- a/applications/dns/unikernel.ml +++ b/applications/dns/unikernel.ml @@ -1,7 +1,14 @@ +open Cmdliner + +let domain_name = + let doc = Arg.info ~doc:"The domain-name to resolve." [ "domain-name" ] in + let key = Arg.(required & opt (some string) None doc) in + Mirage_runtime.key key + module Make (DNS : Dns_client_mirage.S) = struct let start dns = let ( >>= ) = Result.bind in - match Domain_name.(of_string (Key_gen.domain_name ()) >>= host) with + match Domain_name.(of_string (domain_name ()) >>= host) with | Error (`Msg err) -> failwith err | Ok domain_name -> ( let open Lwt.Infix in diff --git a/applications/docteur/config.ml b/applications/docteur/config.ml index 50679a36..6e3760ab 100644 --- a/applications/docteur/config.ml +++ b/applications/docteur/config.ml @@ -1,10 +1,6 @@ open Mirage -let filename = - let doc = Key.Arg.info ~doc:"The filename to print out." [ "filename" ] in - Key.(create "filename" Arg.(required ~stage:`Run string doc)) - -let unikernel = foreign "Unikernel.Make" ~keys:[ Key.v filename ] (kv_ro @-> job) +let unikernel = foreign "Unikernel.Make" (kv_ro @-> job) let remote = "https://github.com/mirage/mirage" let () = diff --git a/applications/docteur/unikernel.ml b/applications/docteur/unikernel.ml index 31b48814..62f8c31d 100644 --- a/applications/docteur/unikernel.ml +++ b/applications/docteur/unikernel.ml @@ -1,10 +1,16 @@ open Lwt.Infix +open Cmdliner + +let filename = + let doc = Arg.info ~doc:"The filename to print out." [ "filename" ] in + let key = Arg.(required & opt (some string) None doc) in + Mirage_runtime.key key module Make (Store : Mirage_kv.RO) = struct module Key = Mirage_kv.Key let start store = - Store.get store (Key.v (Key_gen.filename ())) >|= function + Store.get store (Key.v (filename ())) >|= function | Error err -> Logs.err (fun m -> m "Error: %a." Store.pp_error err) | Ok str -> Logs.info (fun m -> m "%s" str) end diff --git a/applications/git/config.ml b/applications/git/config.ml index e3f3f019..931f35b9 100644 --- a/applications/git/config.ml +++ b/applications/git/config.ml @@ -34,44 +34,36 @@ let git_impl path = (* User space *) -let remote = - let doc = Key.Arg.info ~doc:"Remote Git repository." [ "r"; "remote" ] in - Key.(create "remote" Arg.(required ~stage:`Run string doc)) - let ssh_key = let doc = Key.Arg.info ~doc:"The private SSH key." [ "ssh-key" ] in - Key.(create "ssh_seed" Arg.(opt (some string) None doc)) + Key.(create "ssh_seed" Arg.(opt ~stage:`Run (some string) None doc)) let ssh_password = let doc = Key.Arg.info ~doc:"The private SSH password." [ "ssh-password" ] in - Key.(create "ssh_password" Arg.(opt (some string) None doc)) + Key.(create "ssh_password" Arg.(opt ~stage:`Run (some string) None doc)) let nameservers = let doc = Key.Arg.info ~doc:"DNS nameservers." [ "nameserver" ] in - Key.(create "nameservers" Arg.(opt_all string doc)) + Key.(create "nameservers" Arg.(opt_all ~stage:`Run string doc)) let ssh_authenticator = let doc = Key.Arg.info ~doc:"SSH public key of the remote Git repository." [ "ssh-authenticator" ] in - Key.(create "ssh_authenticator" Arg.(opt (some string) None doc)) + Key.(create "ssh_authenticator" Arg.(opt ~stage:`Run (some string) None doc)) let https_authenticator = let doc = Key.Arg.info ~doc:"SSH public key of the remote Git repository." [ "https-authenticator" ] in - Key.(create "https_authenticator" Arg.(opt (some string) None doc)) - -let branch = - let doc = Key.Arg.info ~doc:"The Git remote branch." [ "branch" ] in - Key.(create "branch" Arg.(opt ~stage:`Run string "refs/heads/master" doc)) + Key.( + create "https_authenticator" Arg.(opt ~stage:`Run (some string) None doc)) let minigit = foreign "Unikernel.Make" ~packages:[ package "ptime" ] - ~keys:[ Key.v remote; Key.v branch ] (git @-> git_client @-> job) let mimic stackv4v6 dns_client happy_eyeballs = diff --git a/applications/git/unikernel.ml b/applications/git/unikernel.ml index 56cd42e0..c8617fc3 100644 --- a/applications/git/unikernel.ml +++ b/applications/git/unikernel.ml @@ -1,9 +1,20 @@ +open Cmdliner open Lwt.Infix +let branch = + let doc = Arg.info ~doc:"The Git remote branch." [ "branch" ] in + let key = Arg.(value & opt string "refs/heads/master" doc) in + Mirage_runtime.key key + +let remote = + let doc = Arg.info ~doc:"Remote Git repository." [ "r"; "remote" ] in + let key = Arg.(required & opt (some string) None doc) in + Mirage_runtime.key key + module Make (Store : Git.S) (_ : sig end) = struct module Sync = Git.Mem.Sync (Store) - let main = lazy (Git.Reference.v (Key_gen.branch ())) + let main = lazy (Git.Reference.v (branch ())) let author () = { @@ -62,7 +73,7 @@ module Make (Store : Git.S) (_ : sig end) = struct let start git ctx = let edn = - match Smart_git.Endpoint.of_string (Key_gen.remote ()) with + match Smart_git.Endpoint.of_string (remote ()) with | Ok edn -> edn | Error (`Msg err) -> Fmt.failwith "%s" err in diff --git a/applications/http/config.ml b/applications/http/config.ml index 85c97026..7277314f 100644 --- a/applications/http/config.ml +++ b/applications/http/config.ml @@ -2,23 +2,7 @@ open Mirage let port = let doc = Key.Arg.info ~doc:"Port of HTTP service." [ "p"; "port" ] in - Key.(create "ports" Arg.(opt int 8080 doc)) - -let tls = - let doc = - Key.Arg.info ~doc:"Start an HTTP server with a TLS certificate." [ "tls" ] - in - Key.(create "tls" Arg.(flag ~stage:`Run doc)) - -let tls_port = - let doc = Key.Arg.info ~doc:"Port of HTTPS service." [ "tls-port" ] in - Key.(create "tls-port" Arg.(opt ~stage:`Run int 4343 doc)) - -let alpn = - let doc = - Key.Arg.info ~doc:"Protocols handled by the HTTP server." [ "alpn" ] - in - Key.(create "alpn" Arg.(opt ~stage:`Run (some string) None doc)) + Key.(create "ports" Arg.(opt ~stage:`Run int 8080 doc)) type conn = Connect @@ -34,7 +18,6 @@ let minipaf = package "rresult"; package "base64" ~sublibs:[ "rfc2045" ]; ] - ~keys:[ Key.v tls_port; Key.v tls; Key.v alpn ] (random @-> kv_ro @-> kv_ro @-> tcpv4v6 @-> conn @-> http_server @-> job) let conn = diff --git a/applications/http/unikernel.ml b/applications/http/unikernel.ml index 6379ae5d..6f89a0db 100644 --- a/applications/http/unikernel.ml +++ b/applications/http/unikernel.ml @@ -1,5 +1,23 @@ open Rresult open Lwt.Infix +open Cmdliner + +let use_tls = + let doc = + Arg.info ~doc:"Start an HTTP server with a TLS certificate." [ "tls" ] + in + let key = Arg.(value & flag doc) in + Mirage_runtime.key key + +let tls_port = + let doc = Arg.info ~doc:"Port of HTTPS service." [ "tls-port" ] in + let key = Arg.(value & opt int 4343 doc) in + Mirage_runtime.key key + +let alpn = + let doc = Arg.info ~doc:"Protocols handled by the HTTP server." [ "alpn" ] in + let key = Arg.(value & opt (some string) None doc) in + Mirage_runtime.key key let ( <.> ) f g x = f (g x) let always x _ = x @@ -120,19 +138,19 @@ struct let open Lwt.Infix in let authenticator = Connect.authenticator in tls key_ro certificate_ro >>= fun tls -> - match (Key_gen.tls (), tls, Key_gen.alpn ()) with + match (use_tls (), tls, alpn ()) with | true, Ok certificates, None -> run_with_tls ~ctx ~authenticator ~tls: (Tls.Config.server ~certificates ~alpn_protocols:[ "h2"; "http/1.1" ] ()) - http_server (Key_gen.tls_port ()) tcpv4v6 + http_server (tls_port ()) tcpv4v6 | true, Ok certificates, Some (("http/1.1" | "h2") as alpn_protocol) -> run_with_tls ~ctx ~authenticator ~tls: (Tls.Config.server ~certificates ~alpn_protocols:[ alpn_protocol ] ()) - http_server (Key_gen.tls_port ()) tcpv4v6 + http_server (tls_port ()) tcpv4v6 | false, _, _ -> run ~ctx ~authenticator http_server | _, _, Some protocol -> Fmt.failwith "Invalid protocol %S" protocol | true, Error _, _ -> diff --git a/applications/static_website_tls/config.ml b/applications/static_website_tls/config.ml index 510822e3..efd661e7 100644 --- a/applications/static_website_tls/config.ml +++ b/applications/static_website_tls/config.ml @@ -6,26 +6,15 @@ let data = generic_kv_ro ~key:data_key "htdocs" (* set ~tls to false to get a plain-http server *) let https_srv = cohttp_server @@ conduit_direct ~tls:true stack - -let http_port = - let doc = Key.Arg.info ~doc:"Listening HTTP port." [ "http" ] in - Key.(create "http_port" Arg.(opt ~stage:`Run int 8080 doc)) - let certs_key = Key.(value @@ kv_ro ~group:"certs" ()) (* some default CAs and self-signed certificates are included in the tls/ directory, but you can replace them with your own. *) let certs = generic_kv_ro ~key:certs_key "tls" -let https_port = - let doc = Key.Arg.info ~doc:"Listening HTTPS port." [ "https" ] in - Key.(create "https_port" Arg.(opt ~stage:`Run int 4433 doc)) - let main = let packages = [ package "uri"; package "magic-mime" ] in - let keys = List.map key [ http_port; https_port ] in - main ~packages ~keys "Dispatch.HTTPS" - (pclock @-> kv_ro @-> kv_ro @-> http @-> job) + main ~packages "Dispatch.HTTPS" (pclock @-> kv_ro @-> kv_ro @-> http @-> job) let () = register "https" [ main $ default_posix_clock $ data $ certs $ https_srv ] diff --git a/applications/static_website_tls/dispatch.ml b/applications/static_website_tls/dispatch.ml index 88dddfb1..5cff902d 100644 --- a/applications/static_website_tls/dispatch.ml +++ b/applications/static_website_tls/dispatch.ml @@ -1,4 +1,15 @@ open Lwt.Infix +open Cmdliner + +let http_port = + let doc = Arg.info ~doc:"Listening HTTP port." [ "http" ] in + let key = Arg.(value & opt int 8080 doc) in + Mirage_runtime.key key + +let https_port = + let doc = Arg.info ~doc:"Listening HTTPS port." [ "https" ] in + let key = Arg.(value & opt int 4433 doc) in + Mirage_runtime.key key module type HTTP = Cohttp_mirage.Server.S (** Common signature for http and https. *) @@ -72,9 +83,9 @@ struct let start _clock data keys http = tls_init keys >>= fun cfg -> - let https_port = Key_gen.https_port () in + let https_port = https_port () in let tls = `TLS (cfg, `TCP https_port) in - let http_port = Key_gen.http_port () in + let http_port = http_port () in let tcp = `TCP http_port in let https = Https_log.info (fun f -> f "listening on %d/TCP" https_port); diff --git a/device-usage/http-fetch/config.ml b/device-usage/http-fetch/config.ml index 8ae183c1..7df4ba12 100644 --- a/device-usage/http-fetch/config.ml +++ b/device-usage/http-fetch/config.ml @@ -1,12 +1,8 @@ open Mirage -let uri = - let doc = Key.Arg.info ~doc:"URL to fetch" [ "uri" ] in - Key.(create "uri" Arg.(opt ~stage:`Run string "https://mirage.io" doc)) - let client = let packages = [ package "cohttp-mirage"; package "duration" ] in - main ~keys:[ key uri ] ~packages "Unikernel.Client" @@ http_client @-> job + main ~packages "Unikernel.Client" @@ http_client @-> job let () = let stack = generic_stackv4v6 default_network in diff --git a/device-usage/http-fetch/unikernel.ml b/device-usage/http-fetch/unikernel.ml index 1d1f01db..2a47c492 100644 --- a/device-usage/http-fetch/unikernel.ml +++ b/device-usage/http-fetch/unikernel.ml @@ -1,5 +1,11 @@ open Lwt.Infix open Printf +open Cmdliner + +let uri = + let doc = Arg.info ~doc:"URL to fetch" [ "uri" ] in + let key = Arg.(value & opt string "https://mirage.io" doc) in + Mirage_runtime.key key let red fmt = sprintf ("\027[31m" ^^ fmt ^^ "\027[m") let green fmt = sprintf ("\027[32m" ^^ fmt ^^ "\027[m") @@ -16,6 +22,6 @@ module Client (Client : Cohttp_lwt.S.Client) = struct Fmt.pr "Cohttp fetch done\n------------\n" let start ctx = - let uri = Uri.of_string (Key_gen.uri ()) in + let uri = Uri.of_string (uri ()) in http_fetch ctx uri end diff --git a/device-usage/network/config.ml b/device-usage/network/config.ml index 4d0b5890..4aaba5d7 100644 --- a/device-usage/network/config.ml +++ b/device-usage/network/config.ml @@ -1,13 +1,5 @@ open Mirage -let port = - let doc = - Key.Arg.info - ~doc:"The TCP port on which to listen for incoming connections." - [ "port" ] - in - Key.(create "port" Arg.(opt ~stage:`Run int 8080 doc)) - -let main = main ~keys:[ key port ] "Unikernel.Main" (stackv4v6 @-> job) +let main = main "Unikernel.Main" (stackv4v6 @-> job) let stack = generic_stackv4v6 default_network let () = register "network" [ main $ stack ] diff --git a/device-usage/network/unikernel.ml b/device-usage/network/unikernel.ml index 67b67b99..b766b211 100644 --- a/device-usage/network/unikernel.ml +++ b/device-usage/network/unikernel.ml @@ -1,8 +1,17 @@ open Lwt.Infix +open Cmdliner + +let port = + let doc = + Arg.info ~doc:"The TCP port on which to listen for incoming connections." + [ "port" ] + in + let key = Arg.(value & opt int 8080 doc) in + Mirage_runtime.key key module Main (S : Tcpip.Stack.V4V6) = struct let start s = - let port = Key_gen.port () in + let port = port () in S.TCP.listen (S.tcp s) ~port (fun flow -> let dst, dst_port = S.TCP.dst flow in Logs.info (fun f -> diff --git a/device-usage/prng/unikernel.ml b/device-usage/prng/unikernel.ml index 5d9a77d0..26d8ced4 100644 --- a/device-usage/prng/unikernel.ml +++ b/device-usage/prng/unikernel.ml @@ -1,20 +1,8 @@ module Main (R : Mirage_random.S) = struct - let t_to_str = function - | `Unix -> "unix" - | `Xen -> "xen" - | `Muen -> "muen" - | `Qubes -> "qubes" - | `MacOSX -> "macosx" - | `Virtio -> "virtio" - | `Hvt -> "hvt" - | `Spt -> "spt" - let generate i = R.generate i let start _r = - let t = Key_gen.target () in - Logs.info (fun m -> - m "PRNG example running on %s (target %s)" Sys.os_type (t_to_str t)); + Logs.info (fun m -> m "PRNG example running on %s" Sys.os_type); Logs.info (fun m -> m "using Fortuna, entropy sources: %a" Fmt.(list ~sep:(any ", ") Mirage_crypto_rng.Entropy.pp_source) diff --git a/tutorial/hello-key/config.ml b/tutorial/hello-key/config.ml index 07729746..c053440c 100644 --- a/tutorial/hello-key/config.ml +++ b/tutorial/hello-key/config.ml @@ -1,13 +1,4 @@ open Mirage -let hello = - let doc = Key.Arg.info ~doc:"How to say hello." [ "hello" ] in - Key.(create "hello" Arg.(opt ~stage:`Run string "Hello World!" doc)) - -let main = - main - ~keys:[ key hello ] - ~packages:[ package "duration" ] - "Unikernel.Hello" (time @-> job) - +let main = main ~packages:[ package "duration" ] "Unikernel.Hello" (time @-> job) let () = register "hello-key" [ main $ default_time ] diff --git a/tutorial/hello-key/unikernel.ml b/tutorial/hello-key/unikernel.ml index 48232798..e88c121c 100644 --- a/tutorial/hello-key/unikernel.ml +++ b/tutorial/hello-key/unikernel.ml @@ -1,8 +1,14 @@ open Lwt.Infix +open Cmdliner + +let hello = + let doc = Arg.info ~doc:"How to say hello." [ "hello" ] in + let key = Arg.(value & opt string "Hello World!" doc) in + Mirage_runtime.key key module Hello (Time : Mirage_time.S) = struct let start _time = - let hello = Key_gen.hello () in + let hello = hello () in let rec loop = function | 0 -> Lwt.return_unit