This commit is contained in:
Hannes Mehnert 2024-05-10 13:11:40 +00:00 committed by GitHub
commit f2f44f9749
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
7 changed files with 14 additions and 17 deletions

View File

@ -23,8 +23,8 @@ ENV OPAMCONFIRMLEVEL=unsafe-yes
# Remove this line (and the base image pin above) if you want to test with the # Remove this line (and the base image pin above) if you want to test with the
# latest versions. # latest versions.
# taken from https://github.com/ocaml/opam-repository # 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 switch create myswitch 4.14.2
RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5 RUN opam exec -- opam install -y mirage opam-monorepo ocaml-solo5
RUN mkdir /tmp/orb-build RUN mkdir /tmp/orb-build
ADD config.ml /tmp/orb-build/config.ml ADD config.ml /tmp/orb-build/config.ml

View File

@ -1,5 +1,5 @@
MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen MIRAGE_KERNEL_NAME = dist/qubes-firewall.xen
OCAML_VERSION ?= 4.14.0 OCAML_VERSION ?= 4.14.2
SOURCE_BUILD_DEP := firewall-build-dep SOURCE_BUILD_DEP := firewall-build-dep
firewall-build-dep: firewall-build-dep:

View File

@ -20,5 +20,5 @@ $builder build -t qubes-mirage-firewall .
echo Building Firewall... echo Building Firewall...
$builder run --rm -i -v `pwd`:/tmp/orb-build:Z qubes-mirage-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 of build: $(sha256sum ./dist/qubes-firewall.xen)"
echo "SHA2 last known: 163991ea96842e03d378501a0be99057ad2489440aff8ae81d850624d98fd3f0" echo "SHA2 last known: 0cbb202c1b93e10ad115c9e988f9384005656c0855ec9deaf05a5e9ac9972984"
echo "(hashes should match for released versions)" echo "(hashes should match for released versions)"

View File

@ -18,13 +18,11 @@ let main =
~packages:[ ~packages:[
package "vchan" ~min:"4.0.2"; package "vchan" ~min:"4.0.2";
package "cstruct"; package "cstruct";
package "astring";
package "tcpip" ~min:"3.7.0"; package "tcpip" ~min:"3.7.0";
package ~min:"2.3.0" ~sublibs:["mirage"] "arp"; package ~min:"2.3.0" ~sublibs:["mirage"] "arp";
package ~min:"3.0.0" "ethernet"; package ~min:"3.0.0" "ethernet";
package "shared-memory-ring" ~min:"3.0.0"; package "shared-memory-ring" ~min:"3.0.0";
package ~min:"2.1.3" "netchannel"; package "mirage-net-xen" ~min:"2.1.4";
package "mirage-net-xen" ~min:"2.1.3";
package "ipaddr" ~min:"5.2.0"; package "ipaddr" ~min:"5.2.0";
package "mirage-qubes" ~min:"0.9.1"; package "mirage-qubes" ~min:"0.9.1";
package ~min:"3.0.1" "mirage-nat"; package ~min:"3.0.1" "mirage-nat";

9
dao.ml
View File

@ -3,7 +3,6 @@
open Lwt.Infix open Lwt.Infix
open Qubes open Qubes
open Astring
let src = Logs.Src.create "dao" ~doc:"QubesDB data access" let src = Logs.Src.create "dao" ~doc:"QubesDB data access"
module Log = (val Logs.src_log src : Logs.LOG) module Log = (val Logs.src_log src : Logs.LOG)
@ -66,26 +65,26 @@ let read_rules rules client_ip =
number = 0;})] number = 0;})]
let vifs client domid = 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 [] | None -> Log.err (fun f -> f "Invalid domid %S" domid); Lwt.return []
| Some domid -> | Some domid ->
let path = Printf.sprintf "backend/vif/%d" domid in let path = Printf.sprintf "backend/vif/%d" domid in
Xen_os.Xs.immediate client (fun handle -> Xen_os.Xs.immediate client (fun handle ->
directory ~handle path >>= directory ~handle path >>=
Lwt_list.filter_map_p (fun device_id -> 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 | None -> Log.err (fun f -> f "Invalid device ID %S for domid %d" device_id domid); Lwt.return_none
| Some device_id -> | Some device_id ->
let vif = { ClientVif.domid; device_id } in let vif = { ClientVif.domid; device_id } in
Lwt.try_bind Lwt.try_bind
(fun () -> Xen_os.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) (fun () -> Xen_os.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
(fun client_ip -> (fun client_ip ->
let client_ip' = match String.cuts ~sep:" " client_ip with let client_ip' = match String.split_on_char ' ' client_ip with
| [] -> Log.err (fun m -> m "unexpected empty list"); "" | [] -> Log.err (fun m -> m "unexpected empty list"); ""
| [ ip ] -> ip | [ ip ] -> ip
| ip::rest -> | ip::rest ->
Log.warn (fun m -> m "ignoring IPs %s from %a, we support one IP per client" 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 ip
in in
match Ipaddr.V4.of_string client_ip' with match Ipaddr.V4.of_string client_ip' with

View File

@ -1,6 +1,6 @@
open Lwt.Infix open Lwt.Infix
open Fw_utils 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 ClientEth = Ethernet.Make (Netback)
module UplinkEth = Ethernet.Make (Netif) module UplinkEth = Ethernet.Make (Netif)
@ -446,14 +446,14 @@ struct
clients := !clients |> Dao.VifMap.add key cleanup))) clients := !clients |> Dao.VifMap.add key cleanup)))
let send_dns_client_query t ~src_port ~dst ~dst_port buf = let send_dns_client_query t ~src_port ~dst ~dst_port buf =
match t with match t.uplink with
| None -> | None ->
Log.err (fun f -> f "No uplink interface"); Log.err (fun f -> f "No uplink interface");
Lwt.return (Error (`Msg "failure")) Lwt.return (Error (`Msg "failure"))
| Some t -> ( | Some uplink -> (
Lwt.catch Lwt.catch
(fun () -> (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 -> | Error s ->
Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s);
Error (`Msg "failure") Error (`Msg "failure")

View File

@ -103,7 +103,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
~uplink:None ~uplink:None
in 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 dns_mvar = Lwt_mvar.create_empty () in
let nameservers = `Udp, [ config.Dao.dns, 53 ; config.Dao.dns2, 53 ] 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_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in