From 8c3b45ed237709126bb5f684a8fa4ad7be6910f9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 20 Jan 2025 12:17:11 +0100 Subject: [PATCH 1/4] tutorial defunctorised --- Makefile | 2 +- tutorial/app_info/config.ml | 7 ++--- tutorial/app_info/unikernel.ml | 10 +++----- tutorial/hello-key/config.ml | 4 +-- tutorial/hello-key/unikernel.ml | 19 +++++++------- tutorial/hello/config.ml | 4 +-- tutorial/hello/unikernel.ml | 19 +++++++------- tutorial/lwt/echo_server/config.ml | 4 +-- tutorial/lwt/echo_server/unikernel.ml | 30 ++++++++++------------ tutorial/lwt/heads1/config.ml | 4 +-- tutorial/lwt/heads1/unikernel.ml | 20 +++++++-------- tutorial/lwt/heads2/config.ml | 5 ++-- tutorial/lwt/heads2/unikernel.ml | 22 ++++++++-------- tutorial/lwt/timeout1/config.ml | 7 ++--- tutorial/lwt/timeout1/unikernel.ml | 37 ++++++++++++--------------- tutorial/lwt/timeout2/config.ml | 7 ++--- tutorial/lwt/timeout2/unikernel.ml | 27 +++++++++---------- 17 files changed, 108 insertions(+), 120 deletions(-) diff --git a/Makefile b/Makefile index 63e47b4b..255dd549 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ BASE_TESTS = \ tutorial/lwt/timeout1 \ tutorial/lwt/timeout2 \ tutorial/lwt/echo_server \ - tutorial/app_info \ + tutorial/app_info #\ device-usage/clock \ device-usage/conduit_server \ device-usage/http-fetch \ diff --git a/tutorial/app_info/config.ml b/tutorial/app_info/config.ml index d730a23c..c9210d97 100644 --- a/tutorial/app_info/config.ml +++ b/tutorial/app_info/config.ml @@ -2,8 +2,9 @@ open Mirage let main = - main "Unikernel.Main" + main "Unikernel" + ~deps:[ dep noop ] ~packages:[ package "fmt"; package "dune-build-info" ] - (job @-> job) + job -let () = register "app-info" [ main $ noop ] +let () = register "app-info" [ main ] diff --git a/tutorial/app_info/unikernel.ml b/tutorial/app_info/unikernel.ml index 7018bd85..2a11b76a 100644 --- a/tutorial/app_info/unikernel.ml +++ b/tutorial/app_info/unikernel.ml @@ -16,9 +16,7 @@ let libraries = let pp_library ppf (name, version) = Fmt.pf ppf "%s.%s" name version -module Main (_ : sig end) = struct - let start () = - Fmt.pr "libraries:\n"; - List.iter (Fmt.pr " - %a\n" pp_library) libraries; - Lwt.return_unit -end +let start () = + Fmt.pr "libraries:\n"; + List.iter (Fmt.pr " - %a\n" pp_library) libraries; + Lwt.return_unit diff --git a/tutorial/hello-key/config.ml b/tutorial/hello-key/config.ml index 13006446..713e2d50 100644 --- a/tutorial/hello-key/config.ml +++ b/tutorial/hello-key/config.ml @@ -2,5 +2,5 @@ open Mirage let packages = [ package "duration" ] -let main = main ~packages "Unikernel.Hello" (time @-> job) -let () = register "hello-key" [ main $ default_time ] +let main = main ~packages "Unikernel" ~deps:[ dep noop ] job +let () = register "hello-key" [ main ] diff --git a/tutorial/hello-key/unikernel.ml b/tutorial/hello-key/unikernel.ml index fbc76b3e..90486bde 100644 --- a/tutorial/hello-key/unikernel.ml +++ b/tutorial/hello-key/unikernel.ml @@ -5,13 +5,12 @@ let hello = let doc = Arg.info ~doc:"How to say hello." [ "hello" ] in Mirage_runtime.register_arg Arg.(value & opt string "Hello World!" doc) -module Hello (Time : Mirage_time.S) = struct - let start _time = - let rec loop = function - | 0 -> Lwt.return_unit - | n -> - Logs.info (fun f -> f "%s" (hello ())); - Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop (n - 1) - in - loop 4 -end +let start () = + let rec loop = function + | 0 -> Lwt.return_unit + | n -> + Logs.info (fun f -> f "%s" (hello ())); + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> + loop (n - 1) + in + loop 4 diff --git a/tutorial/hello/config.ml b/tutorial/hello/config.ml index 7a771afe..f123b111 100644 --- a/tutorial/hello/config.ml +++ b/tutorial/hello/config.ml @@ -2,6 +2,6 @@ open Mirage let main = - main "Unikernel.Hello" (time @-> job) ~packages:[ package "duration" ] + main "Unikernel" job ~deps:[ dep noop ] ~packages:[ package "duration" ] -let () = register "hello" [ main $ default_time ] +let () = register "hello" [ main ] diff --git a/tutorial/hello/unikernel.ml b/tutorial/hello/unikernel.ml index cb9d8848..33b3ccf0 100644 --- a/tutorial/hello/unikernel.ml +++ b/tutorial/hello/unikernel.ml @@ -1,12 +1,11 @@ open Lwt.Infix -module Hello (Time : Mirage_time.S) = struct - let start _time = - let rec loop = function - | 0 -> Lwt.return_unit - | n -> - Logs.info (fun f -> f "hello"); - Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop (n - 1) - in - loop 4 -end +let start () = + let rec loop = function + | 0 -> Lwt.return_unit + | n -> + Logs.info (fun f -> f "hello"); + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> + loop (n - 1) + in + loop 4 diff --git a/tutorial/lwt/echo_server/config.ml b/tutorial/lwt/echo_server/config.ml index b9a553c0..ed83bf6b 100644 --- a/tutorial/lwt/echo_server/config.ml +++ b/tutorial/lwt/echo_server/config.ml @@ -3,6 +3,6 @@ open Mirage let main = let packages = [ package "duration"; package ~min:"0.2.0" "randomconv" ] in - main ~packages "Unikernel.Echo_server" (time @-> random @-> job) + main ~packages ~deps:[ dep noop ] "Unikernel" job -let () = register "echo_server" [ main $ default_time $ default_random ] +let () = register "echo_server" [ main ] diff --git a/tutorial/lwt/echo_server/unikernel.ml b/tutorial/lwt/echo_server/unikernel.ml index a8c80c4e..76f69d8e 100644 --- a/tutorial/lwt/echo_server/unikernel.ml +++ b/tutorial/lwt/echo_server/unikernel.ml @@ -1,20 +1,18 @@ open Lwt.Infix -module Echo_server (Time : Mirage_time.S) (R : Mirage_crypto_rng_mirage.S) = -struct - let generate n = R.generate n +let generate n = Mirage_crypto_rng.generate n - let read_line () = - Time.sleep_ns (Duration.of_ms (Randomconv.int ~bound:2500 generate)) - >|= fun () -> String.make (Randomconv.int ~bound:20 generate) 'a' +let read_line () = + Mirage_sleep.ns (Duration.of_ms (Randomconv.int ~bound:2500 generate)) + >|= fun () -> String.make (Randomconv.int ~bound:20 generate) 'a' + +let start () = + let rec echo_server = function + | 0 -> Lwt.return () + | n -> + read_line () >>= fun s -> + Logs.info (fun m -> m "%s" s); + echo_server (n - 1) + in + echo_server 10 - let start _time _r = - let rec echo_server = function - | 0 -> Lwt.return () - | n -> - read_line () >>= fun s -> - Logs.info (fun m -> m "%s" s); - echo_server (n - 1) - in - echo_server 10 -end diff --git a/tutorial/lwt/heads1/config.ml b/tutorial/lwt/heads1/config.ml index 6299cdd4..a9c30db4 100644 --- a/tutorial/lwt/heads1/config.ml +++ b/tutorial/lwt/heads1/config.ml @@ -2,6 +2,6 @@ open Mirage let main = - main ~packages:[ package "duration" ] "Unikernel.Heads1" (time @-> job) + main ~packages:[ package "duration" ] ~deps:[ dep noop ] "Unikernel" job -let () = register "heads1" [ main $ default_time ] +let () = register "heads1" [ main ] diff --git a/tutorial/lwt/heads1/unikernel.ml b/tutorial/lwt/heads1/unikernel.ml index a8456de6..b653a208 100644 --- a/tutorial/lwt/heads1/unikernel.ml +++ b/tutorial/lwt/heads1/unikernel.ml @@ -1,13 +1,11 @@ open Lwt.Infix -module Heads1 (Time : Mirage_time.S) = struct - let start _time = - Lwt.join - [ - ( Time.sleep_ns (Duration.of_sec 1) >|= fun () -> - Logs.info (fun m -> m "Heads") ); - ( Time.sleep_ns (Duration.of_sec 2) >|= fun () -> - Logs.info (fun m -> m "Tails") ); - ] - >|= fun () -> Logs.info (fun m -> m "Finished") -end +let start () = + Lwt.join + [ + ( Mirage_sleep.ns (Duration.of_sec 1) >|= fun () -> + Logs.info (fun m -> m "Heads") ); + ( Mirage_sleep.ns (Duration.of_sec 2) >|= fun () -> + Logs.info (fun m -> m "Tails") ); + ] + >|= fun () -> Logs.info (fun m -> m "Finished") diff --git a/tutorial/lwt/heads2/config.ml b/tutorial/lwt/heads2/config.ml index c8e54e46..22cc5377 100644 --- a/tutorial/lwt/heads2/config.ml +++ b/tutorial/lwt/heads2/config.ml @@ -4,6 +4,7 @@ open Mirage let main = main ~packages:[ package "duration"; package ~min:"0.2.0" "randomconv" ] - "Unikernel.Heads2" (time @-> job) + ~deps:[ dep noop ] + "Unikernel" job -let () = register "heads2" [ main $ default_time ] +let () = register "heads2" [ main ] diff --git a/tutorial/lwt/heads2/unikernel.ml b/tutorial/lwt/heads2/unikernel.ml index 4e110190..c3034505 100644 --- a/tutorial/lwt/heads2/unikernel.ml +++ b/tutorial/lwt/heads2/unikernel.ml @@ -1,14 +1,12 @@ open Lwt.Infix -module Heads2 (Time : Mirage_time.S) = struct - let start _time = - let heads = - Time.sleep_ns (Duration.of_sec 1) >|= fun () -> - Logs.info (fun m -> m "Heads") - in - let tails = - Time.sleep_ns (Duration.of_sec 2) >|= fun () -> - Logs.info (fun m -> m "Tails") - in - heads <&> tails >|= fun () -> Logs.info (fun m -> m "Finished") -end +let start () = + let heads = + Mirage_sleep.ns (Duration.of_sec 1) >|= fun () -> + Logs.info (fun m -> m "Heads") + in + let tails = + Mirage_sleep.ns (Duration.of_sec 2) >|= fun () -> + Logs.info (fun m -> m "Tails") + in + heads <&> tails >|= fun () -> Logs.info (fun m -> m "Finished") diff --git a/tutorial/lwt/timeout1/config.ml b/tutorial/lwt/timeout1/config.ml index a155e382..214ef60f 100644 --- a/tutorial/lwt/timeout1/config.ml +++ b/tutorial/lwt/timeout1/config.ml @@ -4,7 +4,8 @@ open Mirage let main = main ~packages:[ package "duration"; package ~min:"0.2.0" "randomconv" ] - "Unikernel.Timeout1" - (time @-> random @-> job) + ~deps:[ dep noop ] + "Unikernel" + job -let () = register "timeout1" [ main $ default_time $ default_random ] +let () = register "timeout1" [ main ] diff --git a/tutorial/lwt/timeout1/unikernel.ml b/tutorial/lwt/timeout1/unikernel.ml index 26943cc2..785d2cea 100644 --- a/tutorial/lwt/timeout1/unikernel.ml +++ b/tutorial/lwt/timeout1/unikernel.ml @@ -1,23 +1,20 @@ open Lwt.Infix -module Timeout1 (Time : Mirage_time.S) (R : Mirage_crypto_rng_mirage.S) = struct - let timeout delay t = - Time.sleep_ns delay >>= fun () -> - match Lwt.state t with - | Lwt.Sleep -> - Lwt.cancel t; - Lwt.return None - | Lwt.Return v -> Lwt.return (Some v) - | Lwt.Fail ex -> Lwt.fail ex +let timeout delay t = + Mirage_sleep.ns delay >>= fun () -> + match Lwt.state t with + | Lwt.Sleep -> + Lwt.cancel t; + Lwt.return None + | Lwt.Return v -> Lwt.return (Some v) + | Lwt.Fail ex -> Lwt.fail ex - let generate i = R.generate i - - let start _time _r = - let t = - Time.sleep_ns (Duration.of_ms (Randomconv.int ~bound:3000 generate)) - >|= fun () -> "Heads" - in - timeout (Duration.of_sec 2) t >|= function - | None -> Logs.info (fun m -> m "Cancelled") - | Some v -> Logs.info (fun m -> m "Returned %S" v) -end +let start () = + let t = + let r = Randomconv.int ~bound:3000 Mirage_crypto_rng.generate in + Mirage_sleep.ns (Duration.of_ms r) >|= fun () -> + "Heads" + in + timeout (Duration.of_sec 2) t >|= function + | None -> Logs.info (fun m -> m "Cancelled") + | Some v -> Logs.info (fun m -> m "Returned %S" v) diff --git a/tutorial/lwt/timeout2/config.ml b/tutorial/lwt/timeout2/config.ml index bbdb9c23..08262088 100644 --- a/tutorial/lwt/timeout2/config.ml +++ b/tutorial/lwt/timeout2/config.ml @@ -4,7 +4,8 @@ open Mirage let main = main ~packages:[ package "duration"; package ~min:"0.2.0" "randomconv" ] - "Unikernel.Timeout2" - (time @-> random @-> job) + ~deps:[ dep noop ] + "Unikernel" + job -let () = register "timeout2" [ main $ default_time $ default_random ] +let () = register "timeout2" [ main ] diff --git a/tutorial/lwt/timeout2/unikernel.ml b/tutorial/lwt/timeout2/unikernel.ml index 4d1a00ee..7fc9c841 100644 --- a/tutorial/lwt/timeout2/unikernel.ml +++ b/tutorial/lwt/timeout2/unikernel.ml @@ -1,18 +1,15 @@ open Lwt.Infix -module Timeout2 (Time : Mirage_time.S) (R : Mirage_crypto_rng_mirage.S) = struct - let timeout delay t = - let tmout = Time.sleep_ns delay in - Lwt.pick [ (tmout >|= fun () -> None); (t >|= fun v -> Some v) ] +let timeout delay t = + let tmout = Mirage_sleep.ns delay in + Lwt.pick [ (tmout >|= fun () -> None); (t >|= fun v -> Some v) ] - let generate i = R.generate i - - let start _time _r = - let t = - Time.sleep_ns (Duration.of_ms (Randomconv.int ~bound:3000 generate)) - >|= fun () -> "Heads" - in - timeout (Duration.of_sec 2) t >|= function - | None -> Logs.info (fun m -> m "Cancelled") - | Some v -> Logs.info (fun m -> m "Returned %S" v) -end +let start () = + let t = + let r = Randomconv.int ~bound:3000 Mirage_crypto_rng.generate in + Mirage_sleep.ns (Duration.of_ms r) >|= fun () -> + "Heads" + in + timeout (Duration.of_sec 2) t >|= function + | None -> Logs.info (fun m -> m "Cancelled") + | Some v -> Logs.info (fun m -> m "Returned %S" v) From 708b8d51720ef3c3d7147e8a4e18b8dd84ba9f80 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 21 Jan 2025 23:16:20 +0100 Subject: [PATCH 2/4] fix remaining --- Makefile | 2 +- applications/crypto/config.ml | 4 +- applications/crypto/unikernel.ml | 101 ++++++++++---------- applications/dhcp/config.ml | 5 +- applications/dhcp/unikernel.ml | 16 ++-- applications/git/config.ml | 4 - applications/git/unikernel.ml | 4 +- applications/http/config.ml | 9 +- applications/http/connect.ml | 5 +- applications/http/unikernel.ml | 3 +- applications/static_website_tls/config.ml | 4 +- applications/static_website_tls/dispatch.ml | 5 +- device-usage/clock/config.ml | 5 +- device-usage/clock/unikernel.ml | 33 +++---- device-usage/disk-lottery/config.ml | 4 +- device-usage/disk-lottery/unikernel.ml | 7 +- 16 files changed, 94 insertions(+), 117 deletions(-) diff --git a/Makefile b/Makefile index 255dd549..63e47b4b 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ BASE_TESTS = \ tutorial/lwt/timeout1 \ tutorial/lwt/timeout2 \ tutorial/lwt/echo_server \ - tutorial/app_info #\ + tutorial/app_info \ device-usage/clock \ device-usage/conduit_server \ device-usage/http-fetch \ diff --git a/applications/crypto/config.ml b/applications/crypto/config.ml index 30277d4b..c4950a82 100644 --- a/applications/crypto/config.ml +++ b/applications/crypto/config.ml @@ -12,5 +12,5 @@ let packages = package ~min:"0.2.0" "randomconv"; ] -let main = main "Unikernel.Main" ~packages (random @-> job) -let () = register "crypto-test" [ main $ default_random ] +let main = main "Unikernel" ~packages ~deps:[ dep noop ] job +let () = register "crypto-test" [ main ] diff --git a/applications/crypto/unikernel.ml b/applications/crypto/unikernel.ml index a435ac6c..f9419bd0 100644 --- a/applications/crypto/unikernel.ml +++ b/applications/crypto/unikernel.ml @@ -1,51 +1,50 @@ -module Main (R : Mirage_crypto_rng_mirage.S) = struct - let start _r = - Logs.info (fun m -> - m "using Fortuna, entropy sources: %a" - Fmt.(list ~sep:(any ", ") Mirage_crypto_rng.Entropy.pp_source) - (Mirage_crypto_rng.Entropy.sources ())); - Logs.info (fun m -> - m "Random numbers: 0x%02X 0x%04X 0x%08lX 0x%016LX" - (Randomconv.int8 R.generate) - (Randomconv.int16 R.generate) - (Randomconv.int32 R.generate) - (Randomconv.int64 R.generate)); - Logs.info (fun m -> - m "64 byte random:@ %a" (Ohex.pp_hexdump ()) (R.generate 64)); - Logs.info (fun m -> - m "MD5 of the empty string %a" (Ohex.pp_hexdump ()) - Digestif.MD5.(to_raw_string (digest_string ""))); - Logs.info (fun m -> - m "SHA1 of the empty string %a" (Ohex.pp_hexdump ()) - Digestif.SHA1.(to_raw_string (digest_string ""))); - Logs.info (fun m -> - m "SHA256 of the empty string %a" (Ohex.pp_hexdump ()) - Digestif.SHA256.(to_raw_string (digest_string ""))); - Logs.info (fun m -> - m "SHA384 of the empty string %a" (Ohex.pp_hexdump ()) - Digestif.SHA384.(to_raw_string (digest_string ""))); - Logs.info (fun m -> - m "SHA512 of the empty string %a" (Ohex.pp_hexdump ()) - Digestif.SHA512.(to_raw_string (digest_string ""))); - let n = String.make 32 '\000' in - let key = Mirage_crypto.Chacha20.of_secret n - and nonce = String.make 12 '\000' in - Logs.info (fun m -> - m "Chacha20/Poly1305 of 32*0, key 32*0, nonce 12*0: %a" - (Ohex.pp_hexdump ()) - (Mirage_crypto.Chacha20.authenticate_encrypt ~key ~nonce n)); - let key = Mirage_crypto_pk.Rsa.generate ~bits:4096 () in - let signature = - Mirage_crypto_pk.Rsa.PKCS1.sign ~hash:`SHA256 ~key (`Message n) - in - let verified = - let key = Mirage_crypto_pk.Rsa.pub_of_priv key in - let hashp = function `SHA256 -> true | _ -> false in - Mirage_crypto_pk.Rsa.PKCS1.verify ~hashp ~key ~signature (`Message n) - in - Logs.info (fun m -> - m "Generated a RSA key of %d bits (sign + verify %B)" - (Mirage_crypto_pk.Rsa.priv_bits key) - verified); - Lwt.return_unit -end +let start () = + Logs.info (fun m -> + m "using Fortuna, entropy sources: %a" + Fmt.(list ~sep:(any ", ") Mirage_crypto_rng.Entropy.pp_source) + (Mirage_crypto_rng.Entropy.sources ())); + Logs.info (fun m -> + m "Random numbers: 0x%02X 0x%04X 0x%08lX 0x%016LX" + (Randomconv.int8 Mirage_crypto_rng.generate) + (Randomconv.int16 Mirage_crypto_rng.generate) + (Randomconv.int32 Mirage_crypto_rng.generate) + (Randomconv.int64 Mirage_crypto_rng.generate)); + Logs.info (fun m -> + m "64 byte random:@ %a" (Ohex.pp_hexdump ()) + (Mirage_crypto_rng.generate 64)); + Logs.info (fun m -> + m "MD5 of the empty string %a" (Ohex.pp_hexdump ()) + Digestif.MD5.(to_raw_string (digest_string ""))); + Logs.info (fun m -> + m "SHA1 of the empty string %a" (Ohex.pp_hexdump ()) + Digestif.SHA1.(to_raw_string (digest_string ""))); + Logs.info (fun m -> + m "SHA256 of the empty string %a" (Ohex.pp_hexdump ()) + Digestif.SHA256.(to_raw_string (digest_string ""))); + Logs.info (fun m -> + m "SHA384 of the empty string %a" (Ohex.pp_hexdump ()) + Digestif.SHA384.(to_raw_string (digest_string ""))); + Logs.info (fun m -> + m "SHA512 of the empty string %a" (Ohex.pp_hexdump ()) + Digestif.SHA512.(to_raw_string (digest_string ""))); + let n = String.make 32 '\000' in + let key = Mirage_crypto.Chacha20.of_secret n + and nonce = String.make 12 '\000' in + Logs.info (fun m -> + m "Chacha20/Poly1305 of 32*0, key 32*0, nonce 12*0: %a" + (Ohex.pp_hexdump ()) + (Mirage_crypto.Chacha20.authenticate_encrypt ~key ~nonce n)); + let key = Mirage_crypto_pk.Rsa.generate ~bits:4096 () in + let signature = + Mirage_crypto_pk.Rsa.PKCS1.sign ~hash:`SHA256 ~key (`Message n) + in + let verified = + let key = Mirage_crypto_pk.Rsa.pub_of_priv key in + let hashp = function `SHA256 -> true | _ -> false in + Mirage_crypto_pk.Rsa.PKCS1.verify ~hashp ~key ~signature (`Message n) + in + Logs.info (fun m -> + m "Generated a RSA key of %d bits (sign + verify %B)" + (Mirage_crypto_pk.Rsa.priv_bits key) + verified); + Lwt.return_unit diff --git a/applications/dhcp/config.ml b/applications/dhcp/config.ml index da385d9c..85b03d1d 100644 --- a/applications/dhcp/config.ml +++ b/applications/dhcp/config.ml @@ -9,8 +9,7 @@ let packages = package ~min:"3.0.0" "ethernet"; ] -let main = main "Unikernel.Main" ~packages (network @-> mclock @-> time @-> job) +let main = main "Unikernel.Main" ~packages (network @-> job) let () = - register "dhcp" - [ main $ default_network $ default_monotonic_clock $ default_time ] + register "dhcp" [ main $ default_network ] diff --git a/applications/dhcp/unikernel.ml b/applications/dhcp/unikernel.ml index 2bfc6395..0106c9d0 100644 --- a/applications/dhcp/unikernel.ml +++ b/applications/dhcp/unikernel.ml @@ -1,25 +1,21 @@ open Lwt.Infix -module Main - (N : Mirage_net.S) - (MClock : Mirage_clock.MCLOCK) - (Time : Mirage_time.S) = -struct +module Main (N : Mirage_net.S) = struct module E = Ethernet.Make (N) - module A = Arp.Make (E) (Time) + module A = Arp.Make (E) module DC = Dhcp_config let of_interest dest net = Macaddr.compare dest (N.mac net) = 0 || not (Macaddr.is_unicast dest) - let input_dhcp clock net config leases buf = + let input_dhcp net config leases buf = match Dhcp_wire.pkt_of_buf buf (Cstruct.length buf) with | Error e -> Logs.err (fun m -> m "Can't parse packet: %s" e); Lwt.return leases | Ok pkt -> ( let open Dhcp_server.Input in - let now = MClock.elapsed_ns clock |> Duration.to_sec |> Int32.of_int in + let now = Mirage_mtime.elapsed_ns () |> Duration.to_sec |> Int32.of_int in match input_pkt config leases pkt now with | Silence -> Lwt.return leases | Update leases -> @@ -42,7 +38,7 @@ struct Logs.info (fun m -> m "Sent reply packet %a" Dhcp_wire.pp_pkt reply); Lwt.return leases) - let start net clock _time = + let start net = (* Get an ARP stack *) E.connect net >>= fun e -> A.connect e >>= fun a -> @@ -67,7 +63,7 @@ struct of_interest ethif_header.Ethernet.Packet.destination net && Dhcp_wire.is_dhcp buf (Cstruct.length buf) then ( - input_dhcp clock net config !leases buf >>= fun new_leases -> + input_dhcp net config !leases buf >>= fun new_leases -> leases := new_leases; Lwt.return_unit) else if ethif_header.Ethernet.Packet.ethertype = `ARP then diff --git a/applications/git/config.ml b/applications/git/config.ml index 74510d69..d65a61d2 100644 --- a/applications/git/config.ml +++ b/applications/git/config.ml @@ -53,10 +53,6 @@ let mimic stackv4v6 happy_eyeballs dns_client = merge_git_clients mhttp (merge_git_clients mtcp mssh) let stackv4v6 = generic_stackv4v6 default_network -let mclock = default_monotonic_clock -let pclock = default_posix_clock -let time = default_time -let random = default_random let happy_eyeballs = generic_happy_eyeballs stackv4v6 let dns_client = generic_dns_client stackv4v6 happy_eyeballs let git = git_impl None $ sha1 diff --git a/applications/git/unikernel.ml b/applications/git/unikernel.ml index 235a713a..208fa8ce 100644 --- a/applications/git/unikernel.ml +++ b/applications/git/unikernel.ml @@ -19,9 +19,9 @@ module Make (Store : Git.S) (_ : sig end) = struct Git.User.name = "Romain Calascibetta"; email = "romain.calascibetta@gmail.com"; date = - (let ptime = Ptime.unsafe_of_d_ps (Pclock.now_d_ps ()) in + (let ptime = Mirage_ptime.now () in let tz = - match Pclock.current_tz_offset_s () with + match Mirage_ptime.current_tz_offset_s () with | Some s -> let sign = if s < 0 then `Minus else `Plus in let hours = s / 3600 in diff --git a/applications/http/config.ml b/applications/http/config.ml index e0150b57..86b2eb3b 100644 --- a/applications/http/config.ml +++ b/applications/http/config.ml @@ -16,15 +16,15 @@ let minipaf = package "h2" ~min:"0.13.0"; package "base64" ~sublibs:[ "rfc2045" ]; ] - (random @-> kv_ro @-> kv_ro @-> tcpv4v6 @-> conn @-> http_server @-> job) + (kv_ro @-> kv_ro @-> tcpv4v6 @-> conn @-> http_server @-> job) let conn = let connect _ modname = function - | [ _pclock; _tcpv4v6; ctx ] -> + | [ _tcpv4v6; ctx ] -> code ~pos:__POS__ {ocaml|%s.connect %s|ocaml} modname ctx | _ -> assert false in - impl ~connect "Connect.Make" (pclock @-> tcpv4v6 @-> mimic @-> conn) + impl ~connect "Connect.Make" (tcpv4v6 @-> mimic @-> conn) let stackv4v6 = generic_stackv4v6 default_network let tcpv4v6 = tcpv4v6_of_stackv4v6 stackv4v6 @@ -35,7 +35,7 @@ let keys = crunch "keys" let conn = let happy_eyeballs = mimic_happy_eyeballs stackv4v6 he dns in - conn $ default_posix_clock $ tcpv4v6 $ happy_eyeballs + conn $ tcpv4v6 $ happy_eyeballs let port = Runtime_arg.create ~pos:__POS__ "Unikernel.port" let http_server = paf_server ~port tcpv4v6 @@ -44,7 +44,6 @@ let () = register "minipaf" [ minipaf - $ default_random $ certificates $ keys $ tcpv4v6 diff --git a/applications/http/connect.ml b/applications/http/connect.ml index 6b33bb12..b36472fd 100644 --- a/applications/http/connect.ml +++ b/applications/http/connect.ml @@ -11,7 +11,6 @@ let connect_hostname = Mimic.make ~name:"connect-hostname" let connect_tls_config = Mimic.make ~name:"connect-tls-config" module Make - (Pclock : Mirage_clock.PCLOCK) (TCP : Tcpip.Tcp.S) (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct @@ -104,9 +103,7 @@ struct in Lwt.return ctx - let authenticator = - let module V = Ca_certs_nss.Make (Pclock) in - V.authenticator () + let authenticator = Ca_certs_nss.authenticator () end let decode_uri ~ctx uri = diff --git a/applications/http/unikernel.ml b/applications/http/unikernel.ml index ce50bbce..dae3e39a 100644 --- a/applications/http/unikernel.ml +++ b/applications/http/unikernel.ml @@ -30,7 +30,6 @@ let ( <.> ) f g x = f (g x) let always x _ = x module Make - (Random : Mirage_crypto_rng_mirage.S) (Certificate : Mirage_kv.RO) (Key : Mirage_kv.RO) (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t) @@ -139,7 +138,7 @@ struct in Paf.serve http_1_1_service http_server |> fun (`Initialized th) -> th - let start _random certificate_ro key_ro tcpv4v6 ctx http_server = + let start certificate_ro key_ro tcpv4v6 ctx http_server = let open Lwt.Infix in let authenticator = Connect.authenticator in tls key_ro certificate_ro >>= fun tls -> diff --git a/applications/static_website_tls/config.ml b/applications/static_website_tls/config.ml index 6969c834..a8b84aa2 100644 --- a/applications/static_website_tls/config.ml +++ b/applications/static_website_tls/config.ml @@ -15,7 +15,7 @@ let certs = generic_kv_ro ~key:certs_key "tls" let main = let packages = [ package "uri"; package "magic-mime" ] in - main ~packages "Dispatch.HTTPS" (pclock @-> kv_ro @-> kv_ro @-> http @-> job) + main ~packages "Dispatch.HTTPS" (kv_ro @-> kv_ro @-> http @-> job) let () = - register "https" [ main $ default_posix_clock $ data $ certs $ https_srv ] + register "https" [ main $ data $ certs $ https_srv ] diff --git a/applications/static_website_tls/dispatch.ml b/applications/static_website_tls/dispatch.ml index ec1465c9..2f6ac258 100644 --- a/applications/static_website_tls/dispatch.ml +++ b/applications/static_website_tls/dispatch.ml @@ -66,12 +66,11 @@ module Dispatch (FS : Mirage_kv.RO) (S : HTTP) = struct end module HTTPS - (Pclock : Mirage_clock.PCLOCK) (DATA : Mirage_kv.RO) (KEYS : Mirage_kv.RO) (Http : HTTP) = struct - module X509 = Tls_mirage.X509 (KEYS) (Pclock) + module X509 = Tls_mirage.X509 (KEYS) module D = Dispatch (DATA) (Http) let tls_init kv = @@ -81,7 +80,7 @@ struct in Lwt.return conf - let start _clock data keys http = + let start data keys http = tls_init keys >>= fun cfg -> let tls = `TLS (cfg, `TCP (https_port ())) in let tcp = `TCP (http_port ()) in diff --git a/device-usage/clock/config.ml b/device-usage/clock/config.ml index c4f6d543..168d1545 100644 --- a/device-usage/clock/config.ml +++ b/device-usage/clock/config.ml @@ -3,8 +3,7 @@ open Mirage let main = let packages = [ package "duration" ] in - main ~packages "Unikernel.Main" (time @-> pclock @-> mclock @-> job) + main ~packages ~deps:[ dep noop ] "Unikernel" job let () = - register "speaking_clock" - [ main $ default_time $ default_posix_clock $ default_monotonic_clock ] + register "speaking_clock" [ main ] diff --git a/device-usage/clock/unikernel.ml b/device-usage/clock/unikernel.ml index bfda9e61..270c2ea2 100644 --- a/device-usage/clock/unikernel.ml +++ b/device-usage/clock/unikernel.ml @@ -1,21 +1,16 @@ open Lwt.Infix -module Main - (Time : Mirage_time.S) - (PClock : Mirage_clock.PCLOCK) - (MClock : Mirage_clock.MCLOCK) = -struct - let start _time pclock mclock = - let rec speak pclock mclock () = - let current_time = PClock.now_d_ps pclock |> Ptime.v in - let tz = PClock.current_tz_offset_s pclock in - Logs.app (fun m -> - m "%Lu nanoseconds have elapsed." (MClock.elapsed_ns mclock)); - Logs.app (fun m -> - m "At the stroke, the time will be %a \x07 *BEEP*" - (Ptime.pp_human ?tz_offset_s:tz ()) - current_time); - Time.sleep_ns (Duration.of_sec 1) >>= fun () -> speak pclock mclock () - in - speak pclock mclock () -end +let start () = + let rec speak () = + let current_time = Mirage_ptime.now () in + let tz = Mirage_ptime.current_tz_offset_s () in + Logs.app (fun m -> + m "%Lu nanoseconds have elapsed." (Mirage_mtime.elapsed_ns ())); + Logs.app (fun m -> + m "At the stroke, the time will be %a \x07 *BEEP*" + (Ptime.pp_human ?tz_offset_s:tz ()) + current_time); + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> + speak () + in + speak () diff --git a/device-usage/disk-lottery/config.ml b/device-usage/disk-lottery/config.ml index f780ee59..8a7aa705 100644 --- a/device-usage/disk-lottery/config.ml +++ b/device-usage/disk-lottery/config.ml @@ -3,10 +3,10 @@ open Mirage let main = main "Unikernel.Main" - (block @-> random @-> job) + (block @-> job) ~packages:[ package "checkseum"; package "cstruct"; package "fmt" ] let img = if_impl Key.is_solo5 (block_of_file "storage") (block_of_file "disk.img") -let () = register "lottery" [ main $ img $ default_random ] +let () = register "lottery" [ main $ img ] diff --git a/device-usage/disk-lottery/unikernel.ml b/device-usage/disk-lottery/unikernel.ml index 5b16d559..8239d7ed 100644 --- a/device-usage/disk-lottery/unikernel.ml +++ b/device-usage/disk-lottery/unikernel.ml @@ -19,8 +19,7 @@ let reset = in Mirage_runtime.register_arg Arg.(value & flag doc) -module Main (Disk : Mirage_block.S) (Random : Mirage_crypto_rng_mirage.S) = -struct +module Main (Disk : Mirage_block.S) = struct let write_state disk info sector state = let buf = Cstruct.create info.Mirage_block.sector_size in Lotto.marshal buf state; @@ -48,7 +47,7 @@ struct let play disk info sector = read_state disk info sector >>= fun state -> - let draw = String.get_int32_be (Random.generate 4) 0 in + let draw = String.get_int32_be (Mirage_crypto_rng.generate 4) 0 in let game, state = Lotto.play state draw in Logs.app (fun m -> m "%a" Lotto.pp_game game); Logs.info (fun m -> m "Saving new game state..."); @@ -67,7 +66,7 @@ struct in loop 0L - let start disk _random = + let start disk = Disk.get_info disk >>= fun info -> if info.sector_size < Lotto.len then ( Logs.err (fun m -> From 0d0c5e528e21aefe9ddfcfc9f3c7e3d10f47e8c1 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 4 Feb 2025 16:25:21 +0100 Subject: [PATCH 3/4] remove ~deps:[dep noop] now that mirage automatically inserts it --- applications/crypto/config.ml | 2 +- device-usage/clock/config.ml | 2 +- tutorial/app_info/config.ml | 1 - tutorial/hello-key/config.ml | 2 +- tutorial/hello/config.ml | 2 +- tutorial/lwt/echo_server/config.ml | 2 +- tutorial/lwt/heads1/config.ml | 2 +- tutorial/lwt/heads2/config.ml | 1 - tutorial/lwt/timeout1/config.ml | 1 - tutorial/lwt/timeout2/config.ml | 1 - 10 files changed, 6 insertions(+), 10 deletions(-) diff --git a/applications/crypto/config.ml b/applications/crypto/config.ml index c4950a82..96e1652b 100644 --- a/applications/crypto/config.ml +++ b/applications/crypto/config.ml @@ -12,5 +12,5 @@ let packages = package ~min:"0.2.0" "randomconv"; ] -let main = main "Unikernel" ~packages ~deps:[ dep noop ] job +let main = main "Unikernel" ~packages job let () = register "crypto-test" [ main ] diff --git a/device-usage/clock/config.ml b/device-usage/clock/config.ml index 168d1545..711f832d 100644 --- a/device-usage/clock/config.ml +++ b/device-usage/clock/config.ml @@ -3,7 +3,7 @@ open Mirage let main = let packages = [ package "duration" ] in - main ~packages ~deps:[ dep noop ] "Unikernel" job + main ~packages "Unikernel" job let () = register "speaking_clock" [ main ] diff --git a/tutorial/app_info/config.ml b/tutorial/app_info/config.ml index c9210d97..f9d442dd 100644 --- a/tutorial/app_info/config.ml +++ b/tutorial/app_info/config.ml @@ -3,7 +3,6 @@ open Mirage let main = main "Unikernel" - ~deps:[ dep noop ] ~packages:[ package "fmt"; package "dune-build-info" ] job diff --git a/tutorial/hello-key/config.ml b/tutorial/hello-key/config.ml index 713e2d50..2833ed80 100644 --- a/tutorial/hello-key/config.ml +++ b/tutorial/hello-key/config.ml @@ -2,5 +2,5 @@ open Mirage let packages = [ package "duration" ] -let main = main ~packages "Unikernel" ~deps:[ dep noop ] job +let main = main ~packages "Unikernel" job let () = register "hello-key" [ main ] diff --git a/tutorial/hello/config.ml b/tutorial/hello/config.ml index f123b111..18425bcb 100644 --- a/tutorial/hello/config.ml +++ b/tutorial/hello/config.ml @@ -2,6 +2,6 @@ open Mirage let main = - main "Unikernel" job ~deps:[ dep noop ] ~packages:[ package "duration" ] + main "Unikernel" job ~packages:[ package "duration" ] let () = register "hello" [ main ] diff --git a/tutorial/lwt/echo_server/config.ml b/tutorial/lwt/echo_server/config.ml index ed83bf6b..e2c90fc9 100644 --- a/tutorial/lwt/echo_server/config.ml +++ b/tutorial/lwt/echo_server/config.ml @@ -3,6 +3,6 @@ open Mirage let main = let packages = [ package "duration"; package ~min:"0.2.0" "randomconv" ] in - main ~packages ~deps:[ dep noop ] "Unikernel" job + main ~packages "Unikernel" job let () = register "echo_server" [ main ] diff --git a/tutorial/lwt/heads1/config.ml b/tutorial/lwt/heads1/config.ml index a9c30db4..b28d151a 100644 --- a/tutorial/lwt/heads1/config.ml +++ b/tutorial/lwt/heads1/config.ml @@ -2,6 +2,6 @@ open Mirage let main = - main ~packages:[ package "duration" ] ~deps:[ dep noop ] "Unikernel" job + main ~packages:[ package "duration" ] "Unikernel" job let () = register "heads1" [ main ] diff --git a/tutorial/lwt/heads2/config.ml b/tutorial/lwt/heads2/config.ml index 22cc5377..bfb4cba5 100644 --- a/tutorial/lwt/heads2/config.ml +++ b/tutorial/lwt/heads2/config.ml @@ -4,7 +4,6 @@ open Mirage let main = main ~packages:[ package "duration"; package ~min:"0.2.0" "randomconv" ] - ~deps:[ dep noop ] "Unikernel" job let () = register "heads2" [ main ] diff --git a/tutorial/lwt/timeout1/config.ml b/tutorial/lwt/timeout1/config.ml index 214ef60f..703fa228 100644 --- a/tutorial/lwt/timeout1/config.ml +++ b/tutorial/lwt/timeout1/config.ml @@ -4,7 +4,6 @@ open Mirage let main = main ~packages:[ package "duration"; package ~min:"0.2.0" "randomconv" ] - ~deps:[ dep noop ] "Unikernel" job diff --git a/tutorial/lwt/timeout2/config.ml b/tutorial/lwt/timeout2/config.ml index 08262088..da1a3f3b 100644 --- a/tutorial/lwt/timeout2/config.ml +++ b/tutorial/lwt/timeout2/config.ml @@ -4,7 +4,6 @@ open Mirage let main = main ~packages:[ package "duration"; package ~min:"0.2.0" "randomconv" ] - ~deps:[ dep noop ] "Unikernel" job From abc29bfab7f93626778d613b44c222008961cd36 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 17 Feb 2025 15:50:27 +0100 Subject: [PATCH 4/4] http, static-website: disable temporarily --- Makefile | 7 ++++--- Makefile.config | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 63e47b4b..6def50ae 100644 --- a/Makefile +++ b/Makefile @@ -13,7 +13,6 @@ BASE_TESTS = \ tutorial/app_info \ device-usage/clock \ device-usage/conduit_server \ - device-usage/http-fetch \ device-usage/kv_ro \ device-usage/network \ device-usage/ping6 \ @@ -22,14 +21,16 @@ BASE_TESTS = \ applications/http \ applications/git \ applications/dns \ - applications/crypto \ - applications/static_website_tls + applications/crypto # disabled as it is using an old version of conduit: # device-usage/pgx # disabled as it is incompatible with dune 3.7 # device-usage/littlefs # disabled since docteur uses the old git & mirage-flow # applications/docteur +# disabled, need cohttp patches +# device-usage/http-fetch +# applications/static_website_tls ifeq ($(MODE),muen) TESTS = $(BASE_TESTS) diff --git a/Makefile.config b/Makefile.config index 7bc78778..d50c0ff8 100644 --- a/Makefile.config +++ b/Makefile.config @@ -4,7 +4,7 @@ LOCK = ./mirage.opam.locked MIRAGE_EXTRA_REPOS ?= opam-overlays:https://github.com/dune-universe/opam-overlays.git,\ mirage-opam-overlays:https://github.com/dune-universe/mirage-opam-overlays.git -MODE ?= unix +MODE ?= hvt NET ?= socket MIRAGE_FLAGS ?=