diff --git a/Dockerfile b/Dockerfile index c903ce6..e4aa533 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,18 +1,20 @@ # Pin the base image to a specific hash for maximum reproducibility. # It will probably still work on newer images, though, unless an update # changes some compiler optimisations (unlikely). -#FROM ocurrent/opam:fedora-32-ocaml-4.11 -FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0dd35d15510f +# fedora-35-ocaml-4.14 +FROM ocaml/opam@sha256:68b7ce1fd4c992d6f3bfc9b4b0a88ee572ced52427f0547b6e4eb6194415f585 +ENV PATH="${PATH}:/home/opam/.opam/4.14/bin" + +# Since mirage 4.2 we must use opam version 2.1 or later +RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam # Pin last known-good version for reproducible builds. # Remove this line (and the base image pin above) if you want to test with the # latest versions. -RUN cd ~/opam-repository && git fetch origin master && git reset --hard 479a47921a489d11833e03cf949bfb612bd65e41 && opam update +RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard f904585098b809001380caada4b7426c112d086c && opam update -RUN opam depext -i -y mirage +RUN opam install -y mirage opam-monorepo RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall -RUN opam config exec -- mirage configure -t xen && make depend -CMD opam config exec -- mirage configure -t xen && \ - opam config exec -- make tar +CMD opam exec -- mirage configure -t xen && make depend && make tar diff --git a/Makefile.builder b/Makefile.builder index 68a35b9..5d79a54 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,8 +1,7 @@ -MIRAGE_KERNEL_NAME = qubes_firewall.xen -OCAML_VERSION ?= 4.10.0 +MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen +OCAML_VERSION ?= 4.14.0 SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: - opam install -y depext - opam depext -i -y mirage + opam install -y mirage 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 82facc0..8b4b1a9 100644 --- a/README.md +++ b/README.md @@ -134,7 +134,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/build-with-docker.sh b/build-with-docker.sh index ebacfca..821821d 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -4,6 +4,6 @@ echo Building Docker image with dependencies.. docker build -t qubes-mirage-firewall . echo Building Firewall... docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall -echo "SHA2 of build: $(sha256sum qubes_firewall.xen)" -echo "SHA2 last known: e2af3718b7f40ba533f378d1402a41008c3520fe84d991ab58d3230772cc824c" +echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" +echo "SHA2 last known: 588e921b9d78a99f6f49d468a7b68284c50dabeba95698648ea52e99b381723b" echo "(hashes should match for released versions)" 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..d33bf23 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"; @@ -31,12 +30,11 @@ let main = package "mirage-qubes" ~min:"0.9.1"; package "mirage-nat" ~min:"2.2.1"; package "mirage-logs"; - package "mirage-xen" ~min:"6.0.0"; + package "mirage-xen" ~min:"8.0.0"; 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] - ~argv:no_argv + register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time] 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..665ae14 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,16 +38,17 @@ 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 - if fraction_free stats > 0.1 then `Ok + let stats = Xen_os.Memory.quick_stat () in + if fraction_free stats > 0.4 then `Ok else ( Gc.full_major (); - let stats = OS.Memory.quick_stat () in + Xen_os.Memory.trim (); + let stats = Xen_os.Memory.quick_stat () in report_mem_usage stats; - if fraction_free stats < 0.1 then `Memory_critical + if fraction_free stats < 0.4 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