From 2acdd320ab754f756da72607b12d3ef60d24c016 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 14 Oct 2024 12:43:29 +0200 Subject: [PATCH 1/3] update to mirage 4.8 --- Dockerfile | 2 +- config.ml | 9 +-------- dispatcher.ml | 6 +++--- my_dns.ml | 16 +++++++++------- test/unikernel.ml | 2 +- unikernel.ml | 30 +++++++++++++++--------------- 6 files changed, 30 insertions(+), 35 deletions(-) diff --git a/Dockerfile b/Dockerfile index f33b6e5..165530f 100644 --- a/Dockerfile +++ b/Dockerfile @@ -23,7 +23,7 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # Remove this line (and the base image pin above) if you want to test with the # latest versions. # taken from https://github.com/ocaml/opam-repository -RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#13acffc3de9c22953d1e08bad3e56ee6e965eeed +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#26c09ff1da6a07b20a0f9474e3a6ed6315c6388b RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build diff --git a/config.ml b/config.ml index 74fa23f..808d4ec 100644 --- a/config.ml +++ b/config.ml @@ -1,4 +1,4 @@ -(* mirage >= 4.5.0 & < 5.0.0 *) +(* mirage >= 4.8.0 & < 5.0.0 *) (* Copyright (C) 2017, Thomas Leonard See the README file for details. *) @@ -6,15 +6,8 @@ open Mirage -let nat_table_size = runtime_arg ~pos:__POS__ "Unikernel.nat_table_size" -let ipv4 = runtime_arg ~pos:__POS__ "Unikernel.ipv4" -let ipv4_gw = runtime_arg ~pos:__POS__ "Unikernel.ipv4_gw" -let ipv4_dns = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns" -let ipv4_dns2 = runtime_arg ~pos:__POS__ "Unikernel.ipv4_dns2" - let main = main - ~runtime_args:[ nat_table_size; ipv4; ipv4_gw; ipv4_dns; ipv4_dns2; ] ~packages:[ package "vchan" ~min:"4.0.2"; package "cstruct"; diff --git a/dispatcher.ml b/dispatcher.ml index fc21cdd..3768863 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -9,7 +9,7 @@ let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch" module Log = (val Logs.src_log src : Logs.LOG) module Make - (R : Mirage_random.S) + (R : Mirage_crypto_rng_mirage.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct @@ -453,7 +453,7 @@ struct | Some uplink -> ( Lwt.catch (fun () -> - U.write ~src_port ~dst ~dst_port uplink.udp buf >|= function + U.write ~src_port ~dst ~dst_port uplink.udp (Cstruct.of_string buf) >|= function | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure") @@ -506,7 +506,7 @@ struct "found a DNS packet whose dst_port (%d) was in the list of \ dns_client ports" header.dst_port); - Lwt_mvar.put dns_responses (header, packet) + Lwt_mvar.put dns_responses (header, Cstruct.to_string packet) | _ -> ipv4_from_netvm router (`IPv4 (header, packet)) end end) diff --git a/my_dns.ml b/my_dns.ml index 849aa8d..cbfa763 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -1,10 +1,12 @@ open Lwt.Infix -module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct +module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct type +'a io = 'a Lwt.t type io_addr = Ipaddr.V4.t * int module Dispatcher = Dispatcher.Make(R)(C)(Time) - type stack = Dispatcher.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 = Dispatcher.t * + (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> string -> (unit, [ `Msg of string ]) result Lwt.t) * + (Udp_packet.t * string) Lwt_mvar.t module IM = Map.Make(Int) @@ -13,7 +15,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ nameserver : io_addr ; stack : stack ; timeout_ns : int64 ; - mutable requests : Cstruct.t Lwt_condition.t IM.t ; + mutable requests : string Lwt_condition.t IM.t ; } type context = t @@ -24,8 +26,8 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let rec read t = let _, _, answer = t.stack in Lwt_mvar.take answer >>= fun (_, data) -> - if Cstruct.length data > 2 then begin - match IM.find_opt (Cstruct.BE.get_uint16 data 0) t.requests with + if String.length data > 2 then begin + match IM.find_opt (String.get_uint16_be data 0) t.requests with | Some cond -> Lwt_condition.broadcast cond data | None -> () end; @@ -48,13 +50,13 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let connect (t : t) = Lwt.return (Ok (t.protocol, t)) - let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t = + let send_recv (ctx : context) buf : (string, [> `Msg of string ]) result Lwt.t = let dst, dst_port = ctx.nameserver in let router, send_udp, _ = ctx.stack in let src_port, evict = My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53 in - let id = Cstruct.BE.get_uint16 buf 0 in + let id = String.get_uint16_be buf 0 in with_timeout ctx.timeout_ns (let cond = Lwt_condition.create () in ctx.requests <- IM.add id cond ctx.requests; diff --git a/test/unikernel.ml b/test/unikernel.ml index 9c347f3..04f7d6a 100644 --- a/test/unikernel.ml +++ b/test/unikernel.ml @@ -42,7 +42,7 @@ let netvm = "10.137.0.5" (* default "nameserver"s, which netvm redirects to whatever its real nameservers are *) let nameserver_1, nameserver_2 = "10.139.1.1", "10.139.1.2" -module Client (R: Mirage_random.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct +module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mirage_clock.MCLOCK) (NET: Mirage_net.S) (DB : Qubes.S.DB) = struct module E = Ethernet.Make(NET) module A = Arp.Make(E)(Time) module I = Qubesdb_ipv4.Make(DB)(R)(Clock)(E)(A) diff --git a/unikernel.ml b/unikernel.ml index b4e92c7..b64fd4e 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -10,25 +10,25 @@ module Log = (val Logs.src_log src : Logs.LOG) let nat_table_size = let doc = Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ] in - Arg.(value & opt int 5_000 doc) + Mirage_runtime.register_arg Arg.(value & opt int 5_000 doc) let ipv4 = let doc = Arg.info ~doc:"Manual IP setting." [ "ipv4" ] in - Arg.(value & opt string "0.0.0.0" doc) + Mirage_runtime.register_arg Arg.(value & opt string "0.0.0.0" doc) let ipv4_gw = let doc = Arg.info ~doc:"Manual Gateway IP setting." [ "ipv4-gw" ] in - Arg.(value & opt string "0.0.0.0" doc) + Mirage_runtime.register_arg Arg.(value & opt string "0.0.0.0" doc) let ipv4_dns = let doc = Arg.info ~doc:"Manual DNS IP setting." [ "ipv4-dns" ] in - Arg.(value & opt string "10.139.1.1" doc) + Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.1" doc) let ipv4_dns2 = let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in - Arg.(value & opt string "10.139.1.2" doc) + Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc) -module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct +module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct module Dispatcher = Dispatcher.Make(R)(Clock)(Time) module Dns_transport = My_dns.Transport(R)(Clock)(Time) module Dns_client = Dns_client.Make(Dns_transport) @@ -45,7 +45,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim ] (* Main unikernel entry point (called from auto-generated main.ml). *) - let start _random _clock _time nat_table_size ipv4 ipv4_gw ipv4_dns ipv4_dns2 = + let start _random _clock _time = let start_time = Clock.elapsed_ns () in (* Start qrexec agent and QubesDB agent in parallel *) let qrexec = RExec.connect ~domid:0 () in @@ -66,15 +66,15 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Xen_os.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> Lwt.return_unit in (* Set up networking *) - let nat = My_nat.create ~max_entries:nat_table_size in + let nat = My_nat.create ~max_entries:(nat_table_size ()) in + + let netvm_ip = Ipaddr.V4.of_string_exn (ipv4_gw ()) in + let our_ip = Ipaddr.V4.of_string_exn (ipv4 ()) in + let dns = Ipaddr.V4.of_string_exn (ipv4_dns ()) in + let dns2 = Ipaddr.V4.of_string_exn (ipv4_dns2 ()) in + + let zero_ip = Ipaddr.V4.any in - let netvm_ip = Ipaddr.V4.of_string_exn ipv4_gw in - let our_ip = Ipaddr.V4.of_string_exn ipv4 in - let dns = Ipaddr.V4.of_string_exn ipv4_dns in - let dns2 = Ipaddr.V4.of_string_exn ipv4_dns2 in - - let zero_ip = (Ipaddr.V4.make 0 0 0 0) in - let network_config = if (netvm_ip = zero_ip && our_ip = zero_ip) then (* Read network configuration from QubesDB *) Dao.read_network_config qubesDB >>= fun config -> From b1886e308ca9016a1c3d5d21b412f7833826b75c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 14 Oct 2024 12:54:42 +0200 Subject: [PATCH 2/3] update checksum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index 7d698f0..c54d999 100755 --- a/build-with.sh +++ b/build-with.sh @@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall . echo Building Firewall... $builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 5805e94755334af02fd4244b0b163c7a90fef9061d826e365db3be8adfe8abcc" +echo "SHA2 last known: 4b1f743bf4540bc8a9366cf8f23a78316e4f2d477af77962e50618753c4adf10" echo "(hashes should match for released versions)" From cf5cbc5e9014dd40be2a3ffa069504adbd1932cc Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Mon, 14 Oct 2024 17:10:11 +0200 Subject: [PATCH 3/3] restrict mirage upper bound --- config.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config.ml b/config.ml index 808d4ec..00ddc71 100644 --- a/config.ml +++ b/config.ml @@ -1,4 +1,4 @@ -(* mirage >= 4.8.0 & < 5.0.0 *) +(* mirage >= 4.8.0 & < 4.9.0 *) (* Copyright (C) 2017, Thomas Leonard See the README file for details. *)