Merge pull request #140 from palainp/mirage4

update to mirage 4.2.0 & mirage-xen 8.0.0
This commit is contained in:
Hannes Mehnert 2022-08-30 16:29:10 +02:00 committed by GitHub
commit 61767ef0d5
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 48 additions and 48 deletions

View File

@ -1,18 +1,20 @@
# Pin the base image to a specific hash for maximum reproducibility. # Pin the base image to a specific hash for maximum reproducibility.
# It will probably still work on newer images, though, unless an update # It will probably still work on newer images, though, unless an update
# changes some compiler optimisations (unlikely). # changes some compiler optimisations (unlikely).
#FROM ocurrent/opam:fedora-32-ocaml-4.11 # fedora-35-ocaml-4.14
FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0dd35d15510f 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. # Pin last known-good version for reproducible builds.
# Remove this line (and the base image pin above) if you want to test with the # Remove this line (and the base image pin above) if you want to test with the
# latest versions. # 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 RUN mkdir /home/opam/qubes-mirage-firewall
ADD config.ml /home/opam/qubes-mirage-firewall/config.ml ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
WORKDIR /home/opam/qubes-mirage-firewall WORKDIR /home/opam/qubes-mirage-firewall
RUN opam config exec -- mirage configure -t xen && make depend CMD opam exec -- mirage configure -t xen && make depend && make tar
CMD opam config exec -- mirage configure -t xen && \
opam config exec -- make tar

View File

@ -1,8 +1,7 @@
MIRAGE_KERNEL_NAME = qubes_firewall.xen MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen
OCAML_VERSION ?= 4.10.0 OCAML_VERSION ?= 4.14.0
SOURCE_BUILD_DEP := firewall-build-dep SOURCE_BUILD_DEP := firewall-build-dep
firewall-build-dep: firewall-build-dep:
opam install -y depext opam install -y mirage
opam depext -i -y mirage

View File

@ -1,7 +1,7 @@
tar: build tar: build
rm -rf _build/mirage-firewall rm -rf _build/mirage-firewall
mkdir _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 touch _build/mirage-firewall/modules.img
cat /dev/null | gzip -n > _build/mirage-firewall/initramfs cat /dev/null | gzip -n > _build/mirage-firewall/initramfs
tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall tar cjf mirage-firewall.tar.bz2 -C _build --mtime=./build-with-docker.sh mirage-firewall

View File

@ -134,7 +134,7 @@ The boot process:
### Easy deployment for developers ### 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. 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 $ test-mirage qubes_firewall.xen mirage-firewall

View File

@ -4,6 +4,6 @@ echo Building Docker image with dependencies..
docker build -t qubes-mirage-firewall . docker build -t qubes-mirage-firewall .
echo Building Firewall... echo Building Firewall...
docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-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 of build: $(sha256sum ./dist/qubes-firewall.xen)"
echo "SHA2 last known: e2af3718b7f40ba533f378d1402a41008c3520fe84d991ab58d3230772cc824c" echo "SHA2 last known: 588e921b9d78a99f6f49d468a7b68284c50dabeba95698648ea52e99b381723b"
echo "(hashes should match for released versions)" echo "(hashes should match for released versions)"

View File

@ -4,7 +4,7 @@
open Lwt.Infix open Lwt.Infix
open Fw_utils 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) module ClientEth = Ethernet.Make(Netback)
let src = Logs.Src.create "client_net" ~doc:"Client networking" let src = Logs.Src.create "client_net" ~doc:"Client networking"

View File

@ -6,17 +6,16 @@
open Mirage open Mirage
let table_size = let table_size =
let open Functoria_key in let info = Key.Arg.info
let info = Arg.info
~doc:"The number of NAT entries to allocate." ~doc:"The number of NAT entries to allocate."
~docv:"ENTRIES" ["nat-table-size"] ~docv:"ENTRIES" ["nat-table-size"]
in in
let key = Arg.opt ~stage:`Both Arg.int 5_000 info in let key = Key.Arg.opt ~stage:`Both Key.Arg.int 5_000 info in
create "nat_table_size" key Key.create "nat_table_size" key
let main = let main =
foreign foreign
~keys:[Functoria_key.abstract table_size] ~keys:[Key.v table_size]
~packages:[ ~packages:[
package "vchan" ~min:"4.0.2"; package "vchan" ~min:"4.0.2";
package "cstruct"; package "cstruct";
@ -31,12 +30,11 @@ let main =
package "mirage-qubes" ~min:"0.9.1"; package "mirage-qubes" ~min:"0.9.1";
package "mirage-nat" ~min:"2.2.1"; package "mirage-nat" ~min:"2.2.1";
package "mirage-logs"; 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 ~min:"6.1.0" "dns-client";
package "pf-qubes"; package "pf-qubes";
] ]
"Unikernel.Main" (random @-> mclock @-> job) "Unikernel.Main" (random @-> mclock @-> time @-> job)
let () = let () =
register "qubes-firewall" [main $ default_random $ default_monotonic_clock] register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time]
~argv:no_argv

8
dao.ml
View File

@ -29,7 +29,7 @@ module VifMap = struct
end end
let directory ~handle dir = let directory ~handle dir =
OS.Xs.directory handle dir >|= function Xen_os.Xs.directory handle dir >|= function
| [""] -> [] (* XenStore client bug *) | [""] -> [] (* XenStore client bug *)
| items -> items | items -> items
@ -77,7 +77,7 @@ let vifs ~handle domid =
| Some device_id -> | Some device_id ->
let vif = { ClientVif.domid; device_id } in let vif = { ClientVif.domid; device_id } in
Lwt.try_bind 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 -> (fun client_ip ->
let client_ip' = match String.cuts ~sep:" " client_ip with let client_ip' = match String.cuts ~sep:" " client_ip with
| [] -> Log.err (fun m -> m "unexpected empty list"); "" | [] -> Log.err (fun m -> m "unexpected empty list"); ""
@ -104,10 +104,10 @@ let vifs ~handle domid =
) )
let watch_clients fn = let watch_clients fn =
OS.Xs.make () >>= fun xs -> Xen_os.Xs.make () >>= fun xs ->
let backend_vifs = "backend/vif" in let backend_vifs = "backend/vif" in
Log.info (fun f -> f "Watching %s" backend_vifs); 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 begin Lwt.catch
(fun () -> directory ~handle backend_vifs) (fun () -> directory ~handle backend_vifs)
(function (function

View File

@ -9,11 +9,11 @@ module Log = (val Logs.src_log src : Logs.LOG)
let wordsize_in_bytes = Sys.word_size / 8 let wordsize_in_bytes = Sys.word_size / 8
let fraction_free stats = 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 float free_words /. float heap_words
let meminfo stats = 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_total = heap_words * wordsize_in_bytes in
let mem_free = free_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 %%)" Log.info (fun f -> f "Writing meminfo: free %a / %a (%.2f %%)"
@ -29,7 +29,7 @@ let meminfo stats =
let report_mem_usage stats = let report_mem_usage stats =
Lwt.async (fun () -> Lwt.async (fun () ->
let open OS in let open Xen_os in
Xs.make () >>= fun xs -> Xs.make () >>= fun xs ->
Xs.immediate xs (fun h -> Xs.immediate xs (fun h ->
Xs.write h "memory/meminfo" (meminfo stats) Xs.write h "memory/meminfo" (meminfo stats)
@ -38,16 +38,17 @@ let report_mem_usage stats =
let init () = let init () =
Gc.full_major (); Gc.full_major ();
let stats = OS.Memory.quick_stat () in let stats = Xen_os.Memory.quick_stat () in
report_mem_usage stats report_mem_usage stats
let status () = 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 if fraction_free stats > 0.4 then `Ok
else ( else (
Gc.full_major (); 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; report_mem_usage stats;
if fraction_free stats < 0.1 then `Memory_critical if fraction_free stats < 0.4 then `Memory_critical
else `Ok else `Ok
) )

View File

@ -1,6 +1,6 @@
open Lwt.Infix 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 +'a io = 'a Lwt.t
type io_addr = Ipaddr.V4.t * int 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 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 } { protocol ; nameserver ; stack ; timeout_ns = timeout }
let with_timeout timeout_ns f = 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 ] Lwt.pick [ f ; timeout ]
let connect (t : t) = Lwt.return (Ok t) let connect (t : t) = Lwt.return (Ok t)

View File

@ -7,9 +7,9 @@ open Qubes
let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
module Log = (val Logs.src_log src : Logs.LOG) module Log = (val Logs.src_log src : Logs.LOG)
module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK) = struct module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct
module Uplink = Uplink.Make(R)(Clock) module Uplink = Uplink.Make(R)(Clock)(Time)
module Dns_transport = My_dns.Transport(R)(Clock) module Dns_transport = My_dns.Transport(R)(Clock)(Time)
module Dns_client = Dns_client.Make(Dns_transport) module Dns_client = Dns_client.Make(Dns_transport)
(* Set up networking and listen for incoming packets. *) (* 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). *) (* 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 let start_time = Clock.elapsed_ns () in
(* Start qrexec agent, GUI agent and QubesDB agent in parallel *) (* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
let qrexec = RExec.connect ~domid:0 () in 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); Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time);
(* Watch for shutdown requests from Qubes *) (* Watch for shutdown requests from Qubes *)
let shutdown_rq = let shutdown_rq =
OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
Lwt.return_unit in Lwt.return_unit in
(* Set up networking *) (* Set up networking *)
let max_entries = Key_gen.nat_table_size () in 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. *) (* Run until something fails or we get a shutdown request. *)
Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () -> Lwt.choose [agent_listener; net_listener; shutdown_rq] >>= fun () ->
(* Give the console daemon time to show any final log messages. *) (* 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 end

View File

@ -9,8 +9,8 @@ module Eth = Ethernet.Make(Netif)
let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM"
module Log = (val Logs.src_log src : Logs.LOG) module Log = (val Logs.src_log src : Logs.LOG)
module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) = struct module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct
module Arp = Arp.Make(Eth)(OS.Time) module Arp = Arp.Make(Eth)(Time)
module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp) module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp)
module U = Udp.Make(I)(R) module U = Udp.Make(I)(R)

View File

@ -6,7 +6,7 @@
open Fw_utils open Fw_utils
[@@@ocaml.warning "-67"] [@@@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 type t
val connect : Dao.network_config -> t Lwt.t val connect : Dao.network_config -> t Lwt.t