From e36ffdb0a5edd2a24c3d0b8f2882fb6089defe46 Mon Sep 17 00:00:00 2001 From: Pierre Alain <65669679+palainp@users.noreply.github.com> Date: Tue, 7 May 2024 10:32:40 +0200 Subject: [PATCH 01/58] fix #195, a leading space was inserted by mistake --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index 112b40f..d60f9cf 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: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0" +echo "SHA2 last known: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0" echo "(hashes should match for released versions)" From 1cf272295410004f298edd661a91a8b5da188f04 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Apr 2024 17:31:12 +0100 Subject: [PATCH 02/58] drop astring dependency --- config.ml | 1 - dao.ml | 9 ++++----- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/config.ml b/config.ml index 89bb9bd..def0f87 100644 --- a/config.ml +++ b/config.ml @@ -18,7 +18,6 @@ let main = ~packages:[ package "vchan" ~min:"4.0.2"; package "cstruct"; - package "astring"; package "tcpip" ~min:"3.7.0"; package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; package ~min:"3.0.0" "ethernet"; diff --git a/dao.ml b/dao.ml index 7c6eecb..2361630 100644 --- a/dao.ml +++ b/dao.ml @@ -3,7 +3,6 @@ open Lwt.Infix open Qubes -open Astring let src = Logs.Src.create "dao" ~doc:"QubesDB data access" module Log = (val Logs.src_log src : Logs.LOG) @@ -66,26 +65,26 @@ let read_rules rules client_ip = number = 0;})] let vifs client domid = - match String.to_int domid with + match int_of_string_opt domid with | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return [] | Some domid -> let path = Printf.sprintf "backend/vif/%d" domid in Xen_os.Xs.immediate client (fun handle -> directory ~handle path >>= Lwt_list.filter_map_p (fun device_id -> - match String.to_int device_id with + match int_of_string_opt device_id with | None -> Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); Lwt.return_none | Some device_id -> let vif = { ClientVif.domid; device_id } in Lwt.try_bind (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 + let client_ip' = match String.split_on_char ' ' client_ip with | [] -> Log.err (fun m -> m "unexpected empty list"); "" | [ ip ] -> ip | ip::rest -> Log.warn (fun m -> m "ignoring IPs %s from %a, we support one IP per client" - (String.concat ~sep:" " rest) ClientVif.pp vif); + (String.concat " " rest) ClientVif.pp vif); ip in match Ipaddr.V4.of_string client_ip' with From acac245840d262a12f6a5e040d3c477ade49c315 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 6 May 2024 16:13:17 +0200 Subject: [PATCH 03/58] update to mirage-net-xen 2.1.4 --- config.ml | 3 +-- dispatcher.ml | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/config.ml b/config.ml index def0f87..74fa23f 100644 --- a/config.ml +++ b/config.ml @@ -22,8 +22,7 @@ let main = package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; package ~min:"3.0.0" "ethernet"; package "shared-memory-ring" ~min:"3.0.0"; - package ~min:"2.1.3" "netchannel"; - package "mirage-net-xen" ~min:"2.1.3"; + package "mirage-net-xen" ~min:"2.1.4"; package "ipaddr" ~min:"5.2.0"; package "mirage-qubes" ~min:"0.9.1"; package ~min:"3.0.1" "mirage-nat"; diff --git a/dispatcher.ml b/dispatcher.ml index 856f202..44b8728 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -1,6 +1,6 @@ open Lwt.Infix open Fw_utils -module Netback = Netchannel.Backend.Make (Netchannel.Xenstore.Make (Xen_os.Xs)) +module Netback = Backend.Make (Xenstore.Make (Xen_os.Xs)) module ClientEth = Ethernet.Make (Netback) module UplinkEth = Ethernet.Make (Netif) From a37584a720cfdf63fb18308b519a2aed0a550982 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 9 May 2024 12:51:23 +0200 Subject: [PATCH 04/58] update opam-repository commit --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 6f795d7..300ff72 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#4399f486aa6edefdc96d5e206a65ce42288ebfdd +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#f9f113a6bb242a13702859873fa0fcef9146eb6a RUN opam switch create myswitch 4.14.1 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build From 8e4c24bfbad9d00b42f531af095ae07da9a27dfd Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Mon, 6 May 2024 19:11:23 +0200 Subject: [PATCH 05/58] allow the firewall to use the router for dns requests (in rules) --- dispatcher.ml | 6 +++--- unikernel.ml | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 44b8728..fc21cdd 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -446,14 +446,14 @@ struct clients := !clients |> Dao.VifMap.add key cleanup))) let send_dns_client_query t ~src_port ~dst ~dst_port buf = - match t with + match t.uplink with | None -> Log.err (fun f -> f "No uplink interface"); Lwt.return (Error (`Msg "failure")) - | Some t -> ( + | Some uplink -> ( Lwt.catch (fun () -> - U.write ~src_port ~dst ~dst_port t.udp buf >|= function + U.write ~src_port ~dst ~dst_port uplink.udp buf >|= function | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure") diff --git a/unikernel.ml b/unikernel.ml index e0ceae8..b4e92c7 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -103,7 +103,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim ~uplink:None in - let send_dns_query = Dispatcher.send_dns_client_query None in + let send_dns_query = Dispatcher.send_dns_client_query router in let dns_mvar = Lwt_mvar.create_empty () in let nameservers = `Udp, [ config.Dao.dns, 53 ; config.Dao.dns2, 53 ] in let dns_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in From 8d67e9d47adbe589d05d8c884ce1d5aba270b596 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 9 May 2024 12:58:52 +0200 Subject: [PATCH 06/58] use OCaml 4.14.2 -- the latest LTS release --- Dockerfile | 2 +- Makefile.builder | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index 300ff72..8774680 100644 --- a/Dockerfile +++ b/Dockerfile @@ -24,7 +24,7 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes # latest versions. # taken from https://github.com/ocaml/opam-repository RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#f9f113a6bb242a13702859873fa0fcef9146eb6a -RUN opam switch create myswitch 4.14.1 +RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build ADD config.ml /tmp/orb-build/config.ml diff --git a/Makefile.builder b/Makefile.builder index 5d79a54..53b860d 100644 --- a/Makefile.builder +++ b/Makefile.builder @@ -1,5 +1,5 @@ MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen -OCAML_VERSION ?= 4.14.0 +OCAML_VERSION ?= 4.14.2 SOURCE_BUILD_DEP := firewall-build-dep firewall-build-dep: From 958b84430aad23c041cbe3dd7cff2bbc1f323160 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 10 May 2024 15:11:34 +0200 Subject: [PATCH 07/58] update checksum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index d60f9cf..80f75ed 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: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0" +echo "SHA2 last known: 0cbb202c1b93e10ad115c9e988f9384005656c0855ec9deaf05a5e9ac9972984" echo "(hashes should match for released versions)" From 9058d25dcc4d347095ca4c1554ea256de53edd4f Mon Sep 17 00:00:00 2001 From: Pierre Alain <65669679+palainp@users.noreply.github.com> Date: Sat, 11 May 2024 15:01:33 +0200 Subject: [PATCH 08/58] Update CHANGES.md --- CHANGES.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index ab776a3..1e6224f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +### 0.9.1 (2024-05-10) + +- Drop astring dependency, update mirage-net-xen, and OCaml 4.14.2 -- the + latest LTS release (#193, @hannesm) +- Allow the firewall to use domains requests in rules (#193, @palainp, + reported in the Qubes forum, fix confirmed by @neoniobium) + ### 0.9.0 (2024-04-24) - Fix an incorrect free memory estimation (fix in mirage/ocaml-solo5#135 From 6b0c18fd4e53015e59b5de88a5bf1146802ab145 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 9 Aug 2024 13:37:06 +0200 Subject: [PATCH 09/58] update opam repository in Dockerfile the reason behind this is that in the earlier commit, some urls point to unavailable urls. --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 8774680..f33b6e5 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#f9f113a6bb242a13702859873fa0fcef9146eb6a +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#13acffc3de9c22953d1e08bad3e56ee6e965eeed RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build From 5690052db49931d581a3b59e0ef47d8345e62f8c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 9 Aug 2024 13:50:19 +0200 Subject: [PATCH 10/58] new shasum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index 80f75ed..7d698f0 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: 0cbb202c1b93e10ad115c9e988f9384005656c0855ec9deaf05a5e9ac9972984" +echo "SHA2 last known: 5805e94755334af02fd4244b0b163c7a90fef9061d826e365db3be8adfe8abcc" echo "(hashes should match for released versions)" From 2acdd320ab754f756da72607b12d3ef60d24c016 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 14 Oct 2024 12:43:29 +0200 Subject: [PATCH 11/58] 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 12/58] 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 13/58] 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. *) From c7d8751b1c800726ac7f8e7bdd69d1a521f0e0c2 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 09:41:11 +0200 Subject: [PATCH 14/58] Use Lwt.Syntax and avoid some >>= fun () patterns --- dao.ml | 60 +++++++++++++++++++++++----------------------------- unikernel.ml | 11 ++++------ 2 files changed, 30 insertions(+), 41 deletions(-) diff --git a/dao.ml b/dao.ml index 2361630..78f0065 100644 --- a/dao.ml +++ b/dao.ml @@ -65,43 +65,35 @@ let read_rules rules client_ip = number = 0;})] let vifs client domid = + let open Lwt.Syntax in match int_of_string_opt domid with | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return [] | Some domid -> - let path = Printf.sprintf "backend/vif/%d" domid in - Xen_os.Xs.immediate client (fun handle -> - directory ~handle path >>= - Lwt_list.filter_map_p (fun device_id -> - match int_of_string_opt device_id with - | None -> Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); Lwt.return_none - | Some device_id -> - let vif = { ClientVif.domid; device_id } in - Lwt.try_bind - (fun () -> Xen_os.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) - (fun client_ip -> - let client_ip' = match String.split_on_char ' ' client_ip with - | [] -> Log.err (fun m -> m "unexpected empty list"); "" - | [ ip ] -> ip - | ip::rest -> - Log.warn (fun m -> m "ignoring IPs %s from %a, we support one IP per client" - (String.concat " " rest) ClientVif.pp vif); - ip - in - match Ipaddr.V4.of_string client_ip' with - | Ok ip -> Lwt.return (Some (vif, ip)) - | Error `Msg msg -> - Log.err (fun f -> f "Error parsing IP address of %a from %s: %s" - ClientVif.pp vif client_ip msg); - Lwt.return None - ) - (function - | Xs_protocol.Enoent _ -> Lwt.return None - | ex -> - Log.err (fun f -> f "Error getting IP address of %a: %s" - ClientVif.pp vif (Printexc.to_string ex)); - Lwt.return None - ) - )) + let path = Fmt.str "backend/vif/%d" domid in + let fn handle = + let* entries = directory ~handle path in + let fn device_id = match int_of_string_opt device_id with + | None -> + Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); + Lwt.return_none + | Some device_id -> + let vif = { ClientVif.domid; device_id } in + let fn () = + let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in + let[@warning "-8"] client_ip :: _ = String.split_on_char ' ' str in + Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in + Lwt.catch fn @@ function + | Xs_protocol.Enoent _ -> Lwt.return_none + | Ipaddr.Parse_error (msg, client_ip) -> + Log.err (fun f -> f "Error parsing IP address of %a from %s: %s" + ClientVif.pp vif client_ip msg); + Lwt.return_none + | exn -> + Log.err (fun f -> f "Error getting IP address of %a: %s" + ClientVif.pp vif (Printexc.to_string exn)); + Lwt.return_none in + Lwt_list.filter_map_p fn entries in + Xen_os.Xs.immediate client fn let watch_clients fn = Xen_os.Xs.make () >>= fun xs -> diff --git a/unikernel.ml b/unikernel.ml index b64fd4e..f0e12df 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -46,15 +46,12 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : (* Main unikernel entry point (called from auto-generated main.ml). *) let start _random _clock _time = + let open Lwt.Syntax in let start_time = Clock.elapsed_ns () in (* Start qrexec agent and QubesDB agent in parallel *) - let qrexec = RExec.connect ~domid:0 () in - let qubesDB = DB.connect ~domid:0 () in - - (* Wait for clients to connect *) - qrexec >>= fun qrexec -> + let* qrexec = RExec.connect ~domid:0 () in let agent_listener = RExec.listen qrexec Command.handler in - qubesDB >>= fun qubesDB -> + let* qubesDB = DB.connect ~domid:0 () in let startup_time = let (-) = Int64.sub in let time_in_ns = Clock.elapsed_ns () - start_time in @@ -93,7 +90,7 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Dao.print_network_config config ; (* Set up client-side networking *) - Client_eth.create config >>= fun clients -> + let* clients = Client_eth.create config in (* Set up routing between networks and hosts *) let router = Dispatcher.create From 98506f5b1b28c8b65d5da9b368f587807400f67b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:37:19 +0200 Subject: [PATCH 15/58] Rename some generic fn functions to what they explicitly do --- dao.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/dao.ml b/dao.ml index 78f0065..0e48a21 100644 --- a/dao.ml +++ b/dao.ml @@ -70,19 +70,19 @@ let vifs client domid = | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return [] | Some domid -> let path = Fmt.str "backend/vif/%d" domid in - let fn handle = - let* entries = directory ~handle path in - let fn device_id = match int_of_string_opt device_id with + let vifs_of_domain handle = + let* devices = directory ~handle path in + let ip_of_vif device_id = match int_of_string_opt device_id with | None -> Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); Lwt.return_none | Some device_id -> let vif = { ClientVif.domid; device_id } in - let fn () = + let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in let[@warning "-8"] client_ip :: _ = String.split_on_char ' ' str in Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in - Lwt.catch fn @@ function + Lwt.catch get_client_ip @@ function | Xs_protocol.Enoent _ -> Lwt.return_none | Ipaddr.Parse_error (msg, client_ip) -> Log.err (fun f -> f "Error parsing IP address of %a from %s: %s" @@ -92,8 +92,8 @@ let vifs client domid = Log.err (fun f -> f "Error getting IP address of %a: %s" ClientVif.pp vif (Printexc.to_string exn)); Lwt.return_none in - Lwt_list.filter_map_p fn entries in - Xen_os.Xs.immediate client fn + Lwt_list.filter_map_p ip_of_vif devices in + Xen_os.Xs.immediate client vifs_of_domain let watch_clients fn = Xen_os.Xs.make () >>= fun xs -> From e179ee36b3d33fd3286ec0401202873a31c5b480 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:39:37 +0200 Subject: [PATCH 16/58] Use List.hd instead of [@warning "-8"] --- dao.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dao.ml b/dao.ml index 0e48a21..f008d57 100644 --- a/dao.ml +++ b/dao.ml @@ -80,7 +80,7 @@ let vifs client domid = let vif = { ClientVif.domid; device_id } in let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in - let[@warning "-8"] client_ip :: _ = String.split_on_char ' ' str in + let client_ip = List.hd (String.split_on_char ' ' str) in Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in Lwt.catch get_client_ip @@ function | Xs_protocol.Enoent _ -> Lwt.return_none From ad1afe99eeda8d7f7ca799e6fa1b891a40a60122 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:40:08 +0200 Subject: [PATCH 17/58] Break the line before the 'in' for a multi-line 'let ... in' --- dao.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/dao.ml b/dao.ml index f008d57..3e57781 100644 --- a/dao.ml +++ b/dao.ml @@ -81,7 +81,8 @@ let vifs client domid = let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in let client_ip = List.hd (String.split_on_char ' ' str) in - Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in + Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) + in Lwt.catch get_client_ip @@ function | Xs_protocol.Enoent _ -> Lwt.return_none | Ipaddr.Parse_error (msg, client_ip) -> @@ -91,8 +92,10 @@ let vifs client domid = | exn -> Log.err (fun f -> f "Error getting IP address of %a: %s" ClientVif.pp vif (Printexc.to_string exn)); - Lwt.return_none in - Lwt_list.filter_map_p ip_of_vif devices in + Lwt.return_none + in + Lwt_list.filter_map_p ip_of_vif devices + in Xen_os.Xs.immediate client vifs_of_domain let watch_clients fn = From 3dc545681de71e5df436761ad301a5770d1e5b4b Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:47:10 +0200 Subject: [PATCH 18/58] Add a comment about our usage of List.hd (which can fail) and String.split_on_char --- dao.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/dao.ml b/dao.ml index 3e57781..2e94660 100644 --- a/dao.ml +++ b/dao.ml @@ -81,6 +81,8 @@ let vifs client domid = let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in let client_ip = List.hd (String.split_on_char ' ' str) in + (* XXX(dinosaure): it's safe to use [List.hd] here, + [String.split_on_char] can not return an empty list. *) Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in Lwt.catch get_client_ip @@ function From a7cb153ee17246dc850f01b96121d868621df520 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 11:54:07 +0200 Subject: [PATCH 19/58] Use Ipaddr.V4.Map instead of our own IpMap (the first is available since ipaddr.5.2.0) --- client_eth.ml | 16 ++++++++-------- fw_utils.ml | 8 -------- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/client_eth.ml b/client_eth.ml index de41f70..fc0b01a 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -8,7 +8,7 @@ let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients module Log = (val Logs.src_log src : Logs.LOG) type t = { - mutable iface_of_ip : client_link IpMap.t; + mutable iface_of_ip : client_link Ipaddr.V4.Map.t; changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *) my_ip : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *) } @@ -21,21 +21,21 @@ type host = let create config = let changed = Lwt_condition.create () in let my_ip = config.Dao.our_ip in - Lwt.return { iface_of_ip = IpMap.empty; my_ip; changed } + Lwt.return { iface_of_ip = Ipaddr.V4.Map.empty; my_ip; changed } let client_gw t = t.my_ip let add_client t iface = let ip = iface#other_ip in let rec aux () = - match IpMap.find ip t.iface_of_ip with + match Ipaddr.V4.Map.find_opt ip t.iface_of_ip with | Some old -> (* Wait for old client to disappear before adding one with the same IP address. Otherwise, its [remove_client] call will remove the new client instead. *) Log.info (fun f -> f ~header:iface#log_header "Waiting for old client %s to go away before accepting new one" old#log_header); Lwt_condition.wait t.changed >>= aux | None -> - t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface; + t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.add ip iface; Lwt_condition.broadcast t.changed (); Lwt.return_unit in @@ -43,11 +43,11 @@ let add_client t iface = let remove_client t iface = let ip = iface#other_ip in - assert (IpMap.mem ip t.iface_of_ip); - t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip; + assert (Ipaddr.V4.Map.mem ip t.iface_of_ip); + t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.remove ip; Lwt_condition.broadcast t.changed () -let lookup t ip = IpMap.find ip t.iface_of_ip +let lookup t ip = Ipaddr.V4.Map.find_opt ip t.iface_of_ip let classify t ip = match ip with @@ -79,7 +79,7 @@ module ARP = struct (* We're now treating client networks as point-to-point links, so we no longer respond on behalf of other clients. *) (* - else match IpMap.find ip t.net.iface_of_ip with + else match Ipaddr.V4.Map.find_opt ip t.net.iface_of_ip with | Some client_iface -> Some client_iface#other_mac | None -> None *) diff --git a/fw_utils.ml b/fw_utils.ml index 0307810..f20c63a 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -3,14 +3,6 @@ (** General utility functions. *) -module IpMap = struct - include Map.Make(Ipaddr.V4) - let find x map = - try Some (find x map) - with Not_found -> None - | _ -> Logs.err( fun f -> f "uncaught exception in find...%!"); None -end - (** An Ethernet interface. *) class type interface = object method my_mac : Macaddr.t From 12ed2b268dbf672a4771bc3b04c133a3ea9a79c4 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Wed, 22 May 2024 16:05:29 +0200 Subject: [PATCH 20/58] Replace the Lwt.async into the right context and localize the global clients map We currently try to spawn 2 fibers [qubes_updated] and [listener] per clients and we already finalise them correctly if the client is disconnected. However, the Lwt.async is localized into add_client instead of where we attach a finalisers for these tasks. The first objective of this patch is to be sure that the Lwt.async is near where we registerd cancellation of these tasks. The second part is to localize the global clients to avoid the ability to read/write on it somewhere else. Only Dispatcher.watch_clients uses it - so it corresponds to a free variable of the Dispatcher.watch_clients closure. --- dao.ml | 2 +- dao.mli | 2 +- dispatcher.ml | 77 ++++++++++++++++++++++++++++----------------------- 3 files changed, 44 insertions(+), 37 deletions(-) diff --git a/dao.ml b/dao.ml index 2e94660..27b8bda 100644 --- a/dao.ml +++ b/dao.ml @@ -113,7 +113,7 @@ let watch_clients fn = end >>= fun items -> Xen_os.Xs.make () >>= fun xs -> Lwt_list.map_p (vifs xs) items >>= fun items -> - fn (List.concat items |> VifMap.of_list); + fn (List.concat items |> VifMap.of_list) >>= fun () -> (* Wait for further updates *) Lwt.fail Xs_protocol.Eagain ) diff --git a/dao.mli b/dao.mli index bff4cbf..c278d16 100644 --- a/dao.mli +++ b/dao.mli @@ -15,7 +15,7 @@ module VifMap : sig val find : key -> 'a t -> 'a option end -val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t +val watch_clients : (Ipaddr.V4.t VifMap.t -> unit Lwt.t) -> 'a Lwt.t (** [watch_clients fn] calls [fn clients] with the list of backend clients in XenStore, and again each time XenStore updates. *) diff --git a/dispatcher.ml b/dispatcher.ml index 3768863..9ffcc5b 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -17,8 +17,6 @@ struct module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) module U = Udp.Make (I) (R) - let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty - class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in @@ -344,11 +342,12 @@ struct (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers - ~client_ip ~router ~cleanup_tasks qubesDB = - Netback.make ~domid ~device_id >>= fun backend -> + ~client_ip ~router ~cleanup_tasks qubesDB () = + let open Lwt.Syntax in + let* backend = Netback.make ~domid ~device_id in Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); - ClientEth.connect backend >>= fun eth -> + let* eth = ClientEth.connect backend in let client_mac = Netback.frontend_mac backend in let client_eth = router.clients in let gateway_ip = Client_eth.client_gw client_eth in @@ -404,46 +403,54 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - Lwt.pick [ qubesdb_updater; listener ] + (* XXX(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] + will cancel them if the client is disconnected. *) + Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); + Lwt.return_unit (** A new client VM has been found in XenStore. Find its interface and connect to it. *) let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = + let open Lwt.Syntax in let cleanup_tasks = Cleanup.create () in Log.info (fun f -> f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip); - Lwt.async (fun () -> - Lwt.catch - (fun () -> - add_vif get_ts vif dns_client dns_servers ~client_ip ~router - ~cleanup_tasks qubesDB) - (fun ex -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string ex)); - Lwt.return_unit)); - cleanup_tasks + let* () = + Lwt.catch (add_vif get_ts vif dns_client dns_servers ~client_ip ~router + ~cleanup_tasks qubesDB) + @@ fun exn -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string exn)); + Lwt.return_unit + in + Lwt.return cleanup_tasks (** Watch XenStore for notifications of new clients. *) let wait_clients get_ts dns_client dns_servers qubesDB router = - Dao.watch_clients (fun new_set -> - (* Check for removed clients *) - !clients - |> Dao.VifMap.iter (fun key cleanup -> - if not (Dao.VifMap.mem key new_set) then ( - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup)); - (* Check for added clients *) - new_set - |> Dao.VifMap.iter (fun key ip_addr -> - if not (Dao.VifMap.mem key !clients) then ( - let cleanup = - add_client get_ts dns_client dns_servers ~router key ip_addr - qubesDB - in - Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); - clients := !clients |> Dao.VifMap.add key cleanup))) + let open Lwt.Syntax in + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in + Dao.watch_clients @@ fun new_set -> + (* Check for removed clients *) + let clean_up_clients key cleanup = + if not (Dao.VifMap.mem key new_set) then begin + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup + end + in + Dao.VifMap.iter clean_up_clients !clients; + (* Check for added clients *) + let rec go seq = match Seq.uncons seq with + | None -> Lwt.return_unit + | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> + let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in + Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); + clients := Dao.VifMap.add key cleanup !clients; + go seq + | Some (_, seq) -> go seq + in + go (Dao.VifMap.to_seq new_set) let send_dns_client_query t ~src_port ~dst ~dst_port buf = match t.uplink with From 9156d580df8487d8a18a679797a8ee5850828c53 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:37:50 +0200 Subject: [PATCH 21/58] cleanup whitespace --- dispatcher.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dispatcher.ml b/dispatcher.ml index 9ffcc5b..9dd374e 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -447,7 +447,7 @@ struct let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); clients := Dao.VifMap.add key cleanup !clients; - go seq + go seq | Some (_, seq) -> go seq in go (Dao.VifMap.to_seq new_set) From ceb712ec60c621453a042045d57fa72ed9217b98 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:39:35 +0200 Subject: [PATCH 22/58] minor: reword XXX to NOTE --- dao.ml | 2 +- dispatcher.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dao.ml b/dao.ml index 27b8bda..9344c1f 100644 --- a/dao.ml +++ b/dao.ml @@ -81,7 +81,7 @@ let vifs client domid = let get_client_ip () = let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in let client_ip = List.hd (String.split_on_char ' ' str) in - (* XXX(dinosaure): it's safe to use [List.hd] here, + (* NOTE(dinosaure): it's safe to use [List.hd] here, [String.split_on_char] can not return an empty list. *) Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) in diff --git a/dispatcher.ml b/dispatcher.ml index 9dd374e..60927f6 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -403,7 +403,7 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - (* XXX(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] + (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] will cancel them if the client is disconnected. *) Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); Lwt.return_unit From e2a0b333520a86eef91673588de114770494a1ca Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:44:31 +0200 Subject: [PATCH 23/58] use a newer opam, 2.2.1, instead of 2.1.5 --- Dockerfile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index 165530f..2cecb45 100644 --- a/Dockerfile +++ b/Dockerfile @@ -12,10 +12,10 @@ RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20240419T111010Z bookworm-security main\n" >> /etc/apt/sources.list RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev -RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.1.5/opam-2.1.5-i686-linux && chmod 755 /usr/bin/opam +RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.2.1/opam-2.2.1-i686-linux && chmod 755 /usr/bin/opam # taken from https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh RUN test `sha512sum /usr/bin/opam | cut -d' ' -f1` = \ -"38802b3079eeceb27aab3465bfd0f9f05a710dccf9487eb35fa2c02fbaf9a0659e1447aa19dd36df9cd01f760229de28c523c08c1c86a3aa3f5e25dbe7b551dd" || exit +"bf16d573137835ce9abbcf6b99cb94a1da69ab58804a4de7c90233f0b354d5e68e9c47ee16670ca9d59866d58c7db345d9723e6eb5fc3a1cb8dca371f0e90225" || exit ENV OPAMROOT=/tmp ENV OPAMCONFIRMLEVEL=unsafe-yes From 3bb13f4c2115809c85ce355f9854f0810c2fe886 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:48:14 +0200 Subject: [PATCH 24/58] update opam repository commit to use solo5 0.9 and mirage 4.8.1 --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 165530f..c693045 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#26c09ff1da6a07b20a0f9474e3a6ed6315c6388b +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#5d3f0d1d655199e596a1e785e69fae8fad78cad3 RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build From 1406855a9e901aa4a71a5ba0a333e5368a33a970 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 15 Oct 2024 21:49:57 +0200 Subject: [PATCH 25/58] update checksum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index c54d999..5252f23 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: 4b1f743bf4540bc8a9366cf8f23a78316e4f2d477af77962e50618753c4adf10" +echo "SHA2 last known: 2392386d9056b17a648f26b0c5d1c72b93f8a197964c670b2b45e71707727317" echo "(hashes should match for released versions)" From fc75cce37cc1a84381f9a55328f7384571f7677a Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 16 Oct 2024 14:51:38 +0200 Subject: [PATCH 26/58] update shasum --- build-with.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with.sh b/build-with.sh index 5252f23..eba233e 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: 2392386d9056b17a648f26b0c5d1c72b93f8a197964c670b2b45e71707727317" +echo "SHA2 last known: 78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc" echo "(hashes should match for released versions)" From c738753045d5df9dec862b0f714b991a24f1254b Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 07:30:20 +0200 Subject: [PATCH 27/58] update CHANGES --- CHANGES.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 1e6224f..dac6405 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,9 @@ +### 0.9.2 (2024-10-16) + +- Code refactoring and improvements (#197, @dinosaure) +- Build tooling updates: opam 2.2.1, solo5 0.9, mirage 4.8.1 (#199, #201, #202, + #203, @hannesm) + ### 0.9.1 (2024-05-10) - Drop astring dependency, update mirage-net-xen, and OCaml 4.14.2 -- the From de9a6ccc86c525a3dbe290f2f5984e18af7e97d5 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 07:45:42 +0200 Subject: [PATCH 28/58] WIP: update the salt script + releases files --- .github/workflows/docker.yml | 2 +- .github/workflows/podman.yml | 2 +- Dockerfile | 2 +- Makefile.user | 11 +++-------- ...DownloadAndInstallMirageFirewallInQubes.sls | 18 ++++++++++-------- build-with.sh | 7 ++++--- qubes-firewall-release.sha256 | 1 + qubes-firewall.sha256 | 1 + 8 files changed, 22 insertions(+), 22 deletions(-) create mode 100644 qubes-firewall-release.sha256 create mode 100644 qubes-firewall.sha256 diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index 53b3324..fdf17d7 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -23,7 +23,7 @@ jobs: - run: ./build-with.sh docker - - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen) = $(cat qubes-firewall.sha256) ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact uses: actions/upload-artifact@v3 diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index fba19eb..f8f8c3f 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -23,7 +23,7 @@ jobs: - run: ./build-with.sh podman - - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen | cut -d " " -f 1) = $(grep "SHA2 last known" build-with.sh | rev | cut -d ":" -f 1 | rev | cut -d "\"" -f 1 | tr -d " ") ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen) = $(cat qubes-firewall.sha256) ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact uses: actions/upload-artifact@v3 diff --git a/Dockerfile b/Dockerfile index 2c2f732..edf9e96 100644 --- a/Dockerfile +++ b/Dockerfile @@ -32,4 +32,4 @@ WORKDIR /tmp/orb-build CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\ opam-overlays:https://github.com/dune-universe/opam-overlays.git#4e75ee36715b27550d5bdb87686bb4ae4c9e89c4,\ mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \ -&& make depend && make tar' +&& make depend && make unikernel' diff --git a/Makefile.user b/Makefile.user index 00890f6..7188982 100644 --- a/Makefile.user +++ b/Makefile.user @@ -1,13 +1,8 @@ -tar: build - rm -rf _build/mirage-firewall - mkdir _build/mirage-firewall +unikernel: build cp dist/qubes-firewall.xen dist/qubes-firewall.xen.debug strip dist/qubes-firewall.xen - 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.sh mirage-firewall - sha256sum mirage-firewall.tar.bz2 > mirage-firewall.sha256 + cp dist/qubes-firewall.xen . + sha256sum qubes-firewall.xen fetchmotron: qubes_firewall.xen test-mirage qubes_firewall.xen mirage-fw-test & diff --git a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls index dc83f20..cfb4a0e 100644 --- a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls +++ b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls @@ -10,7 +10,8 @@ {% set DownloadVM = "DownloadVmMirage" %} {% set MirageFW = "sys-mirage-fw" %} {% set GithubUrl = "https://github.com/mirage/qubes-mirage-firewall" %} -{% set Filename = "mirage-firewall.tar.bz2" %} +{% set Kernel = "qubes-firewall.xen" %} +{% set Shasum = "qubes-firewall-release.sha256" %} {% set MirageInstallDir = "/var/lib/qubes/vm-kernels/mirage-firewall" %} #download and install the latest version @@ -28,13 +29,14 @@ create-downloader-VM: - template: {{ DownloadVMTemplate }} - include-in-backups: false -{% set DownloadBinary = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Filename %} +{% set DownloadBinary = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Kernel %} +{% set DownloadShasum = GithubUrl ~ "/releases/download/" ~ Release ~ "/" ~ Shasum %} download-and-unpack-in-DownloadVM4mirage: cmd.run: - names: - qvm-run --pass-io {{ DownloadVM }} {{ "curl -L -O " ~ DownloadBinary }} - - qvm-run --pass-io {{ DownloadVM }} {{ "tar -xvjf " ~ Filename }} + - qvm-run --pass-io {{ DownloadVM }} {{ "curl -L -O " ~ DownloadShasum }} - require: - create-downloader-VM @@ -42,15 +44,15 @@ download-and-unpack-in-DownloadVM4mirage: check-checksum-in-DownloadVM: cmd.run: - names: - - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of last build on github:\\\";curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\"\"" }} - - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1\"" }} - - qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(curl -s https://raw.githubusercontent.com/mirage/qubes-mirage-firewall/main/build-with.sh | grep \\\"SHA2 last known:\\\" | cut -d\' \' -f5 | tr -d \\\\\\\") <(sha256sum ~/mirage-firewall/vmlinuz | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }} #~/mirage-firewall/modules.img + - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of release on github:\\\";cat " ~ Shasum ~ " | cut -d\' \' -f1\"" }} + - qvm-run --pass-io {{ DownloadVM }} {{ "\"echo \\\"Checksum of downloaded local file:\\\";sha256sum " ~ Kernel ~ " | cut -d\' \' -f1\"" }} + - qvm-run --pass-io {{ DownloadVM }} {{ "\"diff <(cat " ~ Shasum ~ " | cut -d\' \' -f1) <(sha256sum " ~ Kernel ~ " | cut -d\' \' -f1) && echo \\\"Checksums DO match.\\\" || (echo \\\"Checksums do NOT match.\\\";exit 101)\"" }} - require: - download-and-unpack-in-DownloadVM4mirage copy-mirage-kernel-to-dom0: cmd.run: - - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} "cat ~/mirage-firewall/vmlinuz" > {{ MirageInstallDir ~ "/vmlinuz" }} + - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} "cat " ~ Kernel > {{ MirageInstallDir ~ "/" ~ Kernel }} - require: - download-and-unpack-in-DownloadVM4mirage - check-checksum-in-DownloadVM @@ -90,7 +92,7 @@ create-sys-mirage-fw: cleanup-in-DownloadVM: cmd.run: - names: - - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Filename ~ "; rm -R ~/mirage-firewall" }}" + - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Kernel ~ " " ~ Shasum }}" - require: - create-initramfs diff --git a/build-with.sh b/build-with.sh index eba233e..728ab1f 100755 --- a/build-with.sh +++ b/build-with.sh @@ -19,6 +19,7 @@ echo Building $builder image with dependencies.. $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: 78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc" -echo "(hashes should match for released versions)" +echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen | cut -d' ' -f1)" +echo "SHA2 current head: $(cat qubes-firewall.sha256 | cut -d' ' -f1)" +echo "SHA2 last release: $(cat qubes-firewall-release.sha256 | cut -d' ' -f1)" +echo "(hashes should match for head versions)" diff --git a/qubes-firewall-release.sha256 b/qubes-firewall-release.sha256 new file mode 100644 index 0000000..b89e36f --- /dev/null +++ b/qubes-firewall-release.sha256 @@ -0,0 +1 @@ +78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc dist/qubes-firewall.xen diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 new file mode 100644 index 0000000..b89e36f --- /dev/null +++ b/qubes-firewall.sha256 @@ -0,0 +1 @@ +78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc dist/qubes-firewall.xen From 887f2d524c5c9843487b921cf769ee5c746e01b0 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 08:09:35 +0200 Subject: [PATCH 29/58] fix string comparison in github actions --- .github/workflows/docker.yml | 2 +- .github/workflows/podman.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index fdf17d7..4b18223 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -23,7 +23,7 @@ jobs: - run: ./build-with.sh docker - - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen) = $(cat qubes-firewall.sha256) ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact uses: actions/upload-artifact@v3 diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index f8f8c3f..6f6b8f5 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -23,7 +23,7 @@ jobs: - run: ./build-with.sh podman - - run: sh -exc 'if [ $(sha256sum dist/qubes-firewall.xen) = $(cat qubes-firewall.sha256) ]; then echo "SHA256 MATCHES"; else exit 42; fi' + - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact uses: actions/upload-artifact@v3 From e7eb1f2e3b2d5fd707d0893aae0feccf653c6b70 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 08:21:49 +0200 Subject: [PATCH 30/58] fix artifact uploads --- .github/workflows/docker.yml | 4 ++-- .github/workflows/podman.yml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index 4b18223..1f1dcda 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -28,5 +28,5 @@ jobs: - name: Upload Artifact uses: actions/upload-artifact@v3 with: - name: mirage-firewall.tar.bz2 - path: mirage-firewall.tar.bz2 + name: qubes-firewall.xen + path: qubes-firewall.xen diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index 6f6b8f5..0fdab2a 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -28,5 +28,5 @@ jobs: - name: Upload Artifact uses: actions/upload-artifact@v3 with: - name: mirage-firewall.tar.bz2 - path: mirage-firewall.tar.bz2 + name: qubes-firewall.xen + path: qubes-firewall.xen From 493608111256569f1485d1c947bf5a78de5cbd70 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 17 Oct 2024 13:14:53 +0200 Subject: [PATCH 31/58] add a LICENSE file (ISC) --- LICENSE.md | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 LICENSE.md diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..ff93dbd --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,15 @@ +ISC License + +Copyright (X) 2015-2024, the Qubes Mirage Firewall authors + +Permission to use, copy, modify, and distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. From 07f05f14085542c9da71ea228ce53f2f8f1b0d1c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 17 Oct 2024 13:56:28 +0200 Subject: [PATCH 32/58] use a BSD 2 clause license remove the LICENSE section from the README --- LICENSE.md | 32 ++++++++++++++++++++------------ README.md | 13 ------------- 2 files changed, 20 insertions(+), 25 deletions(-) diff --git a/LICENSE.md b/LICENSE.md index ff93dbd..23ec3d0 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,15 +1,23 @@ -ISC License - Copyright (X) 2015-2024, the Qubes Mirage Firewall authors +All rights reserved. -Permission to use, copy, modify, and distribute this software for any -purpose with or without fee is hereby granted, provided that the above -copyright notice and this permission notice appear in all copies. +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: -THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/README.md b/README.md index 2a37c53..fa83f2a 100644 --- a/README.md +++ b/README.md @@ -210,19 +210,6 @@ To use it, run `test.sh` and follow the instructions to set up the test environm See [issues tagged "security"](https://github.com/mirage/qubes-mirage-firewall/issues?utf8=%E2%9C%93&q=label%3Asecurity+) for security advisories affecting the firewall. -# LICENSE - -Copyright (c) 2019, Thomas Leonard -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - [test-mirage]: https://github.com/talex5/qubes-test-mirage [mirage-qubes]: https://github.com/mirage/mirage-qubes [A Unikernel Firewall for QubesOS]: http://roscidus.com/blog/blog/2016/01/01/a-unikernel-firewall-for-qubesos/ From 64b45e8be6fb4e57171d188e771aa82e0366a611 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 17 Oct 2024 14:01:31 +0200 Subject: [PATCH 33/58] README.md: refer to LICENSE.md --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index fa83f2a..8f2c00f 100644 --- a/README.md +++ b/README.md @@ -210,6 +210,10 @@ To use it, run `test.sh` and follow the instructions to set up the test environm See [issues tagged "security"](https://github.com/mirage/qubes-mirage-firewall/issues?utf8=%E2%9C%93&q=label%3Asecurity+) for security advisories affecting the firewall. +# LICENSE + +See [LICENSE.md](https://github.com/mirage/qubes-mirage-firewall/blob/main/LICENSE.md) + [test-mirage]: https://github.com/talex5/qubes-test-mirage [mirage-qubes]: https://github.com/mirage/mirage-qubes [A Unikernel Firewall for QubesOS]: http://roscidus.com/blog/blog/2016/01/01/a-unikernel-firewall-for-qubesos/ From 8817893c62eb77aaf6ea567d4851c04e887f1f41 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 17 Oct 2024 13:37:12 +0200 Subject: [PATCH 34/58] update GH action checkout version update salt script --- .github/workflows/docker.yml | 2 +- .github/workflows/podman.yml | 2 +- SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls | 9 ++++----- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index 1f1dcda..9a8216d 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -19,7 +19,7 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - run: ./build-with.sh docker diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index 0fdab2a..f62e075 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -19,7 +19,7 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - run: ./build-with.sh podman diff --git a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls index cfb4a0e..f9886b9 100644 --- a/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls +++ b/SaltScriptToDownloadAndInstallMirageFirewallInQubes.sls @@ -17,7 +17,7 @@ #download and install the latest version {% set Release = salt['cmd.shell']("qvm-run --dispvm " ~ DispVM ~ " --pass-io \"curl --silent --location -o /dev/null -w %{url_effective} " ~ GithubUrl ~ "/releases/latest | rev | cut -d \"/\" -f 1 | rev\"") %} -{% if Release != salt['cmd.shell']("[ ! -f " ~ MirageInstallDir ~ "/version.txt" ~ " ] && touch " ~ MirageInstallDir ~ "/version.txt" ~ ";cat " ~ MirageInstallDir ~ "/version.txt") %} +{% if Release != salt['cmd.shell']("test -e " ~ MirageInstallDir ~ "/version.txt" ~ " || mkdir " ~ MirageInstallDir ~ " ; touch " ~ MirageInstallDir ~ "/version.txt" ~ " ; cat " ~ MirageInstallDir ~ "/version.txt") %} create-downloader-VM: qvm.vm: @@ -52,15 +52,14 @@ check-checksum-in-DownloadVM: copy-mirage-kernel-to-dom0: cmd.run: - - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} "cat " ~ Kernel > {{ MirageInstallDir ~ "/" ~ Kernel }} + - name: mkdir -p {{ MirageInstallDir }}; qvm-run --pass-io --no-gui {{ DownloadVM }} {{ "cat " ~ Kernel }} > {{ MirageInstallDir ~ "/vmlinuz" }} - require: - download-and-unpack-in-DownloadVM4mirage - check-checksum-in-DownloadVM -create-initramfs: +update-version: cmd.run: - names: - - gzip -n9 < /dev/null > {{ MirageInstallDir ~ "/initramfs" }} - echo {{ Release }} > {{ MirageInstallDir ~ "/version.txt" }} - require: - copy-mirage-kernel-to-dom0 @@ -94,7 +93,7 @@ cleanup-in-DownloadVM: - names: - qvm-run -a --pass-io --no-gui {{ DownloadVM }} "{{ "rm " ~ Kernel ~ " " ~ Shasum }}" - require: - - create-initramfs + - update-version remove-DownloadVM4mirage: qvm.absent: From 923719f306ad653060dd5c1395e20495839ef7d0 Mon Sep 17 00:00:00 2001 From: Pierre Alain <65669679+palainp@users.noreply.github.com> Date: Wed, 27 Nov 2024 17:05:39 +0100 Subject: [PATCH 35/58] Update installation instructions in README.md This commit clarify the installation instructions for the first time (for context: https://github.com/mirage/qubes-mirage-firewall/commit/54a964e446207d7954634dd712452e9d10eb430e#commitcomment-149513774) --- README.md | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index 8f2c00f..40e65bd 100644 --- a/README.md +++ b/README.md @@ -58,20 +58,15 @@ However, it should still work fine. ## Deploy ### Manual deployment -If you want to deploy manually, unpack `mirage-firewall.tar.bz2` in domU. The tarball contains `vmlinuz`, -which is the unikernel itself, plus a dummy initramfs file that Qubes requires: - - [user@dev ~]$ tar xjf mirage-firewall.tar.bz2 - -Copy `vmlinuz` to `/var/lib/qubes/vm-kernels/mirage-firewall` directory in dom0, e.g. (if `dev` is the AppVM where you built it): +If you want to deploy manually, you just need to download `qubes-firewall.xen` and +`qubes-firewall.sha256` in domU and check that the `.xen` file has a corresponding +hashsum. `qubes-firewall.xen` is the unikernel itself and should be copied to +`vmlinuz` in the `/var/lib/qubes/vm-kernels/mirage-firewall` directory in dom0, e.g. +(if `dev` is the AppVM where you built it): [tal@dom0 ~]$ mkdir -p /var/lib/qubes/vm-kernels/mirage-firewall/ [tal@dom0 ~]$ cd /var/lib/qubes/vm-kernels/mirage-firewall/ - [tal@dom0 mirage-firewall]$ qvm-run -p dev 'cat mirage-firewall/vmlinuz' > vmlinuz - -Finally, create [a dummy file required by Qubes OS](https://github.com/QubesOS/qubes-issues/issues/5516): - - [tal@dom0 mirage-firewall]$ gzip -n9 < /dev/null > initramfs + [tal@dom0 mirage-firewall]$ qvm-run -p dev 'cat mirage-firewall/qubes-firewall.xen' > vmlinuz Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-firewall` kernel you added above From a5d61cb034c1ffe4aaee6b692ef75d85baf7a89f Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Fri, 20 Dec 2024 08:25:36 +0100 Subject: [PATCH 36/58] revert client connexion management --- dispatcher.ml | 70 +++++++++++++++++++++++++-------------------------- 1 file changed, 34 insertions(+), 36 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 60927f6..4803679 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -17,6 +17,8 @@ struct module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) module U = Udp.Make (I) (R) + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty + class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in @@ -342,7 +344,7 @@ struct (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers - ~client_ip ~router ~cleanup_tasks qubesDB () = + ~client_ip ~router ~cleanup_tasks qubesDB = let open Lwt.Syntax in let* backend = Netback.make ~domid ~device_id in Log.info (fun f -> @@ -405,8 +407,7 @@ struct Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] will cancel them if the client is disconnected. *) - Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); - Lwt.return_unit + Lwt.pick [ qubesdb_updater; listener ] (** A new client VM has been found in XenStore. Find its interface and connect to it. *) let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = @@ -415,42 +416,39 @@ struct Log.info (fun f -> f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip); - let* () = - Lwt.catch (add_vif get_ts vif dns_client dns_servers ~client_ip ~router - ~cleanup_tasks qubesDB) - @@ fun exn -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string exn)); - Lwt.return_unit - in - Lwt.return cleanup_tasks + Lwt.async (fun () -> + Lwt.catch + (fun () -> + add_vif get_ts vif dns_client dns_servers ~client_ip ~router + ~cleanup_tasks qubesDB) + (fun ex -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string ex)); + Lwt.return_unit)); + cleanup_tasks (** Watch XenStore for notifications of new clients. *) let wait_clients get_ts dns_client dns_servers qubesDB router = - let open Lwt.Syntax in - let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in - Dao.watch_clients @@ fun new_set -> - (* Check for removed clients *) - let clean_up_clients key cleanup = - if not (Dao.VifMap.mem key new_set) then begin - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup - end - in - Dao.VifMap.iter clean_up_clients !clients; - (* Check for added clients *) - let rec go seq = match Seq.uncons seq with - | None -> Lwt.return_unit - | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> - let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in - Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); - clients := Dao.VifMap.add key cleanup !clients; - go seq - | Some (_, seq) -> go seq - in - go (Dao.VifMap.to_seq new_set) + Dao.watch_clients (fun new_set -> + (* Check for removed clients *) + !clients + |> Dao.VifMap.iter (fun key cleanup -> + if not (Dao.VifMap.mem key new_set) then ( + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup)); + (* Check for added clients *) + new_set + |> Dao.VifMap.iter (fun key ip_addr -> + if not (Dao.VifMap.mem key !clients) then ( + let cleanup = + add_client get_ts dns_client dns_servers ~router key ip_addr + qubesDB + in + Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); + clients := !clients |> Dao.VifMap.add key cleanup)); + Lwt.return_unit) let send_dns_client_query t ~src_port ~dst ~dst_port buf = match t.uplink with From d8a20eadc8c43e153130737cfda854eeae6e71f9 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Sun, 22 Dec 2024 19:15:36 +0100 Subject: [PATCH 37/58] get back add_client with local clients map --- dispatcher.ml | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 4803679..45db140 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -17,8 +17,6 @@ struct module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) module U = Udp.Make (I) (R) - let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty - class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in @@ -411,7 +409,6 @@ struct (** A new client VM has been found in XenStore. Find its interface and connect to it. *) let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = - let open Lwt.Syntax in let cleanup_tasks = Cleanup.create () in Log.info (fun f -> f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp @@ -430,25 +427,28 @@ struct (** Watch XenStore for notifications of new clients. *) let wait_clients get_ts dns_client dns_servers qubesDB router = - Dao.watch_clients (fun new_set -> - (* Check for removed clients *) - !clients - |> Dao.VifMap.iter (fun key cleanup -> - if not (Dao.VifMap.mem key new_set) then ( - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup)); - (* Check for added clients *) - new_set - |> Dao.VifMap.iter (fun key ip_addr -> - if not (Dao.VifMap.mem key !clients) then ( - let cleanup = - add_client get_ts dns_client dns_servers ~router key ip_addr - qubesDB - in - Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); - clients := !clients |> Dao.VifMap.add key cleanup)); - Lwt.return_unit) + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in + Dao.watch_clients @@ fun new_set -> + (* Check for removed clients *) + let clean_up_clients key cleanup = + if not (Dao.VifMap.mem key new_set) then begin + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup + end + in + Dao.VifMap.iter clean_up_clients !clients; + (* Check for added clients *) + let rec go seq = match Seq.uncons seq with + | None -> Lwt.return_unit + | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> + let cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in + Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); + clients := Dao.VifMap.add key cleanup !clients; + go seq + | Some (_, seq) -> go seq + in + go (Dao.VifMap.to_seq new_set) let send_dns_client_query t ~src_port ~dst ~dst_port buf = match t.uplink with From 3bc01998a6bcc50990a95f9050e1321cd0c2c854 Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 31 Dec 2024 11:23:06 -0500 Subject: [PATCH 38/58] add_client can return a Lwt promise --- dispatcher.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 45db140..be12aa3 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -423,10 +423,11 @@ struct f "Error with client %a: %s" Dao.ClientVif.pp vif (Printexc.to_string ex)); Lwt.return_unit)); - cleanup_tasks + Lwt.return cleanup_tasks (** Watch XenStore for notifications of new clients. *) let wait_clients get_ts dns_client dns_servers qubesDB router = + let open Lwt.Syntax in let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in Dao.watch_clients @@ fun new_set -> (* Check for removed clients *) @@ -442,7 +443,7 @@ struct let rec go seq = match Seq.uncons seq with | None -> Lwt.return_unit | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> - let cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in + let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); clients := Dao.VifMap.add key cleanup !clients; go seq From 763a3de57a2476e6e5581d5c8b80eda33a7b71ed Mon Sep 17 00:00:00 2001 From: palainp Date: Tue, 31 Dec 2024 12:11:42 -0500 Subject: [PATCH 39/58] remove note as the code has changed --- dispatcher.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index be12aa3..6837555 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -341,9 +341,10 @@ struct Lwt.return_unit) (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) - let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers + let add_vif get_ts vif dns_client dns_servers ~client_ip ~router ~cleanup_tasks qubesDB = let open Lwt.Syntax in + let { Dao.ClientVif.domid; device_id } = vif in let* backend = Netback.make ~domid ~device_id in Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); @@ -403,8 +404,6 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] - will cancel them if the client is disconnected. *) Lwt.pick [ qubesdb_updater; listener ] (** A new client VM has been found in XenStore. Find its interface and connect to it. *) From 85de608392eebf57535d02d5fc078643945c6ad5 Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 4 Jan 2025 04:45:29 -0500 Subject: [PATCH 40/58] in Dispatcher.add_client: keep Client_eth.add_client into Lwt.async --- dispatcher.ml | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 6837555..7e6f10e 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -341,18 +341,12 @@ struct Lwt.return_unit) (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) - let add_vif get_ts vif dns_client dns_servers - ~client_ip ~router ~cleanup_tasks qubesDB = - let open Lwt.Syntax in + let conf_vif get_ts vif backend client_eth dns_client dns_servers + ~client_ip ~iface ~router ~cleanup_tasks qubesDB = let { Dao.ClientVif.domid; device_id } = vif in - let* backend = Netback.make ~domid ~device_id in Log.info (fun f -> - f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); - let* eth = ClientEth.connect backend in - let client_mac = Netback.frontend_mac backend in - let client_eth = router.clients in - let gateway_ip = Client_eth.client_gw client_eth in - let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in + f "Client %d:%d (IP: %s) ready" domid device_id (Ipaddr.V4.to_string client_ip)); + (* update the rules whenever QubesDB notices a change for this IP *) let qubesdb_updater = Lwt.catch @@ -380,8 +374,7 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); - add_client router iface >>= fun () -> - Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); + let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in let listener = @@ -404,24 +397,45 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - Lwt.pick [ qubesdb_updater; listener ] + Lwt.async (fun () -> + Lwt.catch + (fun () -> + Lwt.pick [ qubesdb_updater; listener ]) + (fun ex -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string ex)); + Lwt.return_unit)) ; + Lwt.return_unit (** A new client VM has been found in XenStore. Find its interface and connect to it. *) let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = + let open Lwt.Syntax in let cleanup_tasks = Cleanup.create () in Log.info (fun f -> f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip); + let { Dao.ClientVif.domid; device_id } = vif in + let* backend = Netback.make ~domid ~device_id in + let* eth = ClientEth.connect backend in + let client_mac = Netback.frontend_mac backend in + let client_eth = router.clients in + let gateway_ip = Client_eth.client_gw client_eth in + let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in + + Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); Lwt.async (fun () -> Lwt.catch (fun () -> - add_vif get_ts vif dns_client dns_servers ~client_ip ~router - ~cleanup_tasks qubesDB) + add_client router iface) (fun ex -> Log.warn (fun f -> f "Error with client %a: %s" Dao.ClientVif.pp vif (Printexc.to_string ex)); - Lwt.return_unit)); + Lwt.return_unit)) ; + + conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip ~iface ~router + ~cleanup_tasks qubesDB >>= fun () -> Lwt.return cleanup_tasks (** Watch XenStore for notifications of new clients. *) From 812b99842f431937866bf7e4779190422463e64a Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 4 Jan 2025 04:55:47 -0500 Subject: [PATCH 41/58] get catch back into add_client --- dispatcher.ml | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/dispatcher.ml b/dispatcher.ml index 7e6f10e..f6c29c4 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -342,7 +342,7 @@ struct (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) let conf_vif get_ts vif backend client_eth dns_client dns_servers - ~client_ip ~iface ~router ~cleanup_tasks qubesDB = + ~client_ip ~iface ~router ~cleanup_tasks qubesDB () = let { Dao.ClientVif.domid; device_id } = vif in Log.info (fun f -> f "Client %d:%d (IP: %s) ready" domid device_id (Ipaddr.V4.to_string client_ip)); @@ -397,15 +397,9 @@ struct (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) in Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - Lwt.async (fun () -> - Lwt.catch - (fun () -> - Lwt.pick [ qubesdb_updater; listener ]) - (fun ex -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string ex)); - Lwt.return_unit)) ; + (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] + will cancel them if the client is disconnected. *) + Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); Lwt.return_unit (** A new client VM has been found in XenStore. Find its interface and connect to it. *) @@ -434,8 +428,16 @@ struct (Printexc.to_string ex)); Lwt.return_unit)) ; - conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip ~iface ~router - ~cleanup_tasks qubesDB >>= fun () -> + let* () = + Lwt.catch ( + conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip ~iface ~router + ~cleanup_tasks qubesDB) + @@ fun exn -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string exn)); + Lwt.return_unit + in Lwt.return cleanup_tasks (** Watch XenStore for notifications of new clients. *) From 6d0cc1cf9decf4f02c3b1e4823210a50a23ffa12 Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 4 Jan 2025 06:02:40 -0500 Subject: [PATCH 42/58] add hashsum --- qubes-firewall.sha256 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 index b89e36f..c02b661 100644 --- a/qubes-firewall.sha256 +++ b/qubes-firewall.sha256 @@ -1 +1 @@ -78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc dist/qubes-firewall.xen +b78d6711b502f8babcc5c4083b0352b78be8e8a6bef044189ce7a00e6e564612 dist/qubes-firewall.xen From 32394c79e17fa979a7e7a0c1bdbff3bddd85c16e Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 4 Jan 2025 06:18:01 -0500 Subject: [PATCH 43/58] release v0.9.3 --- CHANGES.md | 5 +++++ qubes-firewall-release.sha256 | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index dac6405..0aaa61a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,8 @@ +### 0.9.3 (2025-01-04) + +- Fix an issue when qubes-mirage-firewall is used along with *BSD sys-net + (#209, @palainp, reported in the Qubes forum #208, reviewed by @dinosaure) + ### 0.9.2 (2024-10-16) - Code refactoring and improvements (#197, @dinosaure) diff --git a/qubes-firewall-release.sha256 b/qubes-firewall-release.sha256 index b89e36f..c02b661 100644 --- a/qubes-firewall-release.sha256 +++ b/qubes-firewall-release.sha256 @@ -1 +1 @@ -78a1ee52574b9a4fc5eda265922bcbcface90f7c43ed7a68dc8e201a2ac0a7dc dist/qubes-firewall.xen +b78d6711b502f8babcc5c4083b0352b78be8e8a6bef044189ce7a00e6e564612 dist/qubes-firewall.xen From b3bc2afc581e74ad698095c5064274d39d7bb8c3 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Mon, 3 Feb 2025 08:00:21 +0100 Subject: [PATCH 44/58] update gh action upload artifact --- .github/workflows/docker.yml | 2 +- .github/workflows/podman.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index 9a8216d..a5720ca 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -26,7 +26,7 @@ jobs: - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: qubes-firewall.xen path: qubes-firewall.xen diff --git a/.github/workflows/podman.yml b/.github/workflows/podman.yml index f62e075..21f2bd2 100644 --- a/.github/workflows/podman.yml +++ b/.github/workflows/podman.yml @@ -26,7 +26,7 @@ jobs: - run: sh -exc 'if [ "$(sha256sum dist/qubes-firewall.xen)" = "$(cat qubes-firewall.sha256)" ]; then echo "SHA256 MATCHES"; else exit 42; fi' - name: Upload Artifact - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: qubes-firewall.xen path: qubes-firewall.xen From 2b2ac42ebcb248c8291d95c8d623901a9b17be65 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 6 Feb 2025 12:07:29 +0100 Subject: [PATCH 45/58] fallback to Qubes netvm_mac=fe:ff:ff:ff:ff:ff is our netvm does not reply to us --- dispatcher.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/dispatcher.ml b/dispatcher.ml index f6c29c4..d929822 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -571,7 +571,14 @@ struct I.connect ~cidr ~gateway eth arp >>= fun ip -> U.connect ip >>= fun udp -> let netvm_mac = - Arp.query arp gateway >|= or_raise "Getting MAC of our NetVM" Arp.pp_error + Arp.query arp gateway >>= function + | Error e -> + Log.err(fun f -> f "Getting MAC of our NetVM: %a" Arp.pp_error e); + (* This mac address is a special address used by Qubes when the device + is not managed by Qubes itself. This can occurs inside a service + AppVM (e.g. VPN) when the service creates a new interface. *) + Lwt.return (Macaddr.of_string_exn "fe:ff:ff:ff:ff:ff") + | Ok mac -> Lwt.return mac in let interface = new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip From cf181026a8f21388298a0937a5b8eadc37c0eb02 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Thu, 6 Feb 2025 14:39:34 +0100 Subject: [PATCH 46/58] update hashsum --- qubes-firewall.sha256 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 index c02b661..220644c 100644 --- a/qubes-firewall.sha256 +++ b/qubes-firewall.sha256 @@ -1 +1 @@ -b78d6711b502f8babcc5c4083b0352b78be8e8a6bef044189ce7a00e6e564612 dist/qubes-firewall.xen +0c3c2c0e62a834112c69d7cddc5dd6f70ecb93afa988768fb860ed26e423b1f8 dist/qubes-firewall.xen From 5f5fe82b9b5ca0c673a28edac46147fd7bcbbb86 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Mon, 10 Feb 2025 11:25:57 +0100 Subject: [PATCH 47/58] release v0.9.4 --- CHANGES.md | 8 ++++++++ qubes-firewall-release.sha256 | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 0aaa61a..41d0026 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +### 0.9.4 (2025-02-10) + +- Fix an issue when qubes-mirage-firewall is used a a mullvad AppVM client. If + our netvm does not reply to our ARP requests we can not construct the ethernet + header. However in Linux VMs, Qubes adds a default netvm address associated to + `fe:ff:ff:ff:ff:ff`, so if ARP fails, we fall back on that address. + (#213, @palainp, reported in the Qubes forum #212, reviewed by @hannesm) + ### 0.9.3 (2025-01-04) - Fix an issue when qubes-mirage-firewall is used along with *BSD sys-net diff --git a/qubes-firewall-release.sha256 b/qubes-firewall-release.sha256 index c02b661..220644c 100644 --- a/qubes-firewall-release.sha256 +++ b/qubes-firewall-release.sha256 @@ -1 +1 @@ -b78d6711b502f8babcc5c4083b0352b78be8e8a6bef044189ce7a00e6e564612 dist/qubes-firewall.xen +0c3c2c0e62a834112c69d7cddc5dd6f70ecb93afa988768fb860ed26e423b1f8 dist/qubes-firewall.xen From 592f53777ee9435b654bfcffb5a35c88a76ccfb4 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 10 Mar 2025 13:51:20 +0100 Subject: [PATCH 48/58] update to mirage 4.9.0 --- config.ml | 6 +++--- dispatcher.ml | 12 +++--------- my_dns.ml | 10 +++------- unikernel.ml | 18 +++++++----------- 4 files changed, 16 insertions(+), 30 deletions(-) diff --git a/config.ml b/config.ml index 00ddc71..5c06a4b 100644 --- a/config.ml +++ b/config.ml @@ -1,4 +1,4 @@ -(* mirage >= 4.8.0 & < 4.9.0 *) +(* mirage >= 4.9.0 & < 4.10.0 *) (* Copyright (C) 2017, Thomas Leonard See the README file for details. *) @@ -24,7 +24,7 @@ let main = package ~min:"6.4.0" "dns-client"; package "pf-qubes"; ] - "Unikernel.Main" (random @-> mclock @-> time @-> job) + "Unikernel" job let () = - register "qubes-firewall" [main $ default_random $ default_monotonic_clock $ default_time] + register "qubes-firewall" [main] diff --git a/dispatcher.ml b/dispatcher.ml index d929822..9f6db7f 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -8,14 +8,9 @@ let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch" module Log = (val Logs.src_log src : Logs.LOG) -module Make - (R : Mirage_crypto_rng_mirage.S) - (Clock : Mirage_clock.MCLOCK) - (Time : Mirage_time.S) = -struct - module Arp = Arp.Make (UplinkEth) (Time) - module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) - module U = Udp.Make (I) (R) + module Arp = Arp.Make (UplinkEth) + module I = Static_ipv4.Make (UplinkEth) (Arp) + module U = Udp.Make (I) class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = @@ -632,4 +627,3 @@ struct >>= fun () -> aux new_db in aux Qubes.DB.KeyMap.empty -end diff --git a/my_dns.ml b/my_dns.ml index cbfa763..6000e80 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -1,9 +1,7 @@ open Lwt.Infix -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 -> string -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * string) Lwt_mvar.t @@ -20,8 +18,8 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim type context = t let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ] - let rng = R.generate ?g:None - let clock = C.elapsed_ns + let rng = Mirage_crypto_rng.generate ?g:None + let clock = Mirage_mtime.elapsed_ns let rec read t = let _, _, answer = t.stack in @@ -45,7 +43,7 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim t let with_timeout timeout_ns f = - let timeout = Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in + let timeout = Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in Lwt.pick [ f ; timeout ] let connect (t : t) = Lwt.return (Ok (t.protocol, t)) @@ -72,5 +70,3 @@ module Transport (R : Mirage_crypto_rng_mirage.S) (C : Mirage_clock.MCLOCK) (Tim let bind = Lwt.bind let lift = Lwt.return -end - diff --git a/unikernel.ml b/unikernel.ml index f0e12df..28115d1 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -28,10 +28,7 @@ let ipv4_dns2 = let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc) -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) + module Dns_client = Dns_client.Make(My_dns) (* Set up networking and listen for incoming packets. *) let network dns_client dns_responses dns_servers qubesDB router = @@ -39,22 +36,22 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : Dao.set_iptables_error qubesDB "" >>= fun () -> (* Handle packets from both networks *) Lwt.choose [ - Dispatcher.wait_clients Clock.elapsed_ns dns_client dns_servers qubesDB router ; + Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers qubesDB router ; Dispatcher.uplink_wait_update qubesDB router ; - Dispatcher.uplink_listen Clock.elapsed_ns dns_responses router + Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router ] (* Main unikernel entry point (called from auto-generated main.ml). *) - let start _random _clock _time = + let start () = let open Lwt.Syntax in - let start_time = Clock.elapsed_ns () in + let start_time = Mirage_mtime.elapsed_ns () in (* Start qrexec agent and QubesDB agent in parallel *) let* qrexec = RExec.connect ~domid:0 () in let agent_listener = RExec.listen qrexec Command.handler in let* qubesDB = DB.connect ~domid:0 () in let startup_time = let (-) = Int64.sub in - let time_in_ns = Clock.elapsed_ns () - start_time in + let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in Int64.to_float time_in_ns /. 1e9 in Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); @@ -113,5 +110,4 @@ module Main (R : Mirage_crypto_rng_mirage.S)(Clock : Mirage_clock.MCLOCK)(Time : (* 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. *) - Time.sleep_ns (1.0 *. 1e9 |> Int64.of_float) -end + Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float) From 5d515c360de5c1a5f9e4526fb06b838d3022e835 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 12 Mar 2025 11:56:33 +0100 Subject: [PATCH 49/58] update opam version, opam-repository and overlays hash --- Dockerfile | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Dockerfile b/Dockerfile index edf9e96..bd6e343 100644 --- a/Dockerfile +++ b/Dockerfile @@ -12,10 +12,10 @@ RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian RUN printf "deb [check-valid-until=no] http://snapshot.debian.org/archive/debian-security/20240419T111010Z bookworm-security main\n" >> /etc/apt/sources.list RUN apt update && apt install --no-install-recommends --no-install-suggests -y wget ca-certificates git patch unzip bzip2 make gcc g++ libc-dev -RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.2.1/opam-2.2.1-i686-linux && chmod 755 /usr/bin/opam +RUN wget -O /usr/bin/opam https://github.com/ocaml/opam/releases/download/2.3.0/opam-2.3.0-i686-linux && chmod 755 /usr/bin/opam # taken from https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh RUN test `sha512sum /usr/bin/opam | cut -d' ' -f1` = \ -"bf16d573137835ce9abbcf6b99cb94a1da69ab58804a4de7c90233f0b354d5e68e9c47ee16670ca9d59866d58c7db345d9723e6eb5fc3a1cb8dca371f0e90225" || exit +"4c0e8771889a36bad4d5f964e2e662d5b611e6f112777d3d4eea3eea919d109cd17826beba38e6cfa1ad9553a0a989d9268f911ea5485968da04b1e08efc7de2" || exit ENV OPAMROOT=/tmp ENV OPAMCONFIRMLEVEL=unsafe-yes @@ -23,13 +23,13 @@ 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#5d3f0d1d655199e596a1e785e69fae8fad78cad3 +RUN opam init --disable-sandboxing -a --bare https://github.com/ocaml/opam-repository.git#8f63148a9025a7b775a069a6c0b0385c22ad51d3 RUN opam switch create myswitch 4.14.2 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN mkdir /tmp/orb-build ADD config.ml /tmp/orb-build/config.ml WORKDIR /tmp/orb-build CMD opam exec -- sh -exc 'mirage configure -t xen --extra-repos=\ -opam-overlays:https://github.com/dune-universe/opam-overlays.git#4e75ee36715b27550d5bdb87686bb4ae4c9e89c4,\ +opam-overlays:https://github.com/dune-universe/opam-overlays.git#f2bec38beca4aea9e481f2fd3ee319c519124649,\ mirage-overlays:https://github.com/dune-universe/mirage-opam-overlays.git#797cb363df3ff763c43c8fbec5cd44de2878757e \ && make depend && make unikernel' From a756effb14905e404164c6769d9c9eac660c0390 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 12 Mar 2025 11:56:51 +0100 Subject: [PATCH 50/58] update hashsum --- qubes-firewall.sha256 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 index 220644c..067b2d6 100644 --- a/qubes-firewall.sha256 +++ b/qubes-firewall.sha256 @@ -1 +1 @@ -0c3c2c0e62a834112c69d7cddc5dd6f70ecb93afa988768fb860ed26e423b1f8 dist/qubes-firewall.xen +1cc5664d48a80b96162e14a0d8a17aafa52175cc2043ecf6b834c4bc8fe656f6 dist/qubes-firewall.xen From 85c8b7a661e503f974e311d4ae5a06b68a1ad50b Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Wed, 12 Mar 2025 11:57:13 +0100 Subject: [PATCH 51/58] add ocamlformat and autoformat in github action --- .github/workflows/format.yml | 45 ++++++++++++++++++++++++++++++++++++ .ocamlformat | 3 +++ 2 files changed, 48 insertions(+) create mode 100644 .github/workflows/format.yml create mode 100644 .ocamlformat diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml new file mode 100644 index 0000000..f5ebd58 --- /dev/null +++ b/.github/workflows/format.yml @@ -0,0 +1,45 @@ +name: ocamlformat + +on: [pull_request] + +jobs: + format: + name: ocamlformat + + strategy: + fail-fast: false + matrix: + ocaml-version: ["4.14.2"] + operating-system: [ubuntu-latest] + + runs-on: ${{ matrix.operating-system }} + + steps: + - name: Checkout code + uses: actions/checkout@v2 + with: + ref: ${{ github.event.pull_request.head.ref }} + + - name: Use OCaml ${{ matrix.ocaml-version }} + uses: ocaml/setup-ocaml@v3 + with: + ocaml-compiler: ${{ matrix.ocaml-version }} + + - name: Install ocamlformat + run: grep ^version .ocamlformat | cut -d '=' -f 2 | xargs -I V opam install ocamlformat=V + + - name: Format code + run: git ls-files '*.ml' '*.mli' | xargs opam exec -- ocamlformat --inplace + + - name: Check for modified files + id: git-check + run: echo "modified=$(if git diff-index --quiet HEAD --; then echo "false"; else echo "true"; fi)" >> $GITHUB_OUTPUT + + - name: Commit and push changes + if: steps.git-check.outputs.modified == 'true' + run: | + git config --global user.name "Automated ocamlformat GitHub action, developed by robur.coop" + git config --global user.email "autoformat@robur.coop" + git add -A + git commit -m "formatted code" + git push diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..d6d9647 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,3 @@ +version = 0.27.0 +profile = conventional +parse-docstrings = true From bc3fdaf3d5e5407f2f3c81ed693bcb3c2bf9cca7 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 17 Mar 2025 12:23:10 +0100 Subject: [PATCH 52/58] fix formatting action --- .github/workflows/format.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index f5ebd58..e57f74e 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -16,9 +16,9 @@ jobs: steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 with: - ref: ${{ github.event.pull_request.head.ref }} + ref: ${{ github.head_ref }} - name: Use OCaml ${{ matrix.ocaml-version }} uses: ocaml/setup-ocaml@v3 From 4de45e2f6794f9dca890ab4eb40239710e09c26c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 17 Mar 2025 12:25:34 +0100 Subject: [PATCH 53/58] try --- .github/workflows/format.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index e57f74e..e5c4a21 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -17,8 +17,6 @@ jobs: steps: - name: Checkout code uses: actions/checkout@v4 - with: - ref: ${{ github.head_ref }} - name: Use OCaml ${{ matrix.ocaml-version }} uses: ocaml/setup-ocaml@v3 From edba36b97b5e7842269ac7986a00a1dc230df7e1 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 17 Mar 2025 12:35:47 +0100 Subject: [PATCH 54/58] another try --- .github/workflows/format.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index e5c4a21..7e2d227 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -38,6 +38,5 @@ jobs: run: | git config --global user.name "Automated ocamlformat GitHub action, developed by robur.coop" git config --global user.email "autoformat@robur.coop" - git add -A - git commit -m "formatted code" + git commit -m "formatted code" . git push From 17941c7fbc98664c09dab19135b67a69bb72cdae Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 17 Mar 2025 12:59:22 +0100 Subject: [PATCH 55/58] minor change --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 40e65bd..ce64ba6 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ It's OK to install the Docker or Podman package in a template VM if you want it after a reboot, but the build of the firewall itself should be done in a regular AppVM. You can also build without that script, as for any normal Mirage unikernel; -see [the Mirage installation instructions](https://mirage.io/wiki/install) for details. +see [the Mirage installation instructions](https://mirageos.org/wiki/install) for details. The build script fixes the versions of the libraries it uses, ensuring that you will get exactly the same binary that is in the release. If you build without it, it will build From 511ac0adfb707f591b88ade9af5dbc5225046652 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 18 Mar 2025 09:10:17 +0100 Subject: [PATCH 56/58] trigger format on push rather than pull_request --- .github/workflows/format.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index 7e2d227..7970630 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -1,6 +1,6 @@ name: ocamlformat -on: [pull_request] +on: [push] jobs: format: From 4d89b858922556c13a5be2f9797fc6159a791263 Mon Sep 17 00:00:00 2001 From: "Automated ocamlformat GitHub action, developed by robur.coop" Date: Tue, 18 Mar 2025 08:16:13 +0000 Subject: [PATCH 57/58] formatted code --- cleanup.ml | 4 +- cleanup.mli | 4 +- client_eth.ml | 115 +++-- client_eth.mli | 36 +- command.ml | 20 +- config.ml | 38 +- dao.ml | 193 ++++---- dao.mli | 35 +- dispatcher.ml | 1128 ++++++++++++++++++++++--------------------- fw_utils.ml | 12 +- memory_pressure.ml | 8 +- memory_pressure.mli | 4 +- my_dns.ml | 127 ++--- my_nat.ml | 72 ++- my_nat.mli | 22 +- packet.ml | 46 +- packet.mli | 30 +- rules.ml | 120 +++-- test/config.ml | 36 +- test/unikernel.ml | 460 +++++++++++------- unikernel.ml | 159 +++--- 21 files changed, 1433 insertions(+), 1236 deletions(-) diff --git a/cleanup.ml b/cleanup.ml index cbe9ebc..ecd3c78 100644 --- a/cleanup.ml +++ b/cleanup.ml @@ -4,9 +4,7 @@ type t = (unit -> unit) list ref let create () = ref [] - -let on_cleanup t fn = - t := fn :: !t +let on_cleanup t fn = t := fn :: !t let cleanup t = let tasks = !t in diff --git a/cleanup.mli b/cleanup.mli index d43661b..1358c07 100644 --- a/cleanup.mli +++ b/cleanup.mli @@ -1,8 +1,8 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -(** Register actions to take when a resource is finished. - Like [Lwt_switch], but synchronous. *) +(** Register actions to take when a resource is finished. Like [Lwt_switch], but + synchronous. *) type t diff --git a/client_eth.ml b/client_eth.ml index fc0b01a..bd9d931 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -4,19 +4,19 @@ open Fw_utils open Lwt.Infix -let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients" +let src = + Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients" + module Log = (val Logs.src_log src : Logs.LOG) type t = { mutable iface_of_ip : client_link Ipaddr.V4.Map.t; - changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *) - my_ip : Ipaddr.V4.t; (* The IP that clients are given as their default gateway. *) + changed : unit Lwt_condition.t; (* Fires when [iface_of_ip] changes. *) + my_ip : Ipaddr.V4.t; + (* The IP that clients are given as their default gateway. *) } -type host = - [ `Client of client_link - | `Firewall - | `External of Ipaddr.t ] +type host = [ `Client of client_link | `Firewall | `External of Ipaddr.t ] let create config = let changed = Lwt_condition.create () in @@ -30,14 +30,17 @@ let add_client t iface = let rec aux () = match Ipaddr.V4.Map.find_opt ip t.iface_of_ip with | Some old -> - (* Wait for old client to disappear before adding one with the same IP address. + (* Wait for old client to disappear before adding one with the same IP address. Otherwise, its [remove_client] call will remove the new client instead. *) - Log.info (fun f -> f ~header:iface#log_header "Waiting for old client %s to go away before accepting new one" old#log_header); - Lwt_condition.wait t.changed >>= aux + Log.info (fun f -> + f ~header:iface#log_header + "Waiting for old client %s to go away before accepting new one" + old#log_header); + Lwt_condition.wait t.changed >>= aux | None -> - t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.add ip iface; - Lwt_condition.broadcast t.changed (); - Lwt.return_unit + t.iface_of_ip <- t.iface_of_ip |> Ipaddr.V4.Map.add ip iface; + Lwt_condition.broadcast t.changed (); + Lwt.return_unit in aux () @@ -52,11 +55,12 @@ let lookup t ip = Ipaddr.V4.Map.find_opt ip t.iface_of_ip let classify t ip = match ip with | Ipaddr.V6 _ -> `External ip - | Ipaddr.V4 ip4 -> - if ip4 = t.my_ip then `Firewall - else match lookup t ip4 with - | Some client_link -> `Client client_link - | None -> `External ip + | Ipaddr.V4 ip4 -> ( + if ip4 = t.my_ip then `Firewall + else + match lookup t ip4 with + | Some client_link -> `Client client_link + | None -> `External ip) let resolve t : host -> Ipaddr.t = function | `Client client_link -> Ipaddr.V4 client_link#other_ip @@ -64,50 +68,53 @@ let resolve t : host -> Ipaddr.t = function | `External addr -> addr module ARP = struct - type arp = { - net : t; - client_link : client_link; - } + type arp = { net : t; client_link : client_link } let lookup t ip = if ip = t.net.my_ip then Some t.client_link#my_mac else if (Ipaddr.V4.to_octets ip).[3] = '\x01' then ( - Log.info (fun f -> f ~header:t.client_link#log_header - "Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip); - Some t.client_link#my_mac - ) else None + Log.info (fun f -> + f ~header:t.client_link#log_header + "Request for %a is invalid, but pretending it's me (see Qubes \ + issue #5022)" + Ipaddr.V4.pp ip); + Some t.client_link#my_mac) + else None (* We're now treating client networks as point-to-point links, so we no longer respond on behalf of other clients. *) - (* + (* else match Ipaddr.V4.Map.find_opt ip t.net.iface_of_ip with | Some client_iface -> Some client_iface#other_mac | None -> None *) - let create ~net client_link = {net; client_link} + let create ~net client_link = { net; client_link } let input_query t arp = let req_ipv4 = arp.Arp_packet.target_ip in let pf (f : ?header:string -> ?tags:_ -> _) fmt = - f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp req_ipv4 + f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp + req_ipv4 in if req_ipv4 = t.client_link#other_ip then ( Log.info (fun f -> pf f "ignoring request for client's own IP"); - None - ) else match lookup t req_ipv4 with + None) + else + match lookup t req_ipv4 with | None -> - Log.info (fun f -> pf f "unknown address; not responding"); - None + Log.info (fun f -> pf f "unknown address; not responding"); + None | Some req_mac -> - Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac); - Some { Arp_packet. - operation = Arp_packet.Reply; - (* The Target Hardware Address and IP are copied from the request *) - target_ip = arp.Arp_packet.source_ip; - target_mac = arp.Arp_packet.source_mac; - source_ip = req_ipv4; - source_mac = req_mac; - } + Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac); + Some + { + Arp_packet.operation = Arp_packet.Reply; + (* The Target Hardware Address and IP are copied from the request *) + target_ip = arp.Arp_packet.source_ip; + target_mac = arp.Arp_packet.source_mac; + source_ip = req_ipv4; + source_mac = req_mac; + } let input_gratuitous t arp = let source_ip = arp.Arp_packet.source_ip in @@ -115,18 +122,28 @@ module ARP = struct let header = t.client_link#log_header in match lookup t source_ip with | Some real_mac when Macaddr.compare source_mac real_mac = 0 -> - Log.info (fun f -> f ~header "client suggests updating %s -> %s (as expected)" - (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac)); + Log.info (fun f -> + f ~header "client suggests updating %s -> %s (as expected)" + (Ipaddr.V4.to_string source_ip) + (Macaddr.to_string source_mac)) | Some other_mac -> - Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (should be %s)" - (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac) (Macaddr.to_string other_mac)); + Log.warn (fun f -> + f ~header "client suggests incorrect update %s -> %s (should be %s)" + (Ipaddr.V4.to_string source_ip) + (Macaddr.to_string source_mac) + (Macaddr.to_string other_mac)) | None -> - Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (unexpected IP)" - (Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac)) + Log.warn (fun f -> + f ~header + "client suggests incorrect update %s -> %s (unexpected IP)" + (Ipaddr.V4.to_string source_ip) + (Macaddr.to_string source_mac)) let input t arp = let op = arp.Arp_packet.operation in match op with | Arp_packet.Request -> input_query t arp - | Arp_packet.Reply -> input_gratuitous t arp; None + | Arp_packet.Reply -> + input_gratuitous t arp; + None end diff --git a/client_eth.mli b/client_eth.mli index 02ccee9..d7ecb55 100644 --- a/client_eth.mli +++ b/client_eth.mli @@ -1,34 +1,32 @@ (* Copyright (C) 2016, Thomas Leonard See the README file for details. *) -(** The ethernet networks connecting us to our client AppVMs. - Note: each AppVM is on a point-to-point link, each link being considered to be a separate Ethernet network. *) +(** The ethernet networks connecting us to our client AppVMs. Note: each AppVM + is on a point-to-point link, each link being considered to be a separate + Ethernet network. *) open Fw_utils type t (** A collection of clients. *) -type host = - [ `Client of client_link - | `Firewall - | `External of Ipaddr.t ] +type host = [ `Client of client_link | `Firewall | `External of Ipaddr.t ] (* Note: Qubes does not allow us to distinguish between an external address and a disconnected client. See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *) val create : Dao.network_config -> t Lwt.t -(** [create ~client_gw] is a network of client machines. - Qubes will have configured the client machines to use [client_gw] as their default gateway. *) +(** [create ~client_gw] is a network of client machines. Qubes will have + configured the client machines to use [client_gw] as their default gateway. +*) val add_client : t -> client_link -> unit Lwt.t -(** [add_client t client] registers a new client. If a client with this IP address is already registered, - it waits for [remove_client] to be called on that before adding the new client and returning. *) +(** [add_client t client] registers a new client. If a client with this IP + address is already registered, it waits for [remove_client] to be called on + that before adding the new client and returning. *) val remove_client : t -> client_link -> unit - val client_gw : t -> Ipaddr.V4.t - val classify : t -> Ipaddr.t -> host val resolve : t -> host -> Ipaddr.t @@ -36,18 +34,18 @@ val lookup : t -> Ipaddr.V4.t -> client_link option (** [lookup t addr] is the client with IP address [addr], if connected. *) module ARP : sig - (** We already know the correct mapping of IP addresses to MAC addresses, so we never - allow clients to update it. We log a warning if a client attempts to set incorrect - information. *) + (** We already know the correct mapping of IP addresses to MAC addresses, so + we never allow clients to update it. We log a warning if a client attempts + to set incorrect information. *) type arp (** An ARP-responder for one client. *) val create : net:t -> client_link -> arp - (** [create ~net client_link] is an ARP responder for [client_link]. - It answers only for the client's gateway address. *) + (** [create ~net client_link] is an ARP responder for [client_link]. It + answers only for the client's gateway address. *) val input : arp -> Arp_packet.t -> Arp_packet.t option - (** Process one ethernet frame containing an ARP message. - Returns a response frame, if one is needed. *) + (** Process one ethernet frame containing an ARP message. Returns a response + frame, if one is needed. *) end diff --git a/command.ml b/command.ml index da70727..0661bfc 100644 --- a/command.ml +++ b/command.ml @@ -4,24 +4,30 @@ (** Commands we provide via qvm-run. *) open Lwt - module Flow = Qubes.RExec.Flow let src = Logs.Src.create "command" ~doc:"qrexec command handler" + module Log = (val Logs.src_log src : Logs.LOG) let set_date_time flow = Flow.read_line flow >|= function - | `Eof -> Log.warn (fun f -> f "EOF reading time from dom0"); 1 - | `Ok line -> Log.info (fun f -> f "TODO: set time to %S" line); 0 + | `Eof -> + Log.warn (fun f -> f "EOF reading time from dom0"); + 1 + | `Ok line -> + Log.info (fun f -> f "TODO: set time to %S" line); + 0 let handler ~user:_ cmd flow = (* Write a message to the client and return an exit status of 1. *) let error fmt = - fmt |> Printf.ksprintf @@ fun s -> - Log.warn (fun f -> f "<< %s" s); - Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1 in + fmt + |> Printf.ksprintf @@ fun s -> + Log.warn (fun f -> f "<< %s" s); + Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1 + in match cmd with | "QUBESRPC qubes.SetDateTime dom0" -> set_date_time flow - | "QUBESRPC qubes.WaitForSession none" -> return 0 (* Always ready! *) + | "QUBESRPC qubes.WaitForSession none" -> return 0 (* Always ready! *) | cmd -> error "Unknown command %S" cmd diff --git a/config.ml b/config.ml index 5c06a4b..b663813 100644 --- a/config.ml +++ b/config.ml @@ -7,24 +7,24 @@ open Mirage let main = - main - ~packages:[ - package "vchan" ~min:"4.0.2"; - package "cstruct"; - package "tcpip" ~min:"3.7.0"; - package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; - package ~min:"3.0.0" "ethernet"; - package "shared-memory-ring" ~min:"3.0.0"; - package "mirage-net-xen" ~min:"2.1.4"; - package "ipaddr" ~min:"5.2.0"; - package "mirage-qubes" ~min:"0.9.1"; - package ~min:"3.0.1" "mirage-nat"; - package "mirage-logs"; - package "mirage-xen" ~min:"8.0.0"; - package ~min:"6.4.0" "dns-client"; - package "pf-qubes"; - ] + main + ~packages: + [ + package "vchan" ~min:"4.0.2"; + package "cstruct"; + package "tcpip" ~min:"3.7.0"; + package ~min:"2.3.0" ~sublibs:[ "mirage" ] "arp"; + package ~min:"3.0.0" "ethernet"; + package "shared-memory-ring" ~min:"3.0.0"; + package "mirage-net-xen" ~min:"2.1.4"; + package "ipaddr" ~min:"5.2.0"; + package "mirage-qubes" ~min:"0.9.1"; + package ~min:"3.0.1" "mirage-nat"; + package "mirage-logs"; + package "mirage-xen" ~min:"8.0.0"; + package ~min:"6.4.0" "dns-client"; + package "pf-qubes"; + ] "Unikernel" job -let () = - register "qubes-firewall" [main] +let () = register "qubes-firewall" [ main ] diff --git a/dao.ml b/dao.ml index 9344c1f..9219fa6 100644 --- a/dao.ml +++ b/dao.ml @@ -5,35 +5,34 @@ open Lwt.Infix open Qubes let src = Logs.Src.create "dao" ~doc:"QubesDB data access" + module Log = (val Logs.src_log src : Logs.LOG) module ClientVif = struct - type t = { - domid : int; - device_id : int; - } + type t = { domid : int; device_id : int } - let pp f { domid; device_id } = Fmt.pf f "{domid=%d;device_id=%d}" domid device_id + let pp f { domid; device_id } = + Fmt.pf f "{domid=%d;device_id=%d}" domid device_id let compare = compare end + module VifMap = struct - include Map.Make(ClientVif) + include Map.Make (ClientVif) + let rec of_list = function | [] -> empty | (k, v) :: rest -> add k v (of_list rest) - let find key t = - try Some (find key t) - with Not_found -> None + + let find key t = try Some (find key t) with Not_found -> None end let directory ~handle dir = Xen_os.Xs.directory handle dir >|= function - | [""] -> [] (* XenStore client bug *) + | [ "" ] -> [] (* XenStore client bug *) | items -> items -let db_root client_ip = - "/qubes-firewall/" ^ (Ipaddr.V4.to_string client_ip) +let db_root client_ip = "/qubes-firewall/" ^ Ipaddr.V4.to_string client_ip let read_rules rules client_ip = let root = db_root client_ip in @@ -42,86 +41,101 @@ let read_rules rules client_ip = Log.debug (fun f -> f "reading %s" pattern); match Qubes.DB.KeyMap.find_opt pattern rules with | None -> - Log.debug (fun f -> f "rule %d does not exist; won't look for more" n); - Ok (List.rev l) - | Some rule -> - Log.debug (fun f -> f "rule %d: %s" n rule); - match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with - | Error e -> Log.warn (fun f -> f "Error parsing rule %d: %s" n e); Error e - | Ok rule -> - Log.debug (fun f -> f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule); - get_rule (n+1) (rule :: l) + Log.debug (fun f -> f "rule %d does not exist; won't look for more" n); + Ok (List.rev l) + | Some rule -> ( + Log.debug (fun f -> f "rule %d: %s" n rule); + match Pf_qubes.Parse_qubes.parse_qubes ~number:n rule with + | Error e -> + Log.warn (fun f -> f "Error parsing rule %d: %s" n e); + Error e + | Ok rule -> + Log.debug (fun f -> + f "parsed rule: %a" Pf_qubes.Parse_qubes.pp_rule rule); + get_rule (n + 1) (rule :: l)) in match get_rule 0 [] with | Ok l -> l | Error e -> - Log.warn (fun f -> f "Defaulting to deny-all because of rule parse failure (%s)" e); - [ Pf_qubes.Parse_qubes.({action = Drop; - proto = None; - specialtarget = None; - dst = `any; - dstports = None; - icmp_type = None; - number = 0;})] + Log.warn (fun f -> + f "Defaulting to deny-all because of rule parse failure (%s)" e); + [ + Pf_qubes.Parse_qubes. + { + action = Drop; + proto = None; + specialtarget = None; + dst = `any; + dstports = None; + icmp_type = None; + number = 0; + }; + ] let vifs client domid = let open Lwt.Syntax in match int_of_string_opt domid with - | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return [] + | None -> + Log.err (fun f -> f "Invalid domid %S" domid); + Lwt.return [] | Some domid -> - let path = Fmt.str "backend/vif/%d" domid in - let vifs_of_domain handle = - let* devices = directory ~handle path in - let ip_of_vif device_id = match int_of_string_opt device_id with - | None -> - Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); - Lwt.return_none - | Some device_id -> - let vif = { ClientVif.domid; device_id } in - let get_client_ip () = - let* str = Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) in - let client_ip = List.hd (String.split_on_char ' ' str) in - (* NOTE(dinosaure): it's safe to use [List.hd] here, + let path = Fmt.str "backend/vif/%d" domid in + let vifs_of_domain handle = + let* devices = directory ~handle path in + let ip_of_vif device_id = + match int_of_string_opt device_id with + | None -> + Log.err (fun f -> + f "Invalid device ID %S for domid %d" device_id domid); + Lwt.return_none + | Some device_id -> ( + let vif = { ClientVif.domid; device_id } in + let get_client_ip () = + let* str = + Xen_os.Xs.read handle (Fmt.str "%s/%d/ip" path device_id) + in + let client_ip = List.hd (String.split_on_char ' ' str) in + (* NOTE(dinosaure): it's safe to use [List.hd] here, [String.split_on_char] can not return an empty list. *) - Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) - in - Lwt.catch get_client_ip @@ function - | Xs_protocol.Enoent _ -> Lwt.return_none - | Ipaddr.Parse_error (msg, client_ip) -> - Log.err (fun f -> f "Error parsing IP address of %a from %s: %s" - ClientVif.pp vif client_ip msg); - Lwt.return_none - | exn -> - Log.err (fun f -> f "Error getting IP address of %a: %s" - ClientVif.pp vif (Printexc.to_string exn)); - Lwt.return_none + Lwt.return_some (vif, Ipaddr.V4.of_string_exn client_ip) + in + Lwt.catch get_client_ip @@ function + | Xs_protocol.Enoent _ -> Lwt.return_none + | Ipaddr.Parse_error (msg, client_ip) -> + Log.err (fun f -> + f "Error parsing IP address of %a from %s: %s" + ClientVif.pp vif client_ip msg); + Lwt.return_none + | exn -> + Log.err (fun f -> + f "Error getting IP address of %a: %s" ClientVif.pp vif + (Printexc.to_string exn)); + Lwt.return_none) + in + Lwt_list.filter_map_p ip_of_vif devices in - Lwt_list.filter_map_p ip_of_vif devices - in - Xen_os.Xs.immediate client vifs_of_domain + Xen_os.Xs.immediate client vifs_of_domain let watch_clients fn = Xen_os.Xs.make () >>= fun xs -> let backend_vifs = "backend/vif" in Log.info (fun f -> f "Watching %s" backend_vifs); Xen_os.Xs.wait xs (fun handle -> - begin Lwt.catch - (fun () -> directory ~handle backend_vifs) - (function - | Xs_protocol.Enoent _ -> Lwt.return [] - | ex -> Lwt.fail ex) - end >>= fun items -> - Xen_os.Xs.make () >>= fun xs -> - Lwt_list.map_p (vifs xs) items >>= fun items -> - fn (List.concat items |> VifMap.of_list) >>= fun () -> - (* Wait for further updates *) - Lwt.fail Xs_protocol.Eagain - ) + Lwt.catch + (fun () -> directory ~handle backend_vifs) + (function Xs_protocol.Enoent _ -> Lwt.return [] | ex -> Lwt.fail ex) + >>= fun items -> + Xen_os.Xs.make () >>= fun xs -> + Lwt_list.map_p (vifs xs) items >>= fun items -> + fn (List.concat items |> VifMap.of_list) >>= fun () -> + (* Wait for further updates *) + Lwt.fail Xs_protocol.Eagain) type network_config = { - from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*) - netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) - our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) + from_cmdline : bool; + (* Specify if we have network configuration from command line or from qubesDB*) + netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) + our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; dns2 : Ipaddr.V4.t; } @@ -132,31 +146,36 @@ let try_read_network_config db = let get name = match DB.KeyMap.find_opt name db with | None -> raise (Missing_key name) - | Some value -> Ipaddr.V4.of_string_exn value in - let our_ip = get "/qubes-ip" in (* - IP address for this VM (only when VM has netvm set) *) - let netvm_ip = get "/qubes-gateway" in (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *) + | Some value -> Ipaddr.V4.of_string_exn value + in + let our_ip = get "/qubes-ip" in + (* - IP address for this VM (only when VM has netvm set) *) + let netvm_ip = get "/qubes-gateway" in + (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *) let dns = get "/qubes-primary-dns" in let dns2 = get "/qubes-secondary-dns" in - { from_cmdline=false; netvm_ip ; our_ip ; dns ; dns2 } + { from_cmdline = false; netvm_ip; our_ip; dns; dns2 } let read_network_config qubesDB = let rec aux bindings = try Lwt.return (try_read_network_config bindings) with Missing_key key -> - Log.warn (fun f -> f "QubesDB key %S not (yet) present; waiting for QubesDB to change..." key); + Log.warn (fun f -> + f "QubesDB key %S not (yet) present; waiting for QubesDB to change..." + key); DB.after qubesDB bindings >>= aux in aux (DB.bindings qubesDB) let print_network_config config = - Log.info (fun f -> f "@[Current network configuration (QubesDB or command line):@,\ - NetVM IP on uplink network: %a@,\ - Our IP on client networks: %a@,\ - DNS primary resolver: %a@,\ - DNS secondary resolver: %a@]" - Ipaddr.V4.pp config.netvm_ip - Ipaddr.V4.pp config.our_ip - Ipaddr.V4.pp config.dns - Ipaddr.V4.pp config.dns2) + Log.info (fun f -> + f + "@[Current network configuration (QubesDB or command line):@,\ + NetVM IP on uplink network: %a@,\ + Our IP on client networks: %a@,\ + DNS primary resolver: %a@,\ + DNS secondary resolver: %a@]" + Ipaddr.V4.pp config.netvm_ip Ipaddr.V4.pp config.our_ip Ipaddr.V4.pp + config.dns Ipaddr.V4.pp config.dns2) let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error" diff --git a/dao.mli b/dao.mli index c278d16..85f8912 100644 --- a/dao.mli +++ b/dao.mli @@ -4,40 +4,43 @@ (** Wrapper for XenStore and QubesDB databases. *) module ClientVif : sig - type t = { - domid : int; - device_id : int; - } + type t = { domid : int; device_id : int } + val pp : t Fmt.t end + module VifMap : sig include Map.S with type key = ClientVif.t + val find : key -> 'a t -> 'a option end val watch_clients : (Ipaddr.V4.t VifMap.t -> unit Lwt.t) -> 'a Lwt.t -(** [watch_clients fn] calls [fn clients] with the list of backend clients - in XenStore, and again each time XenStore updates. *) +(** [watch_clients fn] calls [fn clients] with the list of backend clients in + XenStore, and again each time XenStore updates. *) type network_config = { - from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*) - netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) - our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) + from_cmdline : bool; + (* Specify if we have network configuration from command line or from qubesDB*) + netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) + our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; dns2 : Ipaddr.V4.t; } val read_network_config : Qubes.DB.t -> network_config Lwt.t -(** [read_network_config db] fetches the configuration from QubesDB. - If it isn't there yet, it waits until it is. *) +(** [read_network_config db] fetches the configuration from QubesDB. If it isn't + there yet, it waits until it is. *) val db_root : Ipaddr.V4.t -> string -(** Returns the root path of the firewall rules in the QubesDB for a given IP address. *) +(** Returns the root path of the firewall rules in the QubesDB for a given IP + address. *) -val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list -(** [read_rules bindings ip] extracts firewall rule information for [ip] from [bindings]. - If any rules fail to parse, it will return only one rule denying all traffic. *) +val read_rules : + string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes.rule list +(** [read_rules bindings ip] extracts firewall rule information for [ip] from + [bindings]. If any rules fail to parse, it will return only one rule denying + all traffic. *) val print_network_config : network_config -> unit - val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t diff --git a/dispatcher.ml b/dispatcher.ml index 9f6db7f..9d67f88 100644 --- a/dispatcher.ml +++ b/dispatcher.ml @@ -7,158 +7,161 @@ module UplinkEth = Ethernet.Make (Netif) let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch" module Log = (val Logs.src_log src : Logs.LOG) +module Arp = Arp.Make (UplinkEth) +module I = Static_ipv4.Make (UplinkEth) (Arp) +module U = Udp.Make (I) - module Arp = Arp.Make (UplinkEth) - module I = Static_ipv4.Make (UplinkEth) (Arp) - module U = Udp.Make (I) +class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = + let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in + object + val mutable rules = [] + method get_rules = rules + method set_rules new_db = rules <- Dao.read_rules new_db client_ip + method my_mac = ClientEth.mac eth + method other_mac = client_mac + method my_ip = gateway_ip + method other_ip = client_ip - class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link - = - let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in - object - val mutable rules = [] - method get_rules = rules - method set_rules new_db = rules <- Dao.read_rules new_db client_ip - method my_mac = ClientEth.mac eth - method other_mac = client_mac - method my_ip = gateway_ip - method other_ip = client_ip + method writev proto fillfn = + Lwt.catch + (fun () -> + ClientEth.write eth client_mac proto fillfn >|= function + | Ok () -> () + | Error e -> + Log.err (fun f -> + f "error trying to send to client: @[%a@]" ClientEth.pp_error + e)) + (fun ex -> + (* Usually Netback_shutdown, because the client disconnected *) + Log.err (fun f -> + f "uncaught exception trying to send to client: @[%s@]" + (Printexc.to_string ex)); + Lwt.return_unit) - method writev proto fillfn = - Lwt.catch - (fun () -> - ClientEth.write eth client_mac proto fillfn >|= function - | Ok () -> () - | Error e -> - Log.err (fun f -> - f "error trying to send to client: @[%a@]" - ClientEth.pp_error e)) - (fun ex -> - (* Usually Netback_shutdown, because the client disconnected *) - Log.err (fun f -> - f "uncaught exception trying to send to client: @[%s@]" - (Printexc.to_string ex)); - Lwt.return_unit) + method log_header = log_header + end - method log_header = log_header - end +class netvm_iface eth mac ~my_ip ~other_ip : interface = + object + method my_mac = UplinkEth.mac eth + method my_ip = my_ip + method other_ip = other_ip - class netvm_iface eth mac ~my_ip ~other_ip : interface = - object - method my_mac = UplinkEth.mac eth - method my_ip = my_ip - method other_ip = other_ip + method writev ethertype fillfn = + Lwt.catch + (fun () -> + mac >>= fun dst -> + UplinkEth.write eth dst ethertype fillfn + >|= or_raise "Write to uplink" UplinkEth.pp_error) + (fun ex -> + Log.err (fun f -> + f "uncaught exception trying to send to uplink: @[%s@]" + (Printexc.to_string ex)); + Lwt.return_unit) + end - method writev ethertype fillfn = - Lwt.catch - (fun () -> - mac >>= fun dst -> - UplinkEth.write eth dst ethertype fillfn - >|= or_raise "Write to uplink" UplinkEth.pp_error) - (fun ex -> - Log.err (fun f -> - f "uncaught exception trying to send to uplink: @[%s@]" - (Printexc.to_string ex)); - Lwt.return_unit) - end +type uplink = { + net : Netif.t; + eth : UplinkEth.t; + arp : Arp.t; + interface : interface; + mutable fragments : Fragments.Cache.t; + ip : I.t; + udp : U.t; +} - type uplink = { - net : Netif.t; - eth : UplinkEth.t; - arp : Arp.t; - interface : interface; - mutable fragments : Fragments.Cache.t; - ip : I.t; - udp : U.t; +type t = { + uplink_connected : unit Lwt_condition.t; + uplink_disconnect : unit Lwt_condition.t; + uplink_disconnected : unit Lwt_condition.t; + mutable config : Dao.network_config; + clients : Client_eth.t; + nat : My_nat.t; + mutable uplink : uplink option; +} + +let create ~config ~clients ~nat ~uplink = + { + uplink_connected = Lwt_condition.create (); + uplink_disconnect = Lwt_condition.create (); + uplink_disconnected = Lwt_condition.create (); + config; + clients; + nat; + uplink; } - type t = { - uplink_connected : unit Lwt_condition.t; - uplink_disconnect : unit Lwt_condition.t; - uplink_disconnected : unit Lwt_condition.t; - mutable config : Dao.network_config; - clients : Client_eth.t; - nat : My_nat.t; - mutable uplink : uplink option; - } +let update t ~config ~uplink = + t.config <- config; + t.uplink <- uplink; + Lwt.return_unit - let create ~config ~clients ~nat ~uplink = - { - uplink_connected = Lwt_condition.create (); - uplink_disconnect = Lwt_condition.create (); - uplink_disconnected = Lwt_condition.create (); - config; - clients; - nat; - uplink; - } - - let update t ~config ~uplink = - t.config <- config; - t.uplink <- uplink; - Lwt.return_unit - - let target t buf = - let dst_ip = buf.Ipv4_packet.dst in - match Client_eth.lookup t.clients dst_ip with - | Some client_link -> Some (client_link :> interface) - | None -> ( (* if dest is not a client, transfer it to our uplink *) - match t.uplink with - | None -> ( - match Client_eth.lookup t.clients t.config.netvm_ip with - | Some uplink -> - Some (uplink :> interface) - | None -> - Log.err (fun f -> f "We have a command line configuration %a but it's currently not connected to us (please check its netvm property)...%!" Ipaddr.V4.pp t.config.netvm_ip); +let target t buf = + let dst_ip = buf.Ipv4_packet.dst in + match Client_eth.lookup t.clients dst_ip with + | Some client_link -> Some (client_link :> interface) + | None -> ( + (* if dest is not a client, transfer it to our uplink *) + match t.uplink with + | None -> ( + match Client_eth.lookup t.clients t.config.netvm_ip with + | Some uplink -> Some (uplink :> interface) + | None -> + Log.err (fun f -> + f + "We have a command line configuration %a but it's \ + currently not connected to us (please check its netvm \ + property)...%!" + Ipaddr.V4.pp t.config.netvm_ip); None) - | Some uplink -> Some uplink.interface) + | Some uplink -> Some uplink.interface) - let add_client t = Client_eth.add_client t.clients - let remove_client t = Client_eth.remove_client t.clients +let add_client t = Client_eth.add_client t.clients +let remove_client t = Client_eth.remove_client t.clients - let classify t ip = - if ip = Ipaddr.V4 t.config.our_ip then `Firewall - else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM - else (Client_eth.classify t.clients ip :> Packet.host) +let classify t ip = + if ip = Ipaddr.V4 t.config.our_ip then `Firewall + else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM + else (Client_eth.classify t.clients ip :> Packet.host) - let resolve t = function - | `Firewall -> Ipaddr.V4 t.config.our_ip - | `NetVM -> Ipaddr.V4 t.config.netvm_ip - | #Client_eth.host as host -> Client_eth.resolve t.clients host +let resolve t = function + | `Firewall -> Ipaddr.V4 t.config.our_ip + | `NetVM -> Ipaddr.V4 t.config.netvm_ip + | #Client_eth.host as host -> Client_eth.resolve t.clients host - (* Transmission *) +(* Transmission *) - let transmit_ipv4 packet iface = - Lwt.catch - (fun () -> - let fragments = ref [] in - iface#writev `IPv4 (fun b -> - match Nat_packet.into_cstruct packet b with - | Error e -> - Log.warn (fun f -> - f "Failed to write packet to %a: %a" Ipaddr.V4.pp - iface#other_ip Nat_packet.pp_error e); - 0 - | Ok (n, frags) -> - fragments := frags; - n) - >>= fun () -> - Lwt_list.iter_s - (fun f -> - let size = Cstruct.length f in - iface#writev `IPv4 (fun b -> - Cstruct.blit f 0 b 0 size; - size)) - !fragments) - (fun ex -> - Log.warn (fun f -> - f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip - (Printexc.to_string ex)); - Lwt.return_unit) +let transmit_ipv4 packet iface = + Lwt.catch + (fun () -> + let fragments = ref [] in + iface#writev `IPv4 (fun b -> + match Nat_packet.into_cstruct packet b with + | Error e -> + Log.warn (fun f -> + f "Failed to write packet to %a: %a" Ipaddr.V4.pp + iface#other_ip Nat_packet.pp_error e); + 0 + | Ok (n, frags) -> + fragments := frags; + n) + >>= fun () -> + Lwt_list.iter_s + (fun f -> + let size = Cstruct.length f in + iface#writev `IPv4 (fun b -> + Cstruct.blit f 0 b 0 size; + size)) + !fragments) + (fun ex -> + Log.warn (fun f -> + f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip + (Printexc.to_string ex)); + Lwt.return_unit) - let forward_ipv4 t packet = - let (`IPv4 (ip, _)) = packet in - Lwt.catch +let forward_ipv4 t packet = + let (`IPv4 (ip, _)) = packet in + Lwt.catch (fun () -> match target t ip with | Some iface -> transmit_ipv4 packet iface @@ -170,460 +173,463 @@ module Log = (val Logs.src_log src : Logs.LOG) (Printexc.to_string ex)); Lwt.return_unit) - (* NAT *) +(* NAT *) - let translate t packet = My_nat.translate t.nat packet +let translate t packet = My_nat.translate t.nat packet - (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) - let add_nat_and_forward_ipv4 t packet = - let xl_host = t.config.our_ip in - match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with - | Ok packet -> forward_ipv4 t packet - | Error e -> - Log.warn (fun f -> - f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); - Lwt.return_unit +(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) +let add_nat_and_forward_ipv4 t packet = + let xl_host = t.config.our_ip in + match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> + f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); + Lwt.return_unit - (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) - let nat_to t ~host ~port packet = - match resolve t host with - | Ipaddr.V6 _ -> - Log.warn (fun f -> f "Cannot NAT with IPv6"); - Lwt.return_unit - | Ipaddr.V4 target -> ( - let xl_host = t.config.our_ip in - match - My_nat.add_nat_rule_and_translate t.nat ~xl_host - (`Redirect (target, port)) - packet - with - | Ok packet -> forward_ipv4 t packet - | Error e -> - Log.warn (fun f -> - f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp - packet); - Lwt.return_unit) +(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) +let nat_to t ~host ~port packet = + match resolve t host with + | Ipaddr.V6 _ -> + Log.warn (fun f -> f "Cannot NAT with IPv6"); + Lwt.return_unit + | Ipaddr.V4 target -> ( + let xl_host = t.config.our_ip in + match + My_nat.add_nat_rule_and_translate t.nat ~xl_host + (`Redirect (target, port)) + packet + with + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> + f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp + packet); + Lwt.return_unit) - let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst - (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t = - let packet = Packet.to_mirage_nat_packet annotated_packet in - rules annotated_packet >>= fun action -> - match (action, dst) with - | `Accept, `Client client_link -> transmit_ipv4 packet client_link - | `Accept, (`External _ | `NetVM) -> ( - match t.uplink with - | Some uplink -> transmit_ipv4 packet uplink.interface - | None -> ( - match Client_eth.lookup t.clients t.config.netvm_ip with - | Some iface -> transmit_ipv4 packet iface - | None -> - Log.warn (fun f -> - f "No output interface for %a : drop" Nat_packet.pp packet); - Lwt.return_unit)) - | `Accept, `Firewall -> - Log.warn (fun f -> - f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); - Lwt.return_unit - | `NAT, _ -> - Log.debug (fun f -> f "adding NAT rule for %a" Nat_packet.pp packet); - add_nat_and_forward_ipv4 t packet - | `NAT_to (host, port), _ -> nat_to t packet ~host ~port - | `Drop reason, _ -> - Log.debug (fun f -> - f "Dropped packet (%s) %a" reason Nat_packet.pp packet); - Lwt.return_unit +let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst + (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t = + let packet = Packet.to_mirage_nat_packet annotated_packet in + rules annotated_packet >>= fun action -> + match (action, dst) with + | `Accept, `Client client_link -> transmit_ipv4 packet client_link + | `Accept, (`External _ | `NetVM) -> ( + match t.uplink with + | Some uplink -> transmit_ipv4 packet uplink.interface + | None -> ( + match Client_eth.lookup t.clients t.config.netvm_ip with + | Some iface -> transmit_ipv4 packet iface + | None -> + Log.warn (fun f -> + f "No output interface for %a : drop" Nat_packet.pp packet); + Lwt.return_unit)) + | `Accept, `Firewall -> + Log.warn (fun f -> + f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); + Lwt.return_unit + | `NAT, _ -> + Log.debug (fun f -> f "adding NAT rule for %a" Nat_packet.pp packet); + add_nat_and_forward_ipv4 t packet + | `NAT_to (host, port), _ -> nat_to t packet ~host ~port + | `Drop reason, _ -> + Log.debug (fun f -> + f "Dropped packet (%s) %a" reason Nat_packet.pp packet); + Lwt.return_unit - let ipv4_from_netvm t packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> ( - let (`IPv4 (ip, _transport)) = packet in - let src = classify t (Ipaddr.V4 ip.Ipv4_packet.src) in - let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in - match Packet.of_mirage_nat_packet ~src ~dst packet with - | None -> Lwt.return_unit - | Some _ -> ( - match src with - | `Client _ | `Firewall -> - Log.warn (fun f -> - f "Frame from NetVM has internal source IP address! %a" - Nat_packet.pp packet); - Lwt.return_unit - | (`External _ | `NetVM) as src -> ( - match translate t packet with - | Some frame -> forward_ipv4 t frame - | None -> ( - match Packet.of_mirage_nat_packet ~src ~dst packet with - | None -> Lwt.return_unit - | Some packet -> apply_rules t Rules.from_netvm ~dst packet) - ))) +let ipv4_from_netvm t packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> ( + let (`IPv4 (ip, _transport)) = packet in + let src = classify t (Ipaddr.V4 ip.Ipv4_packet.src) in + let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some _ -> ( + match src with + | `Client _ | `Firewall -> + Log.warn (fun f -> + f "Frame from NetVM has internal source IP address! %a" + Nat_packet.pp packet); + Lwt.return_unit + | (`External _ | `NetVM) as src -> ( + match translate t packet with + | Some frame -> forward_ipv4 t frame + | None -> ( + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some packet -> apply_rules t Rules.from_netvm ~dst packet))) + ) - let ipv4_from_client resolver dns_servers t ~src packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> ( - (* Check for existing NAT entry for this packet *) - match translate t packet with - | Some frame -> - forward_ipv4 t frame (* Some existing connection or redirect *) - | None -> ( - (* No existing NAT entry. Check the firewall rules. *) - let (`IPv4 (ip, _transport)) = packet in - match classify t (Ipaddr.V4 ip.Ipv4_packet.src) with - | `Client _ | `Firewall -> ( - let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in - match - Packet.of_mirage_nat_packet ~src:(`Client src) ~dst packet - with - | None -> Lwt.return_unit - | Some firewall_packet -> - apply_rules t - (Rules.from_client resolver dns_servers) - ~dst firewall_packet) - | `NetVM -> ipv4_from_netvm t packet - | `External _ -> - Log.warn (fun f -> - f "Frame from Inside has external source IP address! %a" - Nat_packet.pp packet); - Lwt.return_unit)) +let ipv4_from_client resolver dns_servers t ~src packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> ( + (* Check for existing NAT entry for this packet *) + match translate t packet with + | Some frame -> + forward_ipv4 t frame (* Some existing connection or redirect *) + | None -> ( + (* No existing NAT entry. Check the firewall rules. *) + let (`IPv4 (ip, _transport)) = packet in + match classify t (Ipaddr.V4 ip.Ipv4_packet.src) with + | `Client _ | `Firewall -> ( + let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match + Packet.of_mirage_nat_packet ~src:(`Client src) ~dst packet + with + | None -> Lwt.return_unit + | Some firewall_packet -> + apply_rules t + (Rules.from_client resolver dns_servers) + ~dst firewall_packet) + | `NetVM -> ipv4_from_netvm t packet + | `External _ -> + Log.warn (fun f -> + f "Frame from Inside has external source IP address! %a" + Nat_packet.pp packet); + Lwt.return_unit)) - (** Handle an ARP message from the client. *) - let client_handle_arp ~fixed_arp ~iface request = - match Arp_packet.decode request with - | Error e -> - Log.warn (fun f -> - f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); - Lwt.return_unit - | Ok arp -> ( - match Client_eth.ARP.input fixed_arp arp with - | None -> Lwt.return_unit - | Some response -> +(** Handle an ARP message from the client. *) +let client_handle_arp ~fixed_arp ~iface request = + match Arp_packet.decode request with + | Error e -> + Log.warn (fun f -> + f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); + Lwt.return_unit + | Ok arp -> ( + match Client_eth.ARP.input fixed_arp arp with + | None -> Lwt.return_unit + | Some response -> Lwt.catch (fun () -> - iface#writev `ARP (fun b -> - Arp_packet.encode_into response b; - Arp_packet.size)) + iface#writev `ARP (fun b -> + Arp_packet.encode_into response b; + Arp_packet.size)) (fun ex -> Log.warn (fun f -> f "Failed to write APR to %a: %s" Ipaddr.V4.pp iface#other_ip (Printexc.to_string ex)); - Lwt.return_unit) - ) + Lwt.return_unit)) - (** Handle an IPv4 packet from the client. *) - let client_handle_ipv4 get_ts cache ~iface ~router dns_client dns_servers - packet = - let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in - cache := cache'; - match r with - | Error e -> +(** Handle an IPv4 packet from the client. *) +let client_handle_ipv4 get_ts cache ~iface ~router dns_client dns_servers packet + = + let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in + cache := cache'; + match r with + | Error e -> + Log.warn (fun f -> + f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); + Lwt.return_unit + | Ok None -> Lwt.return_unit + | Ok (Some packet) -> + let (`IPv4 (ip, _)) = packet in + let src = ip.Ipv4_packet.src in + if src = iface#other_ip then + ipv4_from_client dns_client dns_servers router ~src:iface packet + else if iface#other_ip = router.config.netvm_ip then + (* This can occurs when used with *BSD as netvm (and a gateway is set) *) + ipv4_from_netvm router packet + else ( Log.warn (fun f -> - f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); - Lwt.return_unit - | Ok None -> Lwt.return_unit - | Ok (Some packet) -> - let (`IPv4 (ip, _)) = packet in - let src = ip.Ipv4_packet.src in - if src = iface#other_ip then - ipv4_from_client dns_client dns_servers router ~src:iface packet - else if iface#other_ip = router.config.netvm_ip then - (* This can occurs when used with *BSD as netvm (and a gateway is set) *) - ipv4_from_netvm router packet - else ( - Log.warn (fun f -> - f "Incorrect source IP %a in IP packet from %a (dropping)" - Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip); - Lwt.return_unit) + f "Incorrect source IP %a in IP packet from %a (dropping)" + Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip); + Lwt.return_unit) - (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) - let conf_vif get_ts vif backend client_eth dns_client dns_servers - ~client_ip ~iface ~router ~cleanup_tasks qubesDB () = - let { Dao.ClientVif.domid; device_id } = vif in - Log.info (fun f -> - f "Client %d:%d (IP: %s) ready" domid device_id (Ipaddr.V4.to_string client_ip)); +(** Connect to a new client's interface and listen for incoming frames and + firewall rule changes. *) +let conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip + ~iface ~router ~cleanup_tasks qubesDB () = + let { Dao.ClientVif.domid; device_id } = vif in + Log.info (fun f -> + f "Client %d:%d (IP: %s) ready" domid device_id + (Ipaddr.V4.to_string client_ip)); - (* update the rules whenever QubesDB notices a change for this IP *) - let qubesdb_updater = - Lwt.catch - (fun () -> - let rec update current_db current_rules = - Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db - >>= fun new_db -> - iface#set_rules new_db; - let new_rules = iface#get_rules in - if current_rules = new_rules then - Log.info (fun m -> - m "Rules did not change for %s" - (Ipaddr.V4.to_string client_ip)) - else ( - Log.info (fun m -> - m "New firewall rules for %s@.%a" - (Ipaddr.V4.to_string client_ip) - Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) - new_rules); - (* empty NAT table if rules are updated: they might deny old connections *) - My_nat.remove_connections router.nat client_ip); - update new_db new_rules - in - update Qubes.DB.KeyMap.empty []) - (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) - in - Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); + (* update the rules whenever QubesDB notices a change for this IP *) + let qubesdb_updater = + Lwt.catch + (fun () -> + let rec update current_db current_rules = + Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db + >>= fun new_db -> + iface#set_rules new_db; + let new_rules = iface#get_rules in + if current_rules = new_rules then + Log.info (fun m -> + m "Rules did not change for %s" (Ipaddr.V4.to_string client_ip)) + else ( + Log.info (fun m -> + m "New firewall rules for %s@.%a" + (Ipaddr.V4.to_string client_ip) + Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) + new_rules); + (* empty NAT table if rules are updated: they might deny old connections *) + My_nat.remove_connections router.nat client_ip); + update new_db new_rules + in + update Qubes.DB.KeyMap.empty []) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); - let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in - let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in - let listener = - Lwt.catch - (fun () -> - Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet - (fun frame -> - match Ethernet.Packet.of_cstruct frame with - | Error err -> - Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); - Lwt.return_unit - | Ok (eth, payload) -> ( - match eth.Ethernet.Packet.ethertype with - | `ARP -> client_handle_arp ~fixed_arp ~iface payload - | `IPv4 -> - client_handle_ipv4 get_ts fragment_cache ~iface ~router - dns_client dns_servers payload - | `IPv6 -> Lwt.return_unit (* TODO: oh no! *))) - >|= or_raise "Listen on client interface" Netback.pp_error) - (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) - in - Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] + let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in + let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in + let listener = + Lwt.catch + (fun () -> + Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet + (fun frame -> + match Ethernet.Packet.of_cstruct frame with + | Error err -> + Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); + Lwt.return_unit + | Ok (eth, payload) -> ( + match eth.Ethernet.Packet.ethertype with + | `ARP -> client_handle_arp ~fixed_arp ~iface payload + | `IPv4 -> + client_handle_ipv4 get_ts fragment_cache ~iface ~router + dns_client dns_servers payload + | `IPv6 -> Lwt.return_unit (* TODO: oh no! *))) + >|= or_raise "Listen on client interface" Netback.pp_error) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); + (* NOTE(dinosaure): [qubes_updater] and [listener] can be forgotten, our [cleanup_task] will cancel them if the client is disconnected. *) - Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); + Lwt.async (fun () -> Lwt.pick [ qubesdb_updater; listener ]); + Lwt.return_unit + +(** A new client VM has been found in XenStore. Find its interface and connect + to it. *) +let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = + let open Lwt.Syntax in + let cleanup_tasks = Cleanup.create () in + Log.info (fun f -> + f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp + client_ip); + let { Dao.ClientVif.domid; device_id } = vif in + let* backend = Netback.make ~domid ~device_id in + let* eth = ClientEth.connect backend in + let client_mac = Netback.frontend_mac backend in + let client_eth = router.clients in + let gateway_ip = Client_eth.client_gw client_eth in + let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in + + Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); + Lwt.async (fun () -> + Lwt.catch + (fun () -> add_client router iface) + (fun ex -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string ex)); + Lwt.return_unit)); + + let* () = + Lwt.catch + (conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip + ~iface ~router ~cleanup_tasks qubesDB) + @@ fun exn -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string exn)); Lwt.return_unit + in + Lwt.return cleanup_tasks - (** A new client VM has been found in XenStore. Find its interface and connect to it. *) - let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = - let open Lwt.Syntax in - let cleanup_tasks = Cleanup.create () in - Log.info (fun f -> - f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp - client_ip); - let { Dao.ClientVif.domid; device_id } = vif in - let* backend = Netback.make ~domid ~device_id in - let* eth = ClientEth.connect backend in - let client_mac = Netback.frontend_mac backend in - let client_eth = router.clients in - let gateway_ip = Client_eth.client_gw client_eth in - let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in - - Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); - Lwt.async (fun () -> - Lwt.catch - (fun () -> - add_client router iface) - (fun ex -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string ex)); - Lwt.return_unit)) ; - - let* () = - Lwt.catch ( - conf_vif get_ts vif backend client_eth dns_client dns_servers ~client_ip ~iface ~router - ~cleanup_tasks qubesDB) - @@ fun exn -> - Log.warn (fun f -> - f "Error with client %a: %s" Dao.ClientVif.pp vif - (Printexc.to_string exn)); - Lwt.return_unit - in - Lwt.return cleanup_tasks - - (** Watch XenStore for notifications of new clients. *) - let wait_clients get_ts dns_client dns_servers qubesDB router = - let open Lwt.Syntax in - let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in - Dao.watch_clients @@ fun new_set -> - (* Check for removed clients *) - let clean_up_clients key cleanup = - if not (Dao.VifMap.mem key new_set) then begin - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup - end - in - Dao.VifMap.iter clean_up_clients !clients; - (* Check for added clients *) - let rec go seq = match Seq.uncons seq with - | None -> Lwt.return_unit - | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> - let* cleanup = add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB in +(** Watch XenStore for notifications of new clients. *) +let wait_clients get_ts dns_client dns_servers qubesDB router = + let open Lwt.Syntax in + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty in + Dao.watch_clients @@ fun new_set -> + (* Check for removed clients *) + let clean_up_clients key cleanup = + if not (Dao.VifMap.mem key new_set) then ( + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup) + in + Dao.VifMap.iter clean_up_clients !clients; + (* Check for added clients *) + let rec go seq = + match Seq.uncons seq with + | None -> Lwt.return_unit + | Some ((key, ipaddr), seq) when not (Dao.VifMap.mem key !clients) -> + let* cleanup = + add_client get_ts dns_client dns_servers ~router key ipaddr qubesDB + in Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); clients := Dao.VifMap.add key cleanup !clients; go seq - | Some (_, seq) -> go seq - in - go (Dao.VifMap.to_seq new_set) + | Some (_, seq) -> go seq + in + go (Dao.VifMap.to_seq new_set) - let send_dns_client_query t ~src_port ~dst ~dst_port buf = - match t.uplink with - | None -> - Log.err (fun f -> f "No uplink interface"); - Lwt.return (Error (`Msg "failure")) - | Some uplink -> ( - Lwt.catch - (fun () -> - 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") - | Ok () -> Ok ()) - (fun ex -> - Log.err (fun f -> - f "uncaught exception trying to send DNS request to uplink: @[%s@]" - (Printexc.to_string ex)); - Lwt.return (Error (`Msg "DNS request not sent")))) - - (** Wait for packet from our uplink (we must have an uplink here...). *) - let rec uplink_listen get_ts dns_responses router = - Lwt_condition.wait router.uplink_connected >>= fun () -> - match router.uplink with - | None -> +let send_dns_client_query t ~src_port ~dst ~dst_port buf = + match t.uplink with + | None -> + Log.err (fun f -> f "No uplink interface"); + Lwt.return (Error (`Msg "failure")) + | Some uplink -> + Lwt.catch + (fun () -> + 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") + | Ok () -> Ok ()) + (fun ex -> Log.err (fun f -> f - "Uplink is connected but not found in the router, retrying...%!"); - uplink_listen get_ts dns_responses router - | Some uplink -> - let listen = - Lwt.catch - (fun () -> - Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet - (fun frame -> - (* Handle one Ethernet frame from NetVM *) - UplinkEth.input uplink.eth ~arpv4:(Arp.input uplink.arp) - ~ipv4:(fun ip -> - let cache, r = - Nat_packet.of_ipv4_packet uplink.fragments ~now:(get_ts ()) - ip - in - uplink.fragments <- cache; - begin match r with - | Error e -> - Log.warn (fun f -> - f "Ignored unknown IPv4 message from uplink: %a" - Nat_packet.pp_error e); - Lwt.return () - | Ok None -> Lwt.return_unit - | Ok (Some (`IPv4 (header, packet))) -> - let open Udp_packet in - Log.debug (fun f -> - f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp - header.Ipv4_packet.src); - begin match packet with - | `UDP (header, packet) when My_nat.dns_port router.nat header.dst_port -> - Log.debug (fun f -> - f - "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, Cstruct.to_string packet) - | _ -> ipv4_from_netvm router (`IPv4 (header, packet)) - end - end) - ~ipv6:(fun _ip -> Lwt.return_unit) - frame) - >|= or_raise "Uplink listen loop" Netif.pp_error) - (function Lwt.Canceled -> - (* We can be cancelled if reconnect_uplink is achieved (via the Lwt_condition), so we need to disconnect and broadcast when it's done - currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *) - Log.info (fun f -> - f "disconnecting from our uplink"); - U.disconnect uplink.udp >>= fun () -> - I.disconnect uplink.ip >>= fun () -> - (* mutable fragments : Fragments.Cache.t; *) - (* interface : interface; *) - Arp.disconnect uplink.arp >>= fun () -> - UplinkEth.disconnect uplink.eth >>= fun () -> - Netif.disconnect uplink.net >>= fun () -> - Lwt_condition.broadcast router.uplink_disconnected (); - Lwt.return_unit - | e -> Lwt.fail e) - in - let reconnect_uplink = - Lwt_condition.wait router.uplink_disconnect >>= fun () -> - Log.info (fun f -> - f "we need to reconnect to the new uplink"); - Lwt.return_unit - in - Lwt.pick [ listen ; reconnect_uplink ] >>= fun () -> - uplink_listen get_ts dns_responses router + "uncaught exception trying to send DNS request to uplink: \ + @[%s@]" + (Printexc.to_string ex)); + Lwt.return (Error (`Msg "DNS request not sent"))) - (** Connect to our uplink backend (we must have an uplink here...). *) - let connect config = - let my_ip = config.Dao.our_ip in - let gateway = config.Dao.netvm_ip in - Netif.connect "0" >>= fun net -> - UplinkEth.connect net >>= fun eth -> - Arp.connect eth >>= fun arp -> - Arp.add_ip arp my_ip >>= fun () -> - let cidr = Ipaddr.V4.Prefix.make 0 my_ip in - I.connect ~cidr ~gateway eth arp >>= fun ip -> - U.connect ip >>= fun udp -> - let netvm_mac = - Arp.query arp gateway >>= function - | Error e -> - Log.err(fun f -> f "Getting MAC of our NetVM: %a" Arp.pp_error e); - (* This mac address is a special address used by Qubes when the device +(** Wait for packet from our uplink (we must have an uplink here...). *) +let rec uplink_listen get_ts dns_responses router = + Lwt_condition.wait router.uplink_connected >>= fun () -> + match router.uplink with + | None -> + Log.err (fun f -> + f "Uplink is connected but not found in the router, retrying...%!"); + uplink_listen get_ts dns_responses router + | Some uplink -> + let listen = + Lwt.catch + (fun () -> + Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet + (fun frame -> + (* Handle one Ethernet frame from NetVM *) + UplinkEth.input uplink.eth ~arpv4:(Arp.input uplink.arp) + ~ipv4:(fun ip -> + let cache, r = + Nat_packet.of_ipv4_packet uplink.fragments + ~now:(get_ts ()) ip + in + uplink.fragments <- cache; + match r with + | Error e -> + Log.warn (fun f -> + f "Ignored unknown IPv4 message from uplink: %a" + Nat_packet.pp_error e); + Lwt.return () + | Ok None -> Lwt.return_unit + | Ok (Some (`IPv4 (header, packet))) -> ( + let open Udp_packet in + Log.debug (fun f -> + f "received ipv4 packet from %a on uplink" + Ipaddr.V4.pp header.Ipv4_packet.src); + match packet with + | `UDP (header, packet) + when My_nat.dns_port router.nat header.dst_port -> + Log.debug (fun f -> + f + "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, Cstruct.to_string packet) + | _ -> ipv4_from_netvm router (`IPv4 (header, packet)))) + ~ipv6:(fun _ip -> Lwt.return_unit) + frame) + >|= or_raise "Uplink listen loop" Netif.pp_error) + (function + | Lwt.Canceled -> + (* We can be cancelled if reconnect_uplink is achieved (via the Lwt_condition), so we need to disconnect and broadcast when it's done + currently we delay 1s as Netif.disconnect is non-blocking... (need to fix upstream?) *) + Log.info (fun f -> f "disconnecting from our uplink"); + U.disconnect uplink.udp >>= fun () -> + I.disconnect uplink.ip >>= fun () -> + (* mutable fragments : Fragments.Cache.t; *) + (* interface : interface; *) + Arp.disconnect uplink.arp >>= fun () -> + UplinkEth.disconnect uplink.eth >>= fun () -> + Netif.disconnect uplink.net >>= fun () -> + Lwt_condition.broadcast router.uplink_disconnected (); + Lwt.return_unit + | e -> Lwt.fail e) + in + let reconnect_uplink = + Lwt_condition.wait router.uplink_disconnect >>= fun () -> + Log.info (fun f -> f "we need to reconnect to the new uplink"); + Lwt.return_unit + in + Lwt.pick [ listen; reconnect_uplink ] >>= fun () -> + uplink_listen get_ts dns_responses router + +(** Connect to our uplink backend (we must have an uplink here...). *) +let connect config = + let my_ip = config.Dao.our_ip in + let gateway = config.Dao.netvm_ip in + Netif.connect "0" >>= fun net -> + UplinkEth.connect net >>= fun eth -> + Arp.connect eth >>= fun arp -> + Arp.add_ip arp my_ip >>= fun () -> + let cidr = Ipaddr.V4.Prefix.make 0 my_ip in + I.connect ~cidr ~gateway eth arp >>= fun ip -> + U.connect ip >>= fun udp -> + let netvm_mac = + Arp.query arp gateway >>= function + | Error e -> + Log.err (fun f -> f "Getting MAC of our NetVM: %a" Arp.pp_error e); + (* This mac address is a special address used by Qubes when the device is not managed by Qubes itself. This can occurs inside a service AppVM (e.g. VPN) when the service creates a new interface. *) - Lwt.return (Macaddr.of_string_exn "fe:ff:ff:ff:ff:ff") - | Ok mac -> Lwt.return mac - in - let interface = - new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip - in - let fragments = Fragments.Cache.empty (256 * 1024) in - Lwt.return { net; eth; arp; interface; fragments; ip; udp } + Lwt.return (Macaddr.of_string_exn "fe:ff:ff:ff:ff:ff") + | Ok mac -> Lwt.return mac + in + let interface = + new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip + in + let fragments = Fragments.Cache.empty (256 * 1024) in + Lwt.return { net; eth; arp; interface; fragments; ip; udp } - (** Wait Xenstore for our uplink changes (we must have an uplink here...). *) - let uplink_wait_update qubesDB router = - let rec aux current_db = - let netvm = "/qubes-gateway" in - Log.info (fun f -> f "Waiting for netvm changes to %S...%!" netvm); - Qubes.DB.after qubesDB current_db >>= fun new_db -> - (match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with - | Some uplink, Some netvm - when not - (String.equal netvm - (Ipaddr.V4.to_string uplink.interface#other_ip)) -> - Log.info (fun f -> - f "Our netvm IP has changed, before it was %s, now it's: %s%!" - (Ipaddr.V4.to_string uplink.interface#other_ip) - netvm); - Lwt_condition.broadcast router.uplink_disconnect (); - (* wait for uplink disconnexion *) - Lwt_condition.wait router.uplink_disconnected >>= fun () -> - Dao.read_network_config qubesDB >>= fun config -> - Dao.print_network_config config; - connect config >>= fun uplink -> - update router ~config ~uplink:(Some uplink) >>= fun () -> - Lwt_condition.broadcast router.uplink_connected (); - Lwt.return_unit - | None, Some _ -> - (* a new interface is attributed to qubes-mirage-firewall *) - Log.info (fun f -> f "Going from netvm not connected to %s%!" netvm); - Dao.read_network_config qubesDB >>= fun config -> - Dao.print_network_config config; - connect config >>= fun uplink -> - update router ~config ~uplink:(Some uplink) >>= fun () -> - Lwt_condition.broadcast router.uplink_connected (); - Lwt.return_unit - | Some _, None -> - (* This currently is never triggered :( *) - Log.info (fun f -> - f "TODO: Our netvm disapeared, troubles are coming!%!"); - Lwt.return_unit - | Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *) - | None, None -> - Log.info (fun f -> - f "QubesDB has changed but not the situation of our netvm!%!"); - Lwt.return_unit) - >>= fun () -> aux new_db - in - aux Qubes.DB.KeyMap.empty +(** Wait Xenstore for our uplink changes (we must have an uplink here...). *) +let uplink_wait_update qubesDB router = + let rec aux current_db = + let netvm = "/qubes-gateway" in + Log.info (fun f -> f "Waiting for netvm changes to %S...%!" netvm); + Qubes.DB.after qubesDB current_db >>= fun new_db -> + (match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with + | Some uplink, Some netvm + when not + (String.equal netvm + (Ipaddr.V4.to_string uplink.interface#other_ip)) -> + Log.info (fun f -> + f "Our netvm IP has changed, before it was %s, now it's: %s%!" + (Ipaddr.V4.to_string uplink.interface#other_ip) + netvm); + Lwt_condition.broadcast router.uplink_disconnect (); + (* wait for uplink disconnexion *) + Lwt_condition.wait router.uplink_disconnected >>= fun () -> + Dao.read_network_config qubesDB >>= fun config -> + Dao.print_network_config config; + connect config >>= fun uplink -> + update router ~config ~uplink:(Some uplink) >>= fun () -> + Lwt_condition.broadcast router.uplink_connected (); + Lwt.return_unit + | None, Some _ -> + (* a new interface is attributed to qubes-mirage-firewall *) + Log.info (fun f -> f "Going from netvm not connected to %s%!" netvm); + Dao.read_network_config qubesDB >>= fun config -> + Dao.print_network_config config; + connect config >>= fun uplink -> + update router ~config ~uplink:(Some uplink) >>= fun () -> + Lwt_condition.broadcast router.uplink_connected (); + Lwt.return_unit + | Some _, None -> + (* This currently is never triggered :( *) + Log.info (fun f -> + f "TODO: Our netvm disapeared, troubles are coming!%!"); + Lwt.return_unit + | Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *) + | None, None -> + Log.info (fun f -> + f "QubesDB has changed but not the situation of our netvm!%!"); + Lwt.return_unit) + >>= fun () -> aux new_db + in + aux Qubes.DB.KeyMap.empty diff --git a/fw_utils.ml b/fw_utils.ml index f20c63a..53fddb0 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -15,14 +15,16 @@ end class type client_link = object inherit interface method other_mac : Macaddr.t - method log_header : string (* For log messages *) - method get_rules: Pf_qubes.Parse_qubes.rule list - method set_rules: string Qubes.DB.KeyMap.t -> unit + method log_header : string (* For log messages *) + method get_rules : Pf_qubes.Parse_qubes.rule list + method set_rules : string Qubes.DB.KeyMap.t -> unit end -(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *) +(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. +*) let eth_header ethertype ~src ~dst = - Ethernet.Packet.make_cstruct { Ethernet.Packet.source = src; destination = dst; ethertype } + Ethernet.Packet.make_cstruct + { Ethernet.Packet.source = src; destination = dst; ethertype } let error fmt = let err s = Failure s in diff --git a/memory_pressure.ml b/memory_pressure.ml index 667bd50..fe04bca 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -2,14 +2,14 @@ See the README file for details. *) let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor" + module Log = (val Logs.src_log src : Logs.LOG) let fraction_free stats = let { Xen_os.Memory.free_words; heap_words; _ } = stats in float free_words /. float heap_words -let init () = - Gc.full_major () +let init () = Gc.full_major () let status () = let stats = Xen_os.Memory.quick_stat () in @@ -18,6 +18,4 @@ let status () = Gc.full_major (); Xen_os.Memory.trim (); let stats = Xen_os.Memory.quick_stat () in - if fraction_free stats < 0.6 then `Memory_critical - else `Ok - ) + if fraction_free stats < 0.6 then `Memory_critical else `Ok) diff --git a/memory_pressure.mli b/memory_pressure.mli index c0d9f49..f0d7df8 100644 --- a/memory_pressure.mli +++ b/memory_pressure.mli @@ -8,5 +8,5 @@ val status : unit -> [ `Ok | `Memory_critical ] (** Check the memory situation. If we're running low, do a GC (work-around for http://caml.inria.fr/mantis/view.php?id=7100 and OCaml GC needing to malloc extra space to run finalisers). Returns [`Memory_critical] if memory is - still low - caller should take action to reduce memory use. - After GC, updates meminfo in XenStore. *) + still low - caller should take action to reduce memory use. After GC, + updates meminfo in XenStore. *) diff --git a/my_dns.ml b/my_dns.ml index 6000e80..e3bb267 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -1,72 +1,81 @@ open Lwt.Infix - type +'a io = 'a Lwt.t - type io_addr = Ipaddr.V4.t * int - 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 +type +'a io = 'a Lwt.t +type io_addr = Ipaddr.V4.t * int - module IM = Map.Make(Int) +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 - type t = { - protocol : Dns.proto ; - nameserver : io_addr ; - stack : stack ; - timeout_ns : int64 ; - mutable requests : string Lwt_condition.t IM.t ; - } - type context = t +module IM = Map.Make (Int) - let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ] - let rng = Mirage_crypto_rng.generate ?g:None - let clock = Mirage_mtime.elapsed_ns +type t = { + protocol : Dns.proto; + nameserver : io_addr; + stack : stack; + timeout_ns : int64; + mutable requests : string Lwt_condition.t IM.t; +} - let rec read t = - let _, _, answer = t.stack in - Lwt_mvar.take answer >>= fun (_, data) -> - 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; - read t +type context = t - let create ?nameservers ~timeout stack = - let protocol, nameserver = match nameservers with - | None | Some (_, []) -> invalid_arg "no nameserver found" - | Some (proto, ns :: _) -> proto, ns - in - let t = - { protocol ; nameserver ; stack ; timeout_ns = timeout ; requests = IM.empty } - in - Lwt.async (fun () -> read t); - t +let nameservers { protocol; nameserver; _ } = (protocol, [ nameserver ]) +let rng = Mirage_crypto_rng.generate ?g:None +let clock = Mirage_mtime.elapsed_ns - let with_timeout timeout_ns f = - let timeout = Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in - Lwt.pick [ f ; timeout ] +let rec read t = + let _, _, answer = t.stack in + Lwt_mvar.take answer >>= fun (_, data) -> + (if String.length data > 2 then + match IM.find_opt (String.get_uint16_be data 0) t.requests with + | Some cond -> Lwt_condition.broadcast cond data + | None -> ()); + read t - let connect (t : t) = Lwt.return (Ok (t.protocol, t)) +let create ?nameservers ~timeout stack = + let protocol, nameserver = + match nameservers with + | None | Some (_, []) -> invalid_arg "no nameserver found" + | Some (proto, ns :: _) -> (proto, ns) + in + let t = + { protocol; nameserver; stack; timeout_ns = timeout; requests = IM.empty } + in + Lwt.async (fun () -> read t); + 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 = 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; - (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) >>= function - | Ok () -> Lwt_condition.wait cond >|= fun dns_response -> Ok dns_response - | Error _ as e -> Lwt.return e) >|= fun result -> - ctx.requests <- IM.remove id ctx.requests; - evict (); - result +let with_timeout timeout_ns f = + let timeout = + Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") + in + Lwt.pick [ f; timeout ] - let close _ = Lwt.return_unit +let connect (t : t) = Lwt.return (Ok (t.protocol, t)) - let bind = Lwt.bind +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 = 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; + send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg + >>= function + | Ok () -> Lwt_condition.wait cond >|= fun dns_response -> Ok dns_response + | Error _ as e -> Lwt.return e) + >|= fun result -> + ctx.requests <- IM.remove id ctx.requests; + evict (); + result - let lift = Lwt.return +let close _ = Lwt.return_unit +let bind = Lwt.bind +let lift = Lwt.return diff --git a/my_nat.ml b/my_nat.ml index 1e86c2d..e6b70e6 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -2,65 +2,57 @@ See the README file for details. *) let src = Logs.Src.create "my-nat" ~doc:"NAT shim" + module Log = (val Logs.src_log src : Logs.LOG) -type action = [ - | `NAT - | `Redirect of Mirage_nat.endpoint -] +type action = [ `NAT | `Redirect of Mirage_nat.endpoint ] module Nat = Mirage_nat_lru -module S = - Set.Make(struct type t = int let compare (a : int) (b : int) = compare a b end) +module S = Set.Make (struct + type t = int -type t = { - table : Nat.t; - mutable udp_dns : S.t; - last_resort_port : int -} + let compare (a : int) (b : int) = compare a b +end) -let pick_port () = - 1024 + Random.int (0xffff - 1024) +type t = { table : Nat.t; mutable udp_dns : S.t; last_resort_port : int } + +let pick_port () = 1024 + Random.int (0xffff - 1024) let create ~max_entries = let tcp_size = 7 * max_entries / 8 in let udp_size = max_entries - tcp_size in let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in let last_resort_port = pick_port () in - { table ; udp_dns = S.empty ; last_resort_port } + { table; udp_dns = S.empty; last_resort_port } let pick_free_port t proto = let rec go retries = - if retries = 0 then - None + if retries = 0 then None else let p = 1024 + Random.int (0xffff - 1024) in match proto with - | `Udp when S.mem p t.udp_dns || p = t.last_resort_port -> - go (retries - 1) + | `Udp when S.mem p t.udp_dns || p = t.last_resort_port -> go (retries - 1) | _ -> Some p in go 10 let free_udp_port t ~src ~dst ~dst_port = let rec go retries = - if retries = 0 then - t.last_resort_port, Fun.id + if retries = 0 then (t.last_resort_port, Fun.id) else let src_port = Option.value ~default:t.last_resort_port (pick_free_port t `Udp) in - if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then begin + if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then let remove = - if src_port <> t.last_resort_port then begin + if src_port <> t.last_resort_port then ( t.udp_dns <- S.add src_port t.udp_dns; - (fun () -> t.udp_dns <- S.remove src_port t.udp_dns) - end else Fun.id + fun () -> t.udp_dns <- S.remove src_port t.udp_dns) + else Fun.id in - src_port, remove - end else - go (retries - 1) + (src_port, remove) + else go (retries - 1) in go 10 @@ -68,27 +60,27 @@ let dns_port t port = S.mem port t.udp_dns || port = t.last_resort_port let translate t packet = match Nat.translate t.table packet with - | Error (`Untranslated | `TTL_exceeded as e) -> - Log.debug (fun f -> f "Failed to NAT %a: %a" - Nat_packet.pp packet - Mirage_nat.pp_error e - ); - None + | Error ((`Untranslated | `TTL_exceeded) as e) -> + Log.debug (fun f -> + f "Failed to NAT %a: %a" Nat_packet.pp packet Mirage_nat.pp_error e); + None | Ok packet -> Some packet -let remove_connections t ip = - ignore (Nat.remove_connections t.table ip) +let remove_connections t ip = ignore (Nat.remove_connections t.table ip) let add_nat_rule_and_translate t ~xl_host action packet = - let proto = match packet with + let proto = + match packet with | `IPv4 (_, `TCP _) -> `Tcp | `IPv4 (_, `UDP _) -> `Udp | `IPv4 (_, `ICMP _) -> `Icmp in - match Nat.add t.table packet xl_host (fun () -> pick_free_port t proto) action with + match + Nat.add t.table packet xl_host (fun () -> pick_free_port t proto) action + with | Error `Overlap -> Error "Too many retries" | Error `Cannot_NAT -> Error "Cannot NAT this packet" | Ok () -> - Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); - Option.to_result ~none:"No NAT entry, even after adding one!" - (translate t packet) + Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); + Option.to_result ~none:"No NAT entry, even after adding one!" + (translate t packet) diff --git a/my_nat.mli b/my_nat.mli index eab1a34..a9d3829 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -4,17 +4,23 @@ (* Abstract over NAT interface (todo: remove this) *) type t +type action = [ `NAT | `Redirect of Mirage_nat.endpoint ] -type action = [ - | `NAT - | `Redirect of Mirage_nat.endpoint -] - -val free_udp_port : t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> dst_port:int -> +val free_udp_port : + t -> + src:Ipaddr.V4.t -> + dst:Ipaddr.V4.t -> + dst_port:int -> int * (unit -> unit) + val dns_port : t -> int -> bool val create : max_entries:int -> t val remove_connections : t -> Ipaddr.V4.t -> unit val translate : t -> Nat_packet.t -> Nat_packet.t option -val add_nat_rule_and_translate : t -> - xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result + +val add_nat_rule_and_translate : + t -> + xl_host:Ipaddr.V4.t -> + action -> + Nat_packet.t -> + (Nat_packet.t, string) result diff --git a/packet.ml b/packet.ml index 7d8c3c4..d6d4f92 100644 --- a/packet.ml +++ b/packet.ml @@ -8,9 +8,8 @@ type port = int type host = [ `Client of client_link | `Firewall | `NetVM | `External of Ipaddr.t ] -type transport_header = [`TCP of Tcp.Tcp_packet.t - |`UDP of Udp_packet.t - |`ICMP of Icmpv4_packet.t] +type transport_header = + [ `TCP of Tcp.Tcp_packet.t | `UDP of Udp_packet.t | `ICMP of Icmpv4_packet.t ] type ('src, 'dst) t = { ipv4_header : Ipv4_packet.t; @@ -19,13 +18,14 @@ type ('src, 'dst) t = { src : 'src; dst : 'dst; } + let pp_transport_header f = function | `ICMP h -> Icmpv4_packet.pp f h | `TCP h -> Tcp.Tcp_packet.pp f h | `UDP h -> Udp_packet.pp f h let pp_host fmt = function - | `Client c -> Ipaddr.V4.pp fmt (c#other_ip) + | `Client c -> Ipaddr.V4.pp fmt c#other_ip | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp ip | `NetVM -> Format.pp_print_string fmt "net-vm" | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp ip @@ -33,32 +33,28 @@ let pp_host fmt = function let to_mirage_nat_packet t : Nat_packet.t = match t.transport_header with - | `TCP h -> `IPv4 (t.ipv4_header, (`TCP (h, t.transport_payload))) - | `UDP h -> `IPv4 (t.ipv4_header, (`UDP (h, t.transport_payload))) - | `ICMP h -> `IPv4 (t.ipv4_header, (`ICMP (h, t.transport_payload))) + | `TCP h -> `IPv4 (t.ipv4_header, `TCP (h, t.transport_payload)) + | `UDP h -> `IPv4 (t.ipv4_header, `UDP (h, t.transport_payload)) + | `ICMP h -> `IPv4 (t.ipv4_header, `ICMP (h, t.transport_payload)) let of_mirage_nat_packet ~src ~dst packet : ('a, 'b) t option = - let `IPv4 (ipv4_header, ipv4_payload) = packet in - let transport_header, transport_payload = match ipv4_payload with - | `TCP (h, p) -> `TCP h, p - | `UDP (h, p) -> `UDP h, p - | `ICMP (h, p) -> `ICMP h, p + let (`IPv4 (ipv4_header, ipv4_payload)) = packet in + let transport_header, transport_payload = + match ipv4_payload with + | `TCP (h, p) -> (`TCP h, p) + | `UDP (h, p) -> (`UDP h, p) + | `ICMP (h, p) -> (`ICMP h, p) in - Some { - ipv4_header; - transport_header; - transport_payload; - src; - dst; - } + Some { ipv4_header; transport_header; transport_payload; src; dst } (* possible actions to take for a packet: *) -type action = [ - | `Accept (* Send to destination, unmodified. *) - | `NAT (* Rewrite source field to the firewall's IP, with a fresh source port. +type action = + [ `Accept (* Send to destination, unmodified. *) + | `NAT + (* Rewrite source field to the firewall's IP, with a fresh source port. Also, add translation rules for future traffic in both directions, between these hosts on these ports, and corresponding ICMP error traffic. *) - | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's + | `NAT_to of host * port + (* As for [`NAT], but also rewrite the packet's destination fields so it will be sent to [host:port]. *) - | `Drop of string (* Drop packet for this reason. *) -] + | `Drop of string (* Drop packet for this reason. *) ] diff --git a/packet.mli b/packet.mli index f7d2876..af8ee43 100644 --- a/packet.mli +++ b/packet.mli @@ -1,15 +1,13 @@ type port = int type host = - [ `Client of Fw_utils.client_link (** an IP address on the private network *) - | `Firewall (** the firewall's IP on the private network *) - | `NetVM (** the IP of the firewall's default route *) - | `External of Ipaddr.t (** an IP on the public network *) - ] + [ `Client of Fw_utils.client_link (** an IP address on the private network *) + | `Firewall (** the firewall's IP on the private network *) + | `NetVM (** the IP of the firewall's default route *) + | `External of Ipaddr.t (** an IP on the public network *) ] -type transport_header = [`TCP of Tcp.Tcp_packet.t - |`UDP of Udp_packet.t - |`ICMP of Icmpv4_packet.t] +type transport_header = + [ `TCP of Tcp.Tcp_packet.t | `UDP of Udp_packet.t | `ICMP of Icmpv4_packet.t ] type ('src, 'dst) t = { ipv4_header : Ipv4_packet.t; @@ -20,20 +18,18 @@ type ('src, 'dst) t = { } val pp_transport_header : Format.formatter -> transport_header -> unit - val pp_host : Format.formatter -> host -> unit - val to_mirage_nat_packet : ('a, 'b) t -> Nat_packet.t - val of_mirage_nat_packet : src:'a -> dst:'b -> Nat_packet.t -> ('a, 'b) t option (* possible actions to take for a packet: *) -type action = [ - | `Accept (* Send to destination, unmodified. *) - | `NAT (* Rewrite source field to the firewall's IP, with a fresh source port. +type action = + [ `Accept (* Send to destination, unmodified. *) + | `NAT + (* Rewrite source field to the firewall's IP, with a fresh source port. Also, add translation rules for future traffic in both directions, between these hosts on these ports, and corresponding ICMP error traffic. *) - | `NAT_to of host * port (* As for [`NAT], but also rewrite the packet's + | `NAT_to of host * port + (* As for [`NAT], but also rewrite the packet's destination fields so it will be sent to [host:port]. *) - | `Drop of string (* Drop packet for this reason. *) -] + | `Drop of string (* Drop packet for this reason. *) ] diff --git a/rules.ml b/rules.ml index 9210b47..c85a596 100644 --- a/rules.ml +++ b/rules.ml @@ -8,93 +8,115 @@ open Lwt.Infix module Q = Pf_qubes.Parse_qubes let src = Logs.Src.create "rules" ~doc:"Firewall rules" + module Log = (val Logs.src_log src : Logs.LOG) let dns_port = 53 module Classifier = struct - - let matches_port dstports (port : int) = match dstports with + let matches_port dstports (port : int) = + match dstports with | None -> true | Some (Q.Range_inclusive (min, max)) -> min <= port && port <= max - let matches_proto rule dns_servers packet = match rule.Q.proto, rule.Q.specialtarget with + let matches_proto rule dns_servers packet = + match (rule.Q.proto, rule.Q.specialtarget) with | None, None -> true - | None, Some `dns when List.mem packet.ipv4_header.Ipv4_packet.dst dns_servers -> begin - (* specialtarget=dns applies only to the specialtarget destination IPs, and + | None, Some `dns + when List.mem packet.ipv4_header.Ipv4_packet.dst dns_servers -> ( + (* specialtarget=dns applies only to the specialtarget destination IPs, and specialtarget=dns is also implicitly tcp/udp port 53 *) - match packet.transport_header with + match packet.transport_header with | `TCP header -> header.Tcp.Tcp_packet.dst_port = dns_port | `UDP header -> header.Udp_packet.dst_port = dns_port - | _ -> false - end - (* DNS rules can only match traffic headed to the specialtarget hosts, so any other destination + | _ -> false) + (* DNS rules can only match traffic headed to the specialtarget hosts, so any other destination isn't a match for DNS rules *) | None, Some `dns -> false - | Some rule_proto, _ -> match rule_proto, packet.transport_header with - | `tcp, `TCP header -> matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port - | `udp, `UDP header -> matches_port rule.Q.dstports header.Udp_packet.dst_port - | `icmp, `ICMP header -> - begin - match rule.Q.icmp_type with - | None -> true - | Some rule_icmp_type -> - 0 = compare rule_icmp_type @@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty - end - | _, _ -> false + | Some rule_proto, _ -> ( + match (rule_proto, packet.transport_header) with + | `tcp, `TCP header -> + matches_port rule.Q.dstports header.Tcp.Tcp_packet.dst_port + | `udp, `UDP header -> + matches_port rule.Q.dstports header.Udp_packet.dst_port + | `icmp, `ICMP header -> ( + match rule.Q.icmp_type with + | None -> true + | Some rule_icmp_type -> + 0 + = compare rule_icmp_type + @@ Icmpv4_wire.ty_to_int header.Icmpv4_packet.ty) + | _, _ -> false) let matches_dest dns_client rule packet = let ip = packet.ipv4_header.Ipv4_packet.dst in match rule.Q.dst with - | `any -> Lwt.return @@ `Match rule + | `any -> Lwt.return @@ `Match rule | `hosts subnet -> - Lwt.return @@ if (Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet) then `Match rule else `No_match - | `dnsname name -> - Log.debug (fun f -> f "Resolving %a" Domain_name.pp name); - dns_client name >|= function - | Ok (_ttl, found_ips) -> - if Ipaddr.V4.Set.mem ip found_ips - then `Match rule + Lwt.return + @@ + if Ipaddr.Prefix.mem Ipaddr.(V4 ip) subnet then `Match rule else `No_match - | Error (`Msg m) -> - Log.warn (fun f -> f "Ignoring rule %a, could not resolve" Q.pp_rule rule); - Log.debug (fun f -> f "%s" m); - `No_match - | Error _ -> assert false (* TODO: fix type of dns_client so that this case can go *) - + | `dnsname name -> ( + Log.debug (fun f -> f "Resolving %a" Domain_name.pp name); + dns_client name >|= function + | Ok (_ttl, found_ips) -> + if Ipaddr.V4.Set.mem ip found_ips then `Match rule else `No_match + | Error (`Msg m) -> + Log.warn (fun f -> + f "Ignoring rule %a, could not resolve" Q.pp_rule rule); + Log.debug (fun f -> f "%s" m); + `No_match + | Error _ -> + assert + false (* TODO: fix type of dns_client so that this case can go *)) end let find_first_match dns_client dns_servers packet acc rule = match acc with | `No_match -> - if Classifier.matches_proto rule dns_servers packet - then Classifier.matches_dest dns_client rule packet - else Lwt.return `No_match + if Classifier.matches_proto rule dns_servers packet then + Classifier.matches_dest dns_client rule packet + else Lwt.return `No_match | q -> Lwt.return q (* Does the packet match our rules? *) -let classify_client_packet dns_client dns_servers (packet : ([`Client of Fw_utils.client_link], _) Packet.t) = +let classify_client_packet dns_client dns_servers + (packet : ([ `Client of Fw_utils.client_link ], _) Packet.t) = let (`Client client_link) = packet.src in let rules = client_link#get_rules in - Lwt_list.fold_left_s (find_first_match dns_client dns_servers packet) `No_match rules >|= function + Lwt_list.fold_left_s + (find_first_match dns_client dns_servers packet) + `No_match rules + >|= function | `No_match -> `Drop "No matching rule; assuming default drop" - | `Match {Q.action = Q.Accept; _} -> `Accept - | `Match ({Q.action = Q.Drop; _} as rule) -> - `Drop (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule rule) + | `Match { Q.action = Q.Accept; _ } -> `Accept + | `Match ({ Q.action = Q.Drop; _ } as rule) -> + `Drop + (Format.asprintf "rule number %a explicitly drops this packet" Q.pp_rule + rule) let translate_accepted_packets dns_client dns_servers packet = classify_client_packet dns_client dns_servers packet >|= function | `Accept -> `NAT | `Drop s -> `Drop s -(** Packets from the private interface that don't match any NAT table entry are being checked against the fw rules here *) -let from_client dns_client dns_servers (packet : ([`Client of Fw_utils.client_link], _) Packet.t) : Packet.action Lwt.t = +(** Packets from the private interface that don't match any NAT table entry are + being checked against the fw rules here *) +let from_client dns_client dns_servers + (packet : ([ `Client of Fw_utils.client_link ], _) Packet.t) : + Packet.action Lwt.t = match packet with - | { dst = `External _ ; _ } | { dst = `NetVM; _ } -> translate_accepted_packets dns_client dns_servers packet - | { dst = `Firewall ; _ } -> Lwt.return @@ `Drop "packet addressed to firewall itself" - | { dst = `Client _ ; _ } -> classify_client_packet dns_client dns_servers packet + | { dst = `External _; _ } | { dst = `NetVM; _ } -> + translate_accepted_packets dns_client dns_servers packet + | { dst = `Firewall; _ } -> + Lwt.return @@ `Drop "packet addressed to firewall itself" + | { dst = `Client _; _ } -> + classify_client_packet dns_client dns_servers packet | _ -> Lwt.return @@ `Drop "could not classify packet" -(** Packets from the outside world that don't match any NAT table entry are being dropped by default *) -let from_netvm (_packet : ([`NetVM | `External of _], _) Packet.t) : Packet.action Lwt.t = +(** Packets from the outside world that don't match any NAT table entry are + being dropped by default *) +let from_netvm (_packet : ([ `NetVM | `External of _ ], _) Packet.t) : + Packet.action Lwt.t = Lwt.return @@ `Drop "drop by default" diff --git a/test/config.ml b/test/config.ml index d8695e4..d5589d5 100644 --- a/test/config.ml +++ b/test/config.ml @@ -2,26 +2,32 @@ open Mirage let pin = "git+https://github.com/roburio/alcotest.git#mirage" -let packages = [ - package "ethernet"; - package "arp"; - package "arp-mirage"; - package "ipaddr"; - package "tcpip" ~sublibs:["stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp"]; - package "mirage-qubes"; - package "mirage-qubes-ipv4"; - package "dns-client" ~sublibs:["mirage"]; - package ~pin "alcotest"; - package ~pin "alcotest-mirage"; -] +let packages = + [ + package "ethernet"; + package "arp"; + package "arp-mirage"; + package "ipaddr"; + package "tcpip" ~sublibs:[ "stack-direct"; "icmpv4"; "ipv4"; "udp"; "tcp" ]; + package "mirage-qubes"; + package "mirage-qubes-ipv4"; + package "dns-client" ~sublibs:[ "mirage" ]; + package ~pin "alcotest"; + package ~pin "alcotest-mirage"; + ] let client = - foreign ~packages - "Unikernel.Client" @@ random @-> time @-> mclock @-> network @-> qubesdb @-> job + foreign ~packages "Unikernel.Client" + @@ random @-> time @-> mclock @-> network @-> qubesdb @-> job let db = default_qubesdb let network = default_network let () = - let job = [ client $ default_random $ default_time $ default_monotonic_clock $ network $ db ] in + let job = + [ + client $ default_random $ default_time $ default_monotonic_clock $ network + $ db; + ] + in register "http-fetch" job diff --git a/test/unikernel.ml b/test/unikernel.ml index 04f7d6a..2a0c23a 100644 --- a/test/unikernel.ml +++ b/test/unikernel.ml @@ -1,6 +1,8 @@ open Lwt.Infix + (* https://www.qubes-os.org/doc/vm-interface/#firewall-rules-in-4x *) let src = Logs.Src.create "firewall test" ~doc:"Firewalltest" + module Log = (val Logs.src_log src : Logs.LOG) (* TODO @@ -39,18 +41,24 @@ module Log = (val Logs.src_log src : Logs.LOG) (* Point-to-point links out of a netvm always have this IP TODO clarify with Marek *) 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" +let nameserver_1, nameserver_2 = ("10.139.1.1", "10.139.1.2") -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) - module Icmp = Icmpv4.Make(I) - module U = Udp.Make(I)(R) - module T = Tcp.Flow.Make(I)(Time)(Clock)(R) - - module Alcotest = Alcotest_mirage.Make(Clock) +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) + module Icmp = Icmpv4.Make (I) + module U = Udp.Make (I) (R) + module T = Tcp.Flow.Make (I) (Time) (Clock) (R) + module Alcotest = Alcotest_mirage.Make (Clock) module Stack = struct (* A Mirage_stack.V4 implementation which diverts DHCP messages to a DHCP @@ -66,67 +74,77 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir module IPV4 = I type t = { - net : NET.t ; eth : E.t ; arp : A.t ; - ip : I.t ; icmp : Icmp.t ; udp : U.t ; tcp : T.t ; - udp_listeners : (int, U.callback) Hashtbl.t ; - tcp_listeners : (int, T.listener) Hashtbl.t ; - mutable icmp_listener : (src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t) option ; + net : NET.t; + eth : E.t; + arp : A.t; + ip : I.t; + icmp : Icmp.t; + udp : U.t; + tcp : T.t; + udp_listeners : (int, U.callback) Hashtbl.t; + tcp_listeners : (int, T.listener) Hashtbl.t; + mutable icmp_listener : + (src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> Cstruct.t -> unit Lwt.t) option; } - let ipv4 { ip ; _ } = ip - let udpv4 { udp ; _ } = udp - let tcpv4 { tcp ; _ } = tcp - let icmpv4 { icmp ; _ } = icmp - + let ipv4 { ip; _ } = ip + let udpv4 { udp; _ } = udp + let tcpv4 { tcp; _ } = tcp + let icmpv4 { icmp; _ } = icmp let listener h port = Hashtbl.find_opt h port let udp_listener h ~dst_port = listener h dst_port - let listen_udpv4 { udp_listeners ; _ } ~port cb = + let listen_udpv4 { udp_listeners; _ } ~port cb = Hashtbl.replace udp_listeners port cb - let stop_listen_udpv4 { udp_listeners ; _ } ~port = + let stop_listen_udpv4 { udp_listeners; _ } ~port = Hashtbl.remove udp_listeners port - let listen_tcpv4 ?keepalive { tcp_listeners ; _ } ~port cb = - Hashtbl.replace tcp_listeners port { T.process = cb ; T.keepalive } + let listen_tcpv4 ?keepalive { tcp_listeners; _ } ~port cb = + Hashtbl.replace tcp_listeners port { T.process = cb; T.keepalive } - let stop_listen_tcpv4 { tcp_listeners ; _ } ~port = + let stop_listen_tcpv4 { tcp_listeners; _ } ~port = Hashtbl.remove tcp_listeners port let listen_icmp t cb = t.icmp_listener <- cb let listen t = let ethif_listener = - E.input - ~arpv4:(A.input t.arp) - ~ipv4:( - I.input - ~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners)) - ~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners)) - ~default:(fun ~proto ~src ~dst buf -> - match proto with - | 1 -> - begin match t.icmp_listener with + E.input ~arpv4:(A.input t.arp) + ~ipv4: + (I.input + ~tcp:(T.input t.tcp ~listeners:(listener t.tcp_listeners)) + ~udp:(U.input t.udp ~listeners:(udp_listener t.udp_listeners)) + ~default:(fun ~proto ~src ~dst buf -> + match proto with + | 1 -> ( + match t.icmp_listener with | None -> Icmp.input t.icmp ~src ~dst buf - | Some cb -> cb ~src ~dst buf - end - | _ -> Lwt.return_unit) - t.ip) + | Some cb -> cb ~src ~dst buf) + | _ -> Lwt.return_unit) + t.ip) ~ipv6:(fun _ -> Lwt.return_unit) t.eth in NET.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener >>= function | Error e -> - Logs.warn (fun p -> p "%a" NET.pp_error e) ; - Lwt.return_unit + Logs.warn (fun p -> p "%a" NET.pp_error e); + Lwt.return_unit | Ok _res -> Lwt.return_unit let connect net eth arp ip icmp udp tcp = - { net ; eth ; arp ; ip ; icmp ; udp ; tcp ; - udp_listeners = Hashtbl.create 2 ; - tcp_listeners = Hashtbl.create 2 ; - icmp_listener = None ; + { + net; + eth; + arp; + ip; + icmp; + udp; + tcp; + udp_listeners = Hashtbl.create 2; + tcp_listeners = Hashtbl.create 2; + icmp_listener = None; } let disconnect _ = @@ -134,31 +152,39 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir Lwt.return_unit end - module Dns = Dns_client_mirage.Make(R)(Time)(Clock)(Stack) + module Dns = Dns_client_mirage.Make (R) (Time) (Clock) (Stack) let make_ping_packet payload = - let echo_request = { Icmpv4_packet.code = 0; (* constant for echo request/reply *) - ty = Icmpv4_wire.Echo_request; - subheader = Icmpv4_packet.(Id_and_seq (0, 0)); } in + let echo_request = + { + Icmpv4_packet.code = 0; + (* constant for echo request/reply *) + ty = Icmpv4_wire.Echo_request; + subheader = Icmpv4_packet.(Id_and_seq (0, 0)); + } + in Icmpv4_packet.Marshal.make_cstruct echo_request ~payload let is_ping_reply src server packet = - 0 = Ipaddr.V4.(compare src @@ of_string_exn server) && - packet.Icmpv4_packet.code = 0 && - packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply && - packet.Icmpv4_packet.subheader = Icmpv4_packet.(Id_and_seq (0, 0)) + (0 = Ipaddr.V4.(compare src @@ of_string_exn server)) + && packet.Icmpv4_packet.code = 0 + && packet.Icmpv4_packet.ty = Icmpv4_wire.Echo_reply + && packet.Icmpv4_packet.subheader = Icmpv4_packet.(Id_and_seq (0, 0)) let ping_denied_listener server resp_received stack = let icmp_listener ~src ~dst:_ buf = (* hopefully this is a reply to an ICMP echo request we sent *) - Log.info (fun f -> f "ping test: ICMP message received from %a: %a" I.pp_ipaddr src Cstruct.hexdump_pp buf); + Log.info (fun f -> + f "ping test: ICMP message received from %a: %a" I.pp_ipaddr src + Cstruct.hexdump_pp buf); match Icmpv4_packet.Unmarshal.of_cstruct buf with - | Error e -> Log.err (fun f -> f "couldn't parse ICMP packet: %s" e); - Lwt.return_unit + | Error e -> + Log.err (fun f -> f "couldn't parse ICMP packet: %s" e); + Lwt.return_unit | Ok (packet, _payload) -> - Log.info (fun f -> f "ICMP message: %a" Icmpv4_packet.pp packet); - if is_ping_reply src server packet then resp_received := true; - Lwt.return_unit + Log.info (fun f -> f "ICMP message: %a" Icmpv4_packet.pp packet); + if is_ping_reply src server packet then resp_received := true; + Lwt.return_unit in Stack.listen_icmp stack (Some icmp_listener) @@ -166,49 +192,68 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir let resp_received = ref false in Log.info (fun f -> f "Entering ping test: %s" server); ping_denied_listener server resp_received stack; - Icmp.write (Stack.icmpv4 stack) ~dst:(Ipaddr.V4.of_string_exn server) (make_ping_packet (Cstruct.of_string "hi")) >>= function - | Error e -> Log.err (fun f -> f "ping test: error sending ping: %a" Icmp.pp_error e); Lwt.return_unit + Icmp.write (Stack.icmpv4 stack) + ~dst:(Ipaddr.V4.of_string_exn server) + (make_ping_packet (Cstruct.of_string "hi")) + >>= function + | Error e -> + Log.err (fun f -> f "ping test: error sending ping: %a" Icmp.pp_error e); + Lwt.return_unit | Ok () -> - Log.info (fun f -> f "ping test: sent ping to %s" server); - Time.sleep_ns 2_000_000_000L >>= fun () -> - (if !resp_received then - Log.err (fun f -> f "ping test failed: server %s got a response, block expected :(" server) - else - Log.err (fun f -> f "ping test passed: successfully blocked :)") - ); - Stack.listen_icmp stack None; - Lwt.return_unit + Log.info (fun f -> f "ping test: sent ping to %s" server); + Time.sleep_ns 2_000_000_000L >>= fun () -> + if !resp_received then + Log.err (fun f -> + f "ping test failed: server %s got a response, block expected :(" + server) + else Log.err (fun f -> f "ping test passed: successfully blocked :)"); + Stack.listen_icmp stack None; + Lwt.return_unit let icmp_error_type stack () = let resp_correct = ref false in let echo_server = Ipaddr.V4.of_string_exn netvm in let icmp_callback ~src ~dst:_ buf = - if Ipaddr.V4.compare src echo_server = 0 then begin - (* TODO: check that packet is error packet *) - match Icmpv4_packet.Unmarshal.of_cstruct buf with - | Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e) - | Ok (packet, _) -> + (if Ipaddr.V4.compare src echo_server = 0 then + (* TODO: check that packet is error packet *) + match Icmpv4_packet.Unmarshal.of_cstruct buf with + | Error e -> Log.err (fun f -> f "Error parsing icmp packet %s" e) + | Ok (packet, _) -> (* TODO don't hardcode the numbers, make a datatype *) - if packet.Icmpv4_packet.code = 10 (* unreachable, admin prohibited *) + if + packet.Icmpv4_packet.code + = 10 (* unreachable, admin prohibited *) then resp_correct := true - else Log.debug (fun f -> f "Unrelated icmp packet %a" Icmpv4_packet.pp packet) - end; + else + Log.debug (fun f -> + f "Unrelated icmp packet %a" Icmpv4_packet.pp packet)); Lwt.return_unit in let content = Cstruct.of_string "important data" in Stack.listen_icmp stack (Some icmp_callback); - U.write ~src_port:1337 ~dst:echo_server ~dst_port:1338 (Stack.udpv4 stack) content >>= function - | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *) - Time.sleep_ns 1_000_000_000L >>= fun () -> - if !resp_correct - then Log.info (fun m -> m "UDP fetch test to port %d succeeded :)" 1338) - else Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" 1338); - Stack.listen_icmp stack None; - Lwt.return_unit + U.write ~src_port:1337 ~dst:echo_server ~dst_port:1338 (Stack.udpv4 stack) + content + >>= function + | Ok () -> + (* .. listener: test with accept rule, if we get reply we're good *) + Time.sleep_ns 1_000_000_000L >>= fun () -> + if !resp_correct then + Log.info (fun m -> m "UDP fetch test to port %d succeeded :)" 1338) + else + Log.err (fun f -> + f + "UDP fetch test to port %d: failed. :( correct response not \ + received" + 1338); + Stack.listen_icmp stack None; + Lwt.return_unit | Error e -> - Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a" - 1338 U.pp_error e); - Lwt.return_unit + Log.err (fun f -> + f + "UDP fetch test to port %d failed: :( couldn't write the packet: \ + %a" + 1338 U.pp_error e); + Lwt.return_unit let tcp_connect msg server port tcp () = Log.info (fun f -> f "Entering tcp connect test: %s:%d" server port); @@ -216,98 +261,141 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir let msg' = Printf.sprintf "TCP connect test %s to %s:%d" msg server port in T.create_connection tcp (ip, port) >>= function | Ok flow -> - Log.info (fun f -> f "%s passed :)" msg'); - T.close flow - | Error e -> Log.err (fun f -> f "%s failed: Connection failed (%a) :(" msg' T.pp_error e); - Lwt.return_unit + Log.info (fun f -> f "%s passed :)" msg'); + T.close flow + | Error e -> + Log.err (fun f -> + f "%s failed: Connection failed (%a) :(" msg' T.pp_error e); + Lwt.return_unit let tcp_connect_denied msg server port tcp () = let ip = Ipaddr.V4.of_string_exn server in - let msg' = Printf.sprintf "TCP connect denied test %s to %s:%d" msg server port in - let connect = (T.create_connection tcp (ip, port) >>= function - | Ok flow -> - Log.err (fun f -> f "%s failed: Connection should be denied, but was not. :(" msg'); - T.close flow - | Error e -> Log.info (fun f -> f "%s passed (error text: %a) :)" msg' T.pp_error e); - Lwt.return_unit) + let msg' = + Printf.sprintf "TCP connect denied test %s to %s:%d" msg server port in - let timeout = ( + let connect = + T.create_connection tcp (ip, port) >>= function + | Ok flow -> + Log.err (fun f -> + f "%s failed: Connection should be denied, but was not. :(" msg'); + T.close flow + | Error e -> + Log.info (fun f -> + f "%s passed (error text: %a) :)" msg' T.pp_error e); + Lwt.return_unit + in + let timeout = Time.sleep_ns 1_000_000_000L >>= fun () -> Log.info (fun f -> f "%s passed :)" msg'); - Lwt.return_unit) + Lwt.return_unit in - Lwt.pick [ connect ; timeout ] + Lwt.pick [ connect; timeout ] let udp_fetch ~src_port ~echo_server_port stack () = - Log.info (fun f -> f "Entering udp fetch test: %d -> %s:%d" - src_port netvm echo_server_port); + Log.info (fun f -> + f "Entering udp fetch test: %d -> %s:%d" src_port netvm echo_server_port); let resp_correct = ref false in let echo_server = Ipaddr.V4.of_string_exn netvm in let content = Cstruct.of_string "important data" in - let udp_listener : U.callback = (fun ~src ~dst:_ ~src_port buf -> - Log.debug (fun f -> f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp buf); - if ((0 = Ipaddr.V4.compare echo_server src) && src_port = echo_server_port) then - match Cstruct.equal buf content with - | true -> (* yay *) - Log.info (fun f -> f "UDP fetch test to port %d: passed :)" echo_server_port); + let udp_listener : U.callback = + fun ~src ~dst:_ ~src_port buf -> + Log.debug (fun f -> + f "listen_udpv4 function invoked for packet: %a" Cstruct.hexdump_pp + buf); + if 0 = Ipaddr.V4.compare echo_server src && src_port = echo_server_port + then ( + match Cstruct.equal buf content with + | true -> + (* yay *) + Log.info (fun f -> + f "UDP fetch test to port %d: passed :)" echo_server_port); resp_correct := true; Lwt.return_unit - | false -> (* oh no *) - Log.err (fun f -> f "UDP fetch test to port %d: failed. :( Packet corrupted; expected %a but got %a" - echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp buf); - Lwt.return_unit - else - begin - (* disregard this packet *) - Log.debug (fun f -> f "packet is not from the echo server or has the wrong source port (%d but we wanted %d)" - src_port echo_server_port); - (* don't cancel the listener, since we want to keep listening *) - Lwt.return_unit - end - ) + | false -> + (* oh no *) + Log.err (fun f -> + f + "UDP fetch test to port %d: failed. :( Packet corrupted; \ + expected %a but got %a" + echo_server_port Cstruct.hexdump_pp content Cstruct.hexdump_pp + buf); + Lwt.return_unit) + else ( + (* disregard this packet *) + Log.debug (fun f -> + f + "packet is not from the echo server or has the wrong source port \ + (%d but we wanted %d)" + src_port echo_server_port); + (* don't cancel the listener, since we want to keep listening *) + Lwt.return_unit) in Stack.listen_udpv4 stack ~port:src_port udp_listener; - U.write ~src_port ~dst:echo_server ~dst_port:echo_server_port (Stack.udpv4 stack) content >>= function - | Ok () -> (* .. listener: test with accept rule, if we get reply we're good *) - Time.sleep_ns 1_000_000_000L >>= fun () -> - Stack.stop_listen_udpv4 stack ~port:src_port; - if !resp_correct then Lwt.return_unit else begin - Log.err (fun f -> f "UDP fetch test to port %d: failed. :( correct response not received" echo_server_port); - Lwt.return_unit - end + U.write ~src_port ~dst:echo_server ~dst_port:echo_server_port + (Stack.udpv4 stack) content + >>= function + | Ok () -> + (* .. listener: test with accept rule, if we get reply we're good *) + Time.sleep_ns 1_000_000_000L >>= fun () -> + Stack.stop_listen_udpv4 stack ~port:src_port; + if !resp_correct then Lwt.return_unit + else ( + Log.err (fun f -> + f + "UDP fetch test to port %d: failed. :( correct response not \ + received" + echo_server_port); + Lwt.return_unit) | Error e -> - Log.err (fun f -> f "UDP fetch test to port %d failed: :( couldn't write the packet: %a" - echo_server_port U.pp_error e); - Lwt.return_unit + Log.err (fun f -> + f + "UDP fetch test to port %d failed: :( couldn't write the packet: \ + %a" + echo_server_port U.pp_error e); + Lwt.return_unit let dns_expect_failure ~nameserver ~hostname stack () = let lookup = Domain_name.(of_string_exn hostname |> host_exn) in - let nameserver' = `UDP, (Ipaddr.V4.of_string_exn nameserver, 53) in + let nameserver' = (`UDP, (Ipaddr.V4.of_string_exn nameserver, 53)) in let dns = Dns.create ~nameserver:nameserver' stack in Dns.gethostbyname dns lookup >>= function - | Error (`Msg s) when String.compare s "Truncated UDP response" <> 0 -> Log.debug (fun f -> f "DNS test to %s failed as expected: %s" - nameserver s); - Log.info (fun f -> f "DNS traffic to %s correctly blocked :)" nameserver); - Lwt.return_unit + | Error (`Msg s) when String.compare s "Truncated UDP response" <> 0 -> + Log.debug (fun f -> + f "DNS test to %s failed as expected: %s" nameserver s); + Log.info (fun f -> + f "DNS traffic to %s correctly blocked :)" nameserver); + Lwt.return_unit | Error (`Msg s) -> - Log.debug (fun f -> f "DNS test to %s failed unexpectedly (truncated response): %s :(" - nameserver s); - Lwt.return_unit - | Ok addr -> Log.err (fun f -> f "DNS test to %s should have been blocked, but looked up %s:%a" nameserver hostname Ipaddr.V4.pp addr); - Lwt.return_unit + Log.debug (fun f -> + f "DNS test to %s failed unexpectedly (truncated response): %s :(" + nameserver s); + Lwt.return_unit + | Ok addr -> + Log.err (fun f -> + f "DNS test to %s should have been blocked, but looked up %s:%a" + nameserver hostname Ipaddr.V4.pp addr); + Lwt.return_unit let dns_then_tcp_denied server stack () = let parsed_server = Domain_name.(of_string_exn server |> host_exn) in (* ask dns about server *) - Log.debug (fun f -> f "going to make a dns thing using nameserver %s" nameserver_1); - let dns = Dns.create ~nameserver:(`UDP, ((Ipaddr.V4.of_string_exn nameserver_1), 53)) stack in + Log.debug (fun f -> + f "going to make a dns thing using nameserver %s" nameserver_1); + let dns = + Dns.create + ~nameserver:(`UDP, (Ipaddr.V4.of_string_exn nameserver_1, 53)) + stack + in Log.debug (fun f -> f "OK, going to look up %s now" server); Dns.gethostbyname dns parsed_server >>= function - | Error (`Msg s) -> Log.err (fun f -> f "couldn't look up ip for %s: %s" server s); Lwt.return_unit + | Error (`Msg s) -> + Log.err (fun f -> f "couldn't look up ip for %s: %s" server s); + Lwt.return_unit | Ok addr -> - Log.debug (fun f -> f "looked up ip for %s: %a" server Ipaddr.V4.pp addr); - Log.err (fun f -> f "Do more stuff here!!!! :("); - Lwt.return_unit + Log.debug (fun f -> + f "looked up ip for %s: %a" server Ipaddr.V4.pp addr); + Log.err (fun f -> f "Do more stuff here!!!! :("); + Lwt.return_unit let start _random _time _clock network db = E.connect network >>= fun ethernet -> @@ -316,42 +404,64 @@ module Client (R: Mirage_crypto_rng_mirage.S) (Time: Mirage_time.S) (Clock : Mir Icmp.connect ipv4 >>= fun icmp -> U.connect ipv4 >>= fun udp -> T.connect ipv4 >>= fun tcp -> - - let stack = Stack.connect network ethernet arp ipv4 icmp udp tcp in + let stack = Stack.connect network ethernet arp ipv4 icmp udp tcp in Lwt.async (fun () -> Stack.listen stack); (* put this first because tcp_connect_denied tests also generate icmp messages *) - let general_tests : unit Alcotest.test = ("firewall tests", [ - ("UDP fetch", `Quick, udp_fetch ~src_port:9090 ~echo_server_port:1235 stack); - ("Ping expect failure", `Quick, ping_expect_failure "8.8.8.8" stack ); - (* TODO: ping_expect_success to the netvm, for which we have an icmptype rule in update-firewall.sh *) - ("ICMP error type", `Quick, icmp_error_type stack) - ] ) in + let general_tests : unit Alcotest.test = + ( "firewall tests", + [ + ( "UDP fetch", + `Quick, + udp_fetch ~src_port:9090 ~echo_server_port:1235 stack ); + ("Ping expect failure", `Quick, ping_expect_failure "8.8.8.8" stack); + (* TODO: ping_expect_success to the netvm, for which we have an icmptype rule in update-firewall.sh *) + ("ICMP error type", `Quick, icmp_error_type stack); + ] ) + in Alcotest.run ~and_exit:false "name" [ general_tests ] >>= fun () -> - let tcp_tests : unit Alcotest.test = ("tcp tests", [ - (* this test fails on 4.0R3 + let tcp_tests : unit Alcotest.test = + ( "tcp tests", + [ + (* this test fails on 4.0R3 ("TCP connect", `Quick, tcp_connect "when trying specialtarget" nameserver_1 53 tcp); *) - ("TCP connect", `Quick, tcp_connect_denied "" netvm 53 tcp); - ("TCP connect", `Quick, tcp_connect_denied "when trying below range" netvm 6667 tcp); - ("TCP connect", `Quick, tcp_connect "when trying lower bound in range" netvm 6668 tcp); - ("TCP connect", `Quick, tcp_connect "when trying upper bound in range" netvm 6670 tcp); - ("TCP connect", `Quick, tcp_connect_denied "when trying above range" netvm 6671 tcp); - ("TCP connect", `Quick, tcp_connect_denied "" netvm 8082 tcp); - ] ) in + ("TCP connect", `Quick, tcp_connect_denied "" netvm 53 tcp); + ( "TCP connect", + `Quick, + tcp_connect_denied "when trying below range" netvm 6667 tcp ); + ( "TCP connect", + `Quick, + tcp_connect "when trying lower bound in range" netvm 6668 tcp ); + ( "TCP connect", + `Quick, + tcp_connect "when trying upper bound in range" netvm 6670 tcp ); + ( "TCP connect", + `Quick, + tcp_connect_denied "when trying above range" netvm 6671 tcp ); + ("TCP connect", `Quick, tcp_connect_denied "" netvm 8082 tcp); + ] ) + in (* replace the udp-related listeners with the right one for tcp *) Alcotest.run "name" [ tcp_tests ] >>= fun () -> (* use the stack abstraction only after the other tests have run, since it's not friendly with outside use of its modules *) - let stack_tests = "stack tests", [ - ("DNS expect failure", `Quick, dns_expect_failure ~nameserver:"8.8.8.8" ~hostname:"mirage.io" stack); - - (* the test below won't work on @linse's internet, + let stack_tests = + ( "stack tests", + [ + ( "DNS expect failure", + `Quick, + dns_expect_failure ~nameserver:"8.8.8.8" ~hostname:"mirage.io" stack + ); + (* the test below won't work on @linse's internet, * because the nameserver there doesn't answer on TCP port 53, * only UDP port 53. Dns_mirage_client.ml disregards our request * to use UDP and uses TCP anyway, so this request can never work there. *) - (* If we can figure out a way to have this test unikernel do a UDP lookup with minimal pain, + (* If we can figure out a way to have this test unikernel do a UDP lookup with minimal pain, * we should re-enable this test. *) - ("DNS lookup + TCP connect", `Quick, dns_then_tcp_denied "google.com" stack); - ] in + ( "DNS lookup + TCP connect", + `Quick, + dns_then_tcp_denied "google.com" stack ); + ] ) + in Alcotest.run "name" [ stack_tests ] end diff --git a/unikernel.ml b/unikernel.ml index 28115d1..51841ae 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -6,10 +6,13 @@ open Qubes open Cmdliner let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" + 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 + let doc = + Arg.info ~doc:"The number of NAT entries to allocate." [ "nat-table-size" ] + in Mirage_runtime.register_arg Arg.(value & opt int 5_000 doc) let ipv4 = @@ -28,86 +31,96 @@ let ipv4_dns2 = let doc = Arg.info ~doc:"Manual Second DNS IP setting." [ "ipv4-dns2" ] in Mirage_runtime.register_arg Arg.(value & opt string "10.139.1.2" doc) - module Dns_client = Dns_client.Make(My_dns) +module Dns_client = Dns_client.Make (My_dns) - (* Set up networking and listen for incoming packets. *) - let network dns_client dns_responses dns_servers qubesDB router = - (* Report success *) - Dao.set_iptables_error qubesDB "" >>= fun () -> - (* Handle packets from both networks *) - Lwt.choose [ - Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers qubesDB router ; - Dispatcher.uplink_wait_update qubesDB router ; - Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router +(* Set up networking and listen for incoming packets. *) +let network dns_client dns_responses dns_servers qubesDB router = + (* Report success *) + Dao.set_iptables_error qubesDB "" >>= fun () -> + (* Handle packets from both networks *) + Lwt.choose + [ + Dispatcher.wait_clients Mirage_mtime.elapsed_ns dns_client dns_servers + qubesDB router; + Dispatcher.uplink_wait_update qubesDB router; + Dispatcher.uplink_listen Mirage_mtime.elapsed_ns dns_responses router; ] - (* Main unikernel entry point (called from auto-generated main.ml). *) - let start () = - let open Lwt.Syntax in - let start_time = Mirage_mtime.elapsed_ns () in - (* Start qrexec agent and QubesDB agent in parallel *) - let* qrexec = RExec.connect ~domid:0 () in - let agent_listener = RExec.listen qrexec Command.handler in - let* qubesDB = DB.connect ~domid:0 () in - let startup_time = - let (-) = Int64.sub in - let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in - Int64.to_float time_in_ns /. 1e9 - in - Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); - (* Watch for shutdown requests from Qubes *) - let shutdown_rq = - 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 +(* Main unikernel entry point (called from auto-generated main.ml). *) +let start () = + let open Lwt.Syntax in + let start_time = Mirage_mtime.elapsed_ns () in + (* Start qrexec agent and QubesDB agent in parallel *) + let* qrexec = RExec.connect ~domid:0 () in + let agent_listener = RExec.listen qrexec Command.handler in + let* qubesDB = DB.connect ~domid:0 () in + let startup_time = + let ( - ) = Int64.sub in + let time_in_ns = Mirage_mtime.elapsed_ns () - start_time in + Int64.to_float time_in_ns /. 1e9 + in + Log.info (fun f -> + f "QubesDB and qrexec agents connected in %.3f s" startup_time); + (* Watch for shutdown requests from Qubes *) + let shutdown_rq = + 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 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 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 zero_ip = Ipaddr.V4.any 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 -> - if config.netvm_ip = zero_ip || config.our_ip = zero_ip then - Log.info (fun f -> f "We currently have no netvm nor command line for setting it up, aborting..."); - assert (config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); - Lwt.return config - else begin - let config:Dao.network_config = {from_cmdline=true; netvm_ip; our_ip; dns; dns2} in - Lwt.return config - end - in - network_config >>= fun config -> + 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 -> + if config.netvm_ip = zero_ip || config.our_ip = zero_ip then + Log.info (fun f -> + f + "We currently have no netvm nor command line for setting it up, \ + aborting..."); + assert (config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); + Lwt.return config) + else + let config : Dao.network_config = + { from_cmdline = true; netvm_ip; our_ip; dns; dns2 } + in + Lwt.return config + in + network_config >>= fun config -> + (* We now must have a valid netvm IP address and our IP address or crash *) + Dao.print_network_config config; - (* We now must have a valid netvm IP address and our IP address or crash *) - Dao.print_network_config config ; + (* Set up client-side networking *) + let* clients = Client_eth.create config in - (* Set up client-side networking *) - let* clients = Client_eth.create config in + (* Set up routing between networks and hosts *) + let router = Dispatcher.create ~config ~clients ~nat ~uplink:None in - (* Set up routing between networks and hosts *) - let router = Dispatcher.create - ~config - ~clients - ~nat - ~uplink:None - in + let send_dns_query = Dispatcher.send_dns_client_query router in + let dns_mvar = Lwt_mvar.create_empty () in + let nameservers = (`Udp, [ (config.Dao.dns, 53); (config.Dao.dns2, 53) ]) in + let dns_client = + Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) + in - let send_dns_query = Dispatcher.send_dns_client_query router in - let dns_mvar = Lwt_mvar.create_empty () in - let nameservers = `Udp, [ config.Dao.dns, 53 ; config.Dao.dns2, 53 ] in - let dns_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in + let dns_servers = [ config.Dao.dns; config.Dao.dns2 ] in + let net_listener = + network + (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) + dns_mvar dns_servers qubesDB router + in - let dns_servers = [ config.Dao.dns ; config.Dao.dns2 ] in - let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar dns_servers qubesDB router in - - (* Report memory usage to XenStore *) - Memory_pressure.init (); - (* 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. *) - Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float) + (* Report memory usage to XenStore *) + Memory_pressure.init (); + (* 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. *) + Mirage_sleep.ns (1.0 *. 1e9 |> Int64.of_float) From 64d2b16c3a021b189a0ac3a80e9ae4106f0491a4 Mon Sep 17 00:00:00 2001 From: Pierre Alain Date: Tue, 18 Mar 2025 15:52:32 +0100 Subject: [PATCH 58/58] fix hashsum --- qubes-firewall.sha256 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/qubes-firewall.sha256 b/qubes-firewall.sha256 index 067b2d6..f6c0982 100644 --- a/qubes-firewall.sha256 +++ b/qubes-firewall.sha256 @@ -1 +1 @@ -1cc5664d48a80b96162e14a0d8a17aafa52175cc2043ecf6b834c4bc8fe656f6 dist/qubes-firewall.xen +ac049069b35f786fa11b18a2261d7dbecd588301af0363ef6888ec9d924dc989 dist/qubes-firewall.xen