defunctorised versions of unikernels

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)

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 ?=

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 job
+let () = register "crypto-test" [ main ]

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

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 ]

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

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

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

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

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 =

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 ->

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 ]

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

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 "Unikernel" job
 
 let () =
-  register "speaking_clock"
-    [ main $ default_time $ default_posix_clock $ default_monotonic_clock ]
+  register "speaking_clock" [ main ]

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 ()

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 ]