mirror of
https://github.com/mirage/qubes-mirage-firewall.git
synced 2024-10-01 01:05:39 -04:00
312627e078
Qubes does not remove the client directory itself when the domain exits.
Combined with 63cbb4bed0, this prevented clients from reconnecting.
This may also make it possible to connect clients to the firewall via
multiple interfaces, although this doesn't seem useful.
99 lines
3.2 KiB
OCaml
99 lines
3.2 KiB
OCaml
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
|
See the README file for details. *)
|
|
|
|
open Lwt.Infix
|
|
open Utils
|
|
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 =
|
|
OS.Xs.directory handle dir >|= function
|
|
| [""] -> [] (* XenStore client bug *)
|
|
| items -> items
|
|
|
|
let vifs ~handle 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
|
|
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 () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
|
|
(fun client_ip ->
|
|
let client_ip = Ipaddr.V4.of_string_exn client_ip in
|
|
Lwt.return (Some (vif, client_ip))
|
|
)
|
|
(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 =
|
|
OS.Xs.make () >>= fun xs ->
|
|
let backend_vifs = "backend/vif" in
|
|
Log.info (fun f -> f "Watching %s" backend_vifs);
|
|
OS.Xs.wait xs (fun handle ->
|
|
begin Lwt.catch
|
|
(fun () -> directory ~handle backend_vifs)
|
|
(function
|
|
| Xs_protocol.Enoent _ -> return []
|
|
| ex -> fail ex)
|
|
end >>= fun items ->
|
|
Lwt_list.map_p (vifs ~handle) items >>= fun items ->
|
|
fn (List.concat items |> VifMap.of_list);
|
|
(* Wait for further updates *)
|
|
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) *)
|
|
}
|
|
|
|
(* TODO: /qubes-secondary-dns *)
|
|
let read_network_config qubesDB =
|
|
let get name =
|
|
match DB.read qubesDB name with
|
|
| None -> raise (error "QubesDB key %S not present" 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
|
|
{ uplink_netvm_ip; uplink_our_ip; clients_our_ip }
|
|
|
|
let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error"
|