From a99d7f8792f977b7a91abb8fdbce4bd73f459f33 Mon Sep 17 00:00:00 2001 From: palainp Date: Wed, 30 Mar 2022 03:12:01 -0400 Subject: [PATCH] update to mirage 4.0.0 & mirage-xen 7.0.0 --- Makefile.user | 2 +- README.md | 2 +- client_net.ml | 2 +- config.ml | 13 ++++++------- dao.ml | 8 ++++---- memory_pressure.ml | 12 ++++++------ my_dns.ml | 4 ++-- unikernel.ml | 12 ++++++------ uplink.ml | 4 ++-- uplink.mli | 2 +- 10 files changed, 30 insertions(+), 31 deletions(-) diff --git a/Makefile.user b/Makefile.user index cc7a7f4..04d772b 100644 --- a/Makefile.user +++ b/Makefile.user @@ -1,7 +1,7 @@ tar: build rm -rf _build/mirage-firewall mkdir _build/mirage-firewall - cp qubes_firewall.xen _build/mirage-firewall/vmlinuz + cp dist/qubes-firewall.xen _build/mirage-firewall/vmlinuz touch _build/mirage-firewall/modules.img cat /dev/null | gzip -n > _build/mirage-firewall/initramfs tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall diff --git a/README.md b/README.md index 7b8abbb..4216e49 100644 --- a/README.md +++ b/README.md @@ -145,7 +145,7 @@ The boot process: ### Easy deployment for developers -For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes_firewall.xen`) from your development AppVM. +For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes-firewall.xen`) from your development AppVM. This takes a little more setting up the first time, but will be much quicker after that. e.g. $ test-mirage qubes_firewall.xen mirage-firewall diff --git a/client_net.ml b/client_net.ml index a493f9b..fc501df 100644 --- a/client_net.ml +++ b/client_net.ml @@ -4,7 +4,7 @@ open Lwt.Infix open Fw_utils -module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs)) +module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Xen_os.Xs)) module ClientEth = Ethernet.Make(Netback) let src = Logs.Src.create "client_net" ~doc:"Client networking" diff --git a/config.ml b/config.ml index 2363eb5..a7a1f99 100644 --- a/config.ml +++ b/config.ml @@ -6,17 +6,16 @@ open Mirage let table_size = - let open Functoria_key in - let info = Arg.info + let info = Key.Arg.info ~doc:"The number of NAT entries to allocate." ~docv:"ENTRIES" ["nat-table-size"] in - let key = Arg.opt ~stage:`Both Arg.int 5_000 info in - create "nat_table_size" key + let key = Key.Arg.opt ~stage:`Both Key.Arg.int 5_000 info in + Key.create "nat_table_size" key let main = foreign - ~keys:[Functoria_key.abstract table_size] + ~keys:[Key.v table_size] ~packages:[ package "vchan" ~min:"4.0.2"; package "cstruct"; @@ -35,8 +34,8 @@ let main = package ~min:"6.1.0" "dns-client"; package "pf-qubes"; ] - "Unikernel.Main" (random @-> mclock @-> job) + "Unikernel.Main" (random @-> mclock @-> time @-> job) let () = - register "qubes-firewall" [main $ default_random $ default_monotonic_clock] + register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time] ~argv:no_argv diff --git a/dao.ml b/dao.ml index 30b4c2d..241a90f 100644 --- a/dao.ml +++ b/dao.ml @@ -29,7 +29,7 @@ module VifMap = struct end let directory ~handle dir = - OS.Xs.directory handle dir >|= function + Xen_os.Xs.directory handle dir >|= function | [""] -> [] (* XenStore client bug *) | items -> items @@ -77,7 +77,7 @@ let vifs ~handle domid = | Some device_id -> let vif = { ClientVif.domid; device_id } in Lwt.try_bind - (fun () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) + (fun () -> Xen_os.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) (fun client_ip -> let client_ip' = match String.cuts ~sep:" " client_ip with | [] -> Log.err (fun m -> m "unexpected empty list"); "" @@ -104,10 +104,10 @@ let vifs ~handle domid = ) let watch_clients fn = - OS.Xs.make () >>= fun xs -> + Xen_os.Xs.make () >>= fun xs -> let backend_vifs = "backend/vif" in Log.info (fun f -> f "Watching %s" backend_vifs); - OS.Xs.wait xs (fun handle -> + Xen_os.Xs.wait xs (fun handle -> begin Lwt.catch (fun () -> directory ~handle backend_vifs) (function diff --git a/memory_pressure.ml b/memory_pressure.ml index cecf4a9..7f367fb 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -9,11 +9,11 @@ module Log = (val Logs.src_log src : Logs.LOG) let wordsize_in_bytes = Sys.word_size / 8 let fraction_free stats = - let { OS.Memory.free_words; heap_words; _ } = stats in + let { Xen_os.Memory.free_words; heap_words; _ } = stats in float free_words /. float heap_words let meminfo stats = - let { OS.Memory.free_words; heap_words; _ } = stats in + let { Xen_os.Memory.free_words; heap_words; _ } = stats in let mem_total = heap_words * wordsize_in_bytes in let mem_free = free_words * wordsize_in_bytes in Log.info (fun f -> f "Writing meminfo: free %a / %a (%.2f %%)" @@ -29,7 +29,7 @@ let meminfo stats = let report_mem_usage stats = Lwt.async (fun () -> - let open OS in + let open Xen_os in Xs.make () >>= fun xs -> Xs.immediate xs (fun h -> Xs.write h "memory/meminfo" (meminfo stats) @@ -38,15 +38,15 @@ let report_mem_usage stats = let init () = Gc.full_major (); - let stats = OS.Memory.quick_stat () in + let stats = Xen_os.Memory.quick_stat () in report_mem_usage stats let status () = - let stats = OS.Memory.quick_stat () in + let stats = Xen_os.Memory.quick_stat () in if fraction_free stats > 0.1 then `Ok else ( Gc.full_major (); - let stats = OS.Memory.quick_stat () in + let stats = Xen_os.Memory.quick_stat () in report_mem_usage stats; if fraction_free stats < 0.1 then `Memory_critical else `Ok diff --git a/my_dns.ml b/my_dns.ml index a0e8b18..01ce370 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -1,6 +1,6 @@ open Lwt.Infix -module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct +module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct type +'a io = 'a Lwt.t type io_addr = Ipaddr.V4.t * int type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t @@ -25,7 +25,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct { protocol ; nameserver ; stack ; timeout_ns = timeout } let with_timeout timeout_ns f = - let timeout = OS.Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in + let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in Lwt.pick [ f ; timeout ] let connect (t : t) = Lwt.return (Ok t) diff --git a/unikernel.ml b/unikernel.ml index cccb710..f4e65fe 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -7,9 +7,9 @@ open Qubes let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) -module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct - module Uplink = Uplink.Make(R)(Clock) - module Dns_transport = My_dns.Transport(R)(Clock) +module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct + module Uplink = Uplink.Make(R)(Clock)(Time) + module Dns_transport = My_dns.Transport(R)(Clock)(Time) module Dns_client = Dns_client.Make(Dns_transport) (* Set up networking and listen for incoming packets. *) @@ -40,7 +40,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct ) (* Main unikernel entry point (called from auto-generated main.ml). *) - let start _random _clock = + let start _random _clock _time = let start_time = Clock.elapsed_ns () in (* Start qrexec agent, GUI agent and QubesDB agent in parallel *) let qrexec = RExec.connect ~domid:0 () in @@ -59,7 +59,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); (* Watch for shutdown requests from Qubes *) let shutdown_rq = - OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> + Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> Lwt.return_unit in (* Set up networking *) let max_entries = Key_gen.nat_table_size () in @@ -91,5 +91,5 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct (* Run until something fails or we get a shutdown request. *) Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () -> (* Give the console daemon time to show any final log messages. *) - OS.Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float) + Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float) end diff --git a/uplink.ml b/uplink.ml index c058d54..1e5d30e 100644 --- a/uplink.ml +++ b/uplink.ml @@ -9,8 +9,8 @@ module Eth = Ethernet.Make(Netif) let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" module Log = (val Logs.src_log src : Logs.LOG) -module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) = struct - module Arp = Arp.Make(Eth)(OS.Time) +module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct + module Arp = Arp.Make(Eth)(Time) module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp) module U = Udp.Make(I)(R) diff --git a/uplink.mli b/uplink.mli index 438e04a..0052d75 100644 --- a/uplink.mli +++ b/uplink.mli @@ -6,7 +6,7 @@ open Fw_utils [@@@ocaml.warning "-67"] -module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK) : sig +module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) : sig type t val connect : Dao.network_config -> t Lwt.t