mirror of
https://github.com/mirage/qubes-mirage-firewall.git
synced 2024-10-01 01:05:39 -04:00
d094b20950
in the callback to "Xs_client.wait", all operations are tracked and new watches are installed (that are never removed, due to xenstore's xs_handle "accessed_path" never removes any elements of the "accessed_paths" (a mutable StringSet). So, whatever is done in the callback of wait needs to take care (if returning EAGAIN and thus forcing xenstore to continue waiting/watching) that accesses are tracked. Our way out is to create a fresh client and read the IP address with that new client -> the watcher isn't extended -> no dangling (leaking) watches, and no leaking only-expanding StringSet.
169 lines
6.4 KiB
OCaml
169 lines
6.4 KiB
OCaml
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
|
See the README file for details. *)
|
|
|
|
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)
|
|
|
|
module ClientVif = struct
|
|
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 compare = compare
|
|
end
|
|
module VifMap = struct
|
|
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
|
|
end
|
|
|
|
let directory ~handle dir =
|
|
Xen_os.Xs.directory handle dir >|= function
|
|
| [""] -> [] (* XenStore client bug *)
|
|
| items -> items
|
|
|
|
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
|
|
let rec get_rule n l : (Pf_qubes.Parse_qubes.rule list, string) result =
|
|
let pattern = root ^ "/" ^ Printf.sprintf "%04d" n in
|
|
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)
|
|
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;})]
|
|
|
|
let vifs client domid =
|
|
match String.to_int 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
|
|
| 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
|
|
| [] -> 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);
|
|
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 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);
|
|
(* Wait for further updates *)
|
|
Lwt.fail Xs_protocol.Eagain
|
|
)
|
|
|
|
type network_config = {
|
|
uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *)
|
|
uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *)
|
|
|
|
clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *)
|
|
dns : Ipaddr.V4.t;
|
|
dns2 : Ipaddr.V4.t;
|
|
}
|
|
|
|
exception Missing_key of string
|
|
|
|
let try_read_network_config db =
|
|
let get name =
|
|
match DB.KeyMap.find_opt name db with
|
|
| None -> raise (Missing_key name)
|
|
| Some value -> value in
|
|
let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in
|
|
let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in
|
|
let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in
|
|
let dns = get "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn in
|
|
let dns2 = get "/qubes-secondary-dns" |> Ipaddr.V4.of_string_exn in
|
|
Log.info (fun f -> f "@[<v2>Got network configuration from QubesDB:@,\
|
|
NetVM IP on uplink network: %a@,\
|
|
Our IP on uplink network: %a@,\
|
|
Our IP on client networks: %a@,\
|
|
DNS primary resolver: %a@,\
|
|
DNS secondary resolver: %a@]"
|
|
Ipaddr.V4.pp uplink_netvm_ip
|
|
Ipaddr.V4.pp uplink_our_ip
|
|
Ipaddr.V4.pp clients_our_ip
|
|
Ipaddr.V4.pp dns
|
|
Ipaddr.V4.pp dns2);
|
|
{ uplink_netvm_ip; uplink_our_ip; clients_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);
|
|
DB.after qubesDB bindings >>= aux
|
|
in
|
|
aux (DB.bindings qubesDB)
|
|
|
|
let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error"
|