mirror of
https://github.com/mirage/qubes-mirage-firewall.git
synced 2024-10-01 01:05:39 -04:00
Merge pull request #89 from roburio/mirage-3.7
support Mirage 3.7 and mirage-nat 2.0.0
This commit is contained in:
commit
e851565823
@ -7,9 +7,9 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155
|
||||
# Pin last known-good version for reproducible builds.
|
||||
# Remove this line (and the base image pin above) if you want to test with the
|
||||
# latest versions.
|
||||
RUN cd ~/opam-repository && git fetch origin master && git reset --hard 5eed470abc5c7991e448c9653698c03d6ea146d1 && opam update
|
||||
RUN cd ~/opam-repository && git fetch origin master && git reset --hard d205c265cee9a86869259180fd2238da98370430 && opam update
|
||||
|
||||
RUN opam depext -i -y mirage.3.5.2 lwt
|
||||
RUN opam depext -i -y mirage.3.7.4 lwt
|
||||
RUN mkdir /home/opam/qubes-mirage-firewall
|
||||
ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
|
||||
WORKDIR /home/opam/qubes-mirage-firewall
|
||||
|
@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall .
|
||||
echo Building Firewall...
|
||||
docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall
|
||||
echo "SHA2 of build: $(sha256sum qubes_firewall.xen)"
|
||||
echo "SHA2 last known: cae3c66d38a50671f694cd529062c538592438b95935d707b97d80b57fbfc186"
|
||||
echo "SHA2 last known: 8a337e61e7d093f7c1f0fa5fe277dace4d606bfa06cfde3f2d61d6bdee6eefbc"
|
||||
echo "(hashes should match for released versions)"
|
||||
|
@ -4,7 +4,7 @@
|
||||
open Lwt.Infix
|
||||
open Fw_utils
|
||||
|
||||
module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Os_xen.Xs))
|
||||
module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs))
|
||||
module ClientEth = Ethernet.Make(Netback)
|
||||
|
||||
let src = Logs.Src.create "client_net" ~doc:"Client networking"
|
||||
@ -23,7 +23,7 @@ let writev eth dst proto fillfn =
|
||||
(* 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 ()
|
||||
Lwt.return_unit
|
||||
)
|
||||
|
||||
class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link =
|
||||
@ -48,31 +48,32 @@ let input_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 ()
|
||||
Lwt.return_unit
|
||||
| Ok arp ->
|
||||
match Client_eth.ARP.input fixed_arp arp with
|
||||
| None -> return ()
|
||||
| None -> Lwt.return_unit
|
||||
| Some response ->
|
||||
iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size)
|
||||
|
||||
(** Handle an IPv4 packet from the client. *)
|
||||
let input_ipv4 ~iface ~router packet =
|
||||
match Nat_packet.of_ipv4_packet packet with
|
||||
let input_ipv4 get_ts cache ~iface ~router packet =
|
||||
match Nat_packet.of_ipv4_packet cache ~now:(get_ts ()) packet with
|
||||
| Error e ->
|
||||
Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e);
|
||||
Lwt.return ()
|
||||
| Ok packet ->
|
||||
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 Firewall.ipv4_from_client router ~src:iface 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);
|
||||
return ()
|
||||
Lwt.return_unit
|
||||
)
|
||||
|
||||
(** Connect to a new client's interface and listen for incoming frames. *)
|
||||
let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks =
|
||||
let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks =
|
||||
Netback.make ~domid ~device_id >>= fun backend ->
|
||||
Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip));
|
||||
ClientEth.connect backend >>= fun eth ->
|
||||
@ -83,6 +84,7 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks
|
||||
Router.add_client router iface >>= fun () ->
|
||||
Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface);
|
||||
let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
|
||||
let fragment_cache = Fragments.Cache.create (256 * 1024) in
|
||||
Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
|
||||
match Ethernet_packet.Unmarshal.of_cstruct frame with
|
||||
| exception ex ->
|
||||
@ -90,33 +92,33 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks
|
||||
Cstruct.hexdump_pp frame
|
||||
);
|
||||
Lwt.return_unit
|
||||
| Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); return ()
|
||||
| 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 -> input_arp ~fixed_arp ~iface payload
|
||||
| `IPv4 -> input_ipv4 ~iface ~router payload
|
||||
| `IPv6 -> return () (* TODO: oh no! *)
|
||||
| `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router payload
|
||||
| `IPv6 -> Lwt.return_unit (* TODO: oh no! *)
|
||||
)
|
||||
>|= or_raise "Listen on client interface" Netback.pp_error
|
||||
|
||||
(** A new client VM has been found in XenStore. Find its interface and connect to it. *)
|
||||
let add_client ~router vif client_ip =
|
||||
let add_client get_ts ~router vif client_ip =
|
||||
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 vif ~client_ip ~router ~cleanup_tasks
|
||||
add_vif get_ts vif ~client_ip ~router ~cleanup_tasks
|
||||
)
|
||||
(fun ex ->
|
||||
Log.warn (fun f -> f "Error with client %a: %s"
|
||||
Dao.ClientVif.pp vif (Printexc.to_string ex));
|
||||
return ()
|
||||
Lwt.return_unit
|
||||
)
|
||||
);
|
||||
cleanup_tasks
|
||||
|
||||
(** Watch XenStore for notifications of new clients. *)
|
||||
let listen router =
|
||||
let listen get_ts router =
|
||||
Dao.watch_clients (fun new_set ->
|
||||
(* Check for removed clients *)
|
||||
!clients |> Dao.VifMap.iter (fun key cleanup ->
|
||||
@ -129,7 +131,7 @@ let listen router =
|
||||
(* 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 ~router key ip_addr in
|
||||
let cleanup = add_client get_ts ~router key ip_addr in
|
||||
clients := !clients |> Dao.VifMap.add key cleanup
|
||||
)
|
||||
)
|
||||
|
@ -3,8 +3,8 @@
|
||||
|
||||
(** Handling client VMs. *)
|
||||
|
||||
val listen : Router.t -> 'a Lwt.t
|
||||
(** [listen router] is a thread that watches for clients being added to and
|
||||
removed from XenStore. Clients are connected to the client network and
|
||||
packets are sent via [router]. We ensure the source IP address is correct
|
||||
before routing a packet. *)
|
||||
val listen : (unit -> int64) -> Router.t -> 'a Lwt.t
|
||||
(** [listen get_timestamp router] is a thread that watches for clients being
|
||||
added to and removed from XenStore. Clients are connected to the client
|
||||
network and packets are sent via [router]. We ensure the source IP address
|
||||
is correct before routing a packet. *)
|
||||
|
@ -30,10 +30,10 @@ let main =
|
||||
package "netchannel" ~min:"1.11.0";
|
||||
package "mirage-net-xen";
|
||||
package "ipaddr" ~min:"4.0.0";
|
||||
package "mirage-qubes";
|
||||
package "mirage-nat" ~min:"1.2.0";
|
||||
package "mirage-qubes" ~min:"0.8.0";
|
||||
package "mirage-nat" ~min:"2.0.0";
|
||||
package "mirage-logs";
|
||||
package "mirage-xen" ~min:"4.0.0";
|
||||
package "mirage-xen" ~min:"5.0.0";
|
||||
]
|
||||
"Unikernel.Main" (mclock @-> job)
|
||||
|
||||
|
15
dao.ml
15
dao.ml
@ -3,7 +3,6 @@
|
||||
|
||||
open Lwt.Infix
|
||||
open Qubes
|
||||
open Fw_utils
|
||||
open Astring
|
||||
|
||||
let src = Logs.Src.create "dao" ~doc:"QubesDB data access"
|
||||
@ -30,7 +29,7 @@ module VifMap = struct
|
||||
end
|
||||
|
||||
let directory ~handle dir =
|
||||
Os_xen.Xs.directory handle dir >|= function
|
||||
OS.Xs.directory handle dir >|= function
|
||||
| [""] -> [] (* XenStore client bug *)
|
||||
| items -> items
|
||||
|
||||
@ -46,7 +45,7 @@ let vifs ~handle domid =
|
||||
| Some device_id ->
|
||||
let vif = { ClientVif.domid; device_id } in
|
||||
Lwt.try_bind
|
||||
(fun () -> Os_xen.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id))
|
||||
(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))
|
||||
@ -61,20 +60,20 @@ let vifs ~handle domid =
|
||||
)
|
||||
|
||||
let watch_clients fn =
|
||||
Os_xen.Xs.make () >>= fun xs ->
|
||||
OS.Xs.make () >>= fun xs ->
|
||||
let backend_vifs = "backend/vif" in
|
||||
Log.info (fun f -> f "Watching %s" backend_vifs);
|
||||
Os_xen.Xs.wait xs (fun handle ->
|
||||
OS.Xs.wait xs (fun handle ->
|
||||
begin Lwt.catch
|
||||
(fun () -> directory ~handle backend_vifs)
|
||||
(function
|
||||
| Xs_protocol.Enoent _ -> return []
|
||||
| ex -> fail ex)
|
||||
| Xs_protocol.Enoent _ -> Lwt.return []
|
||||
| ex -> Lwt.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
|
||||
Lwt.fail Xs_protocol.Eagain
|
||||
)
|
||||
|
||||
type network_config = {
|
||||
|
34
firewall.ml
34
firewall.ml
@ -1,7 +1,6 @@
|
||||
(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
|
||||
See the README file for details. *)
|
||||
|
||||
open Fw_utils
|
||||
open Packet
|
||||
open Lwt.Infix
|
||||
|
||||
@ -15,6 +14,7 @@ let transmit_ipv4 packet iface =
|
||||
(fun () ->
|
||||
Lwt.catch
|
||||
(fun () ->
|
||||
let fragments = ref [] in
|
||||
iface#writev `IPv4 (fun b ->
|
||||
match Nat_packet.into_cstruct packet b with
|
||||
| Error e ->
|
||||
@ -22,14 +22,16 @@ let transmit_ipv4 packet iface =
|
||||
Ipaddr.V4.pp iface#other_ip
|
||||
Nat_packet.pp_error e);
|
||||
0
|
||||
| Ok n -> n
|
||||
)
|
||||
)
|
||||
| Ok (n, frags) -> fragments := frags ; n) >>= fun () ->
|
||||
Lwt_list.iter_s (fun f ->
|
||||
let size = Cstruct.len 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 ()
|
||||
Lwt.return_unit
|
||||
)
|
||||
)
|
||||
(fun ex ->
|
||||
@ -37,7 +39,7 @@ let transmit_ipv4 packet iface =
|
||||
(Printexc.to_string ex)
|
||||
Nat_packet.pp packet
|
||||
);
|
||||
Lwt.return ()
|
||||
Lwt.return_unit
|
||||
)
|
||||
|
||||
let forward_ipv4 t packet =
|
||||
@ -124,19 +126,19 @@ let add_nat_and_forward_ipv4 t packet =
|
||||
| Ok packet -> forward_ipv4 t packet
|
||||
| Error e ->
|
||||
Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e pp_header packet);
|
||||
Lwt.return ()
|
||||
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 Router.resolve t host with
|
||||
| Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return ()
|
||||
| Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit
|
||||
| Ipaddr.V4 target ->
|
||||
let xl_host = t.Router.uplink#my_ip in
|
||||
My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function
|
||||
| Ok packet -> forward_ipv4 t packet
|
||||
| Error e ->
|
||||
Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e pp_header packet);
|
||||
Lwt.return ()
|
||||
Lwt.return_unit
|
||||
|
||||
(* Handle incoming packets *)
|
||||
|
||||
@ -147,12 +149,12 @@ let apply_rules t rules ~dst info =
|
||||
| `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink
|
||||
| `Accept, `Firewall ->
|
||||
Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" (pp_packet t) info);
|
||||
return ()
|
||||
Lwt.return_unit
|
||||
| `NAT, _ -> add_nat_and_forward_ipv4 t packet
|
||||
| `NAT_to (host, port), _ -> nat_to t packet ~host ~port
|
||||
| `Drop reason, _ ->
|
||||
Log.info (fun f -> f "Dropped packet (%s) %a" reason (pp_packet t) info);
|
||||
return ()
|
||||
Lwt.return_unit
|
||||
|
||||
let handle_low_memory t =
|
||||
match Memory_pressure.status () with
|
||||
@ -164,7 +166,7 @@ let handle_low_memory t =
|
||||
|
||||
let ipv4_from_client t ~src packet =
|
||||
handle_low_memory t >>= function
|
||||
| `Memory_critical -> return ()
|
||||
| `Memory_critical -> Lwt.return_unit
|
||||
| `Ok ->
|
||||
(* Check for existing NAT entry for this packet *)
|
||||
translate t packet >>= function
|
||||
@ -174,23 +176,23 @@ let ipv4_from_client t ~src packet =
|
||||
let `IPv4 (ip, _transport) = packet in
|
||||
let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
||||
match classify ~src:(resolve_client src) ~dst:(resolve_host dst) packet with
|
||||
| None -> return ()
|
||||
| None -> Lwt.return_unit
|
||||
| Some info -> apply_rules t Rules.from_client ~dst info
|
||||
|
||||
let ipv4_from_netvm t packet =
|
||||
handle_low_memory t >>= function
|
||||
| `Memory_critical -> return ()
|
||||
| `Memory_critical -> Lwt.return_unit
|
||||
| `Ok ->
|
||||
let `IPv4 (ip, _transport) = packet in
|
||||
let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
|
||||
let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
||||
match classify ~src ~dst:(resolve_host dst) packet with
|
||||
| None -> return ()
|
||||
| None -> Lwt.return_unit
|
||||
| Some info ->
|
||||
match src with
|
||||
| `Client _ | `Firewall ->
|
||||
Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" (pp_packet t) info);
|
||||
return ()
|
||||
Lwt.return_unit
|
||||
| `External _ | `NetVM as src ->
|
||||
translate t packet >>= function
|
||||
| Some frame -> forward_ipv4 t frame
|
||||
|
@ -41,9 +41,6 @@ let error fmt =
|
||||
let err s = Failure s in
|
||||
Printf.ksprintf err fmt
|
||||
|
||||
let return = Lwt.return
|
||||
let fail = Lwt.fail
|
||||
|
||||
let or_raise msg pp = function
|
||||
| Ok x -> x
|
||||
| Error e -> failwith (Fmt.strf "%s: %a" msg pp e)
|
||||
|
@ -6,7 +6,7 @@ open Lwt
|
||||
let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor"
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
let total_pages = Os_xen.MM.Heap_pages.total ()
|
||||
let total_pages = OS.MM.Heap_pages.total ()
|
||||
let pagesize_kb = Io_page.page_size / 1024
|
||||
|
||||
let meminfo ~used =
|
||||
@ -23,7 +23,7 @@ let meminfo ~used =
|
||||
|
||||
let report_mem_usage used =
|
||||
Lwt.async (fun () ->
|
||||
let open Os_xen in
|
||||
let open OS in
|
||||
Xs.make () >>= fun xs ->
|
||||
Xs.immediate xs (fun h ->
|
||||
Xs.write h "memory/meminfo" (meminfo ~used)
|
||||
@ -32,16 +32,16 @@ let report_mem_usage used =
|
||||
|
||||
let init () =
|
||||
Gc.full_major ();
|
||||
let used = Os_xen.MM.Heap_pages.used () in
|
||||
let used = OS.MM.Heap_pages.used () in
|
||||
report_mem_usage used
|
||||
|
||||
let status () =
|
||||
let used = Os_xen.MM.Heap_pages.used () |> float_of_int in
|
||||
let used = OS.MM.Heap_pages.used () |> float_of_int in
|
||||
let frac = used /. float_of_int total_pages in
|
||||
if frac < 0.9 then `Ok
|
||||
else (
|
||||
Gc.full_major ();
|
||||
let used = Os_xen.MM.Heap_pages.used () in
|
||||
let used = OS.MM.Heap_pages.used () in
|
||||
report_mem_usage used;
|
||||
let frac = float_of_int used /. float_of_int total_pages in
|
||||
if frac > 0.9 then `Memory_critical
|
||||
|
@ -15,14 +15,13 @@ module Nat = Mirage_nat_lru
|
||||
|
||||
type t = {
|
||||
table : Nat.t;
|
||||
get_time : unit -> Mirage_nat.time;
|
||||
}
|
||||
|
||||
let create ~get_time ~max_entries =
|
||||
let create ~max_entries =
|
||||
let tcp_size = 7 * max_entries / 8 in
|
||||
let udp_size = max_entries - tcp_size in
|
||||
Nat.empty ~tcp_size ~udp_size ~icmp_size:100 >|= fun table ->
|
||||
{ get_time; table }
|
||||
{ table }
|
||||
|
||||
let translate t packet =
|
||||
Nat.translate t.table packet >|= function
|
||||
@ -41,10 +40,9 @@ let reset t =
|
||||
Nat.reset t.table
|
||||
|
||||
let add_nat_rule_and_translate t ~xl_host action packet =
|
||||
let now = t.get_time () in
|
||||
let apply_action xl_port =
|
||||
Lwt.catch (fun () ->
|
||||
Nat.add t.table ~now packet (xl_host, xl_port) action
|
||||
Nat.add t.table packet (xl_host, xl_port) action
|
||||
)
|
||||
(function
|
||||
| Out_of_memory -> Lwt.return (Error `Out_of_memory)
|
||||
|
@ -10,7 +10,7 @@ type action = [
|
||||
| `Redirect of Mirage_nat.endpoint
|
||||
]
|
||||
|
||||
val create : get_time:(unit -> Mirage_nat.time) -> max_entries:int -> t Lwt.t
|
||||
val create : max_entries:int -> t Lwt.t
|
||||
val reset : t -> unit Lwt.t
|
||||
val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t
|
||||
val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t ->
|
||||
|
27
unikernel.ml
27
unikernel.ml
@ -7,15 +7,15 @@ open Qubes
|
||||
let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
module Main (Clock : Mirage_clock.MCLOCK) = struct
|
||||
module Uplink = Uplink.Make(Clock)
|
||||
|
||||
(* Set up networking and listen for incoming packets. *)
|
||||
let network ~clock nat qubesDB =
|
||||
let network nat qubesDB =
|
||||
(* Read configuration from QubesDB *)
|
||||
Dao.read_network_config qubesDB >>= fun config ->
|
||||
(* Initialise connection to NetVM *)
|
||||
Uplink.connect ~clock config >>= fun uplink ->
|
||||
Uplink.connect config >>= fun uplink ->
|
||||
(* Report success *)
|
||||
Dao.set_iptables_error qubesDB "" >>= fun () ->
|
||||
(* Set up client-side networking *)
|
||||
@ -29,8 +29,8 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
in
|
||||
(* Handle packets from both networks *)
|
||||
Lwt.choose [
|
||||
Client_net.listen router;
|
||||
Uplink.listen uplink router
|
||||
Client_net.listen Clock.elapsed_ns router;
|
||||
Uplink.listen uplink Clock.elapsed_ns router
|
||||
]
|
||||
|
||||
(* We don't use the GUI, but it's interesting to keep an eye on it.
|
||||
@ -41,18 +41,18 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
(fun () ->
|
||||
gui >>= fun gui ->
|
||||
Log.info (fun f -> f "GUI agent connected");
|
||||
GUI.listen gui
|
||||
GUI.listen gui ()
|
||||
)
|
||||
(fun `Cant_happen -> assert false)
|
||||
(fun ex ->
|
||||
Log.warn (fun f -> f "GUI thread failed: %s" (Printexc.to_string ex));
|
||||
return ()
|
||||
Lwt.return_unit
|
||||
)
|
||||
)
|
||||
|
||||
(* Main unikernel entry point (called from auto-generated main.ml). *)
|
||||
let start clock =
|
||||
let start_time = Clock.elapsed_ns clock in
|
||||
let start _clock =
|
||||
let start_time = Clock.elapsed_ns () in
|
||||
(* Start qrexec agent, GUI agent and QubesDB agent in parallel *)
|
||||
let qrexec = RExec.connect ~domid:0 () in
|
||||
GUI.connect ~domid:0 () |> watch_gui;
|
||||
@ -63,19 +63,18 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
qubesDB >>= fun qubesDB ->
|
||||
let startup_time =
|
||||
let (-) = Int64.sub in
|
||||
let time_in_ns = Clock.elapsed_ns clock - start_time in
|
||||
let time_in_ns = Clock.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 =
|
||||
OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
|
||||
return () in
|
||||
Lwt.return_unit in
|
||||
(* Set up networking *)
|
||||
let get_time () = Clock.elapsed_ns clock in
|
||||
let max_entries = Key_gen.nat_table_size () in
|
||||
My_nat.create ~get_time ~max_entries >>= fun nat ->
|
||||
let net_listener = network ~clock nat qubesDB in
|
||||
My_nat.create ~max_entries >>= fun nat ->
|
||||
let net_listener = network nat qubesDB in
|
||||
(* Report memory usage to XenStore *)
|
||||
Memory_pressure.init ();
|
||||
(* Run until something fails or we get a shutdown request. *)
|
||||
|
19
uplink.ml
19
uplink.ml
@ -9,7 +9,7 @@ module Eth = Ethernet.Make(Netif)
|
||||
let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM"
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
|
||||
module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
module Make(Clock : Mirage_clock.MCLOCK) = struct
|
||||
module Arp = Arp.Make(Eth)(OS.Time)
|
||||
|
||||
type t = {
|
||||
@ -17,6 +17,7 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
eth : Eth.t;
|
||||
arp : Arp.t;
|
||||
interface : interface;
|
||||
fragments : Fragments.Cache.t;
|
||||
}
|
||||
|
||||
class netvm_iface eth mac ~my_ip ~other_ip : interface = object
|
||||
@ -31,13 +32,13 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
)
|
||||
end
|
||||
|
||||
let listen t router =
|
||||
let listen t get_ts router =
|
||||
Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame ->
|
||||
(* Handle one Ethernet frame from NetVM *)
|
||||
Eth.input t.eth
|
||||
~arpv4:(Arp.input t.arp)
|
||||
~ipv4:(fun ip ->
|
||||
match Nat_packet.of_ipv4_packet ip with
|
||||
match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip with
|
||||
| exception ex ->
|
||||
Log.err (fun f -> f "Error unmarshalling ethernet frame from uplink: %s@.%a" (Printexc.to_string ex)
|
||||
Cstruct.hexdump_pp frame
|
||||
@ -45,17 +46,18 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
Lwt.return_unit
|
||||
| Error e ->
|
||||
Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
|
||||
Lwt.return ()
|
||||
| Ok packet ->
|
||||
Lwt.return_unit
|
||||
| Ok None -> Lwt.return_unit
|
||||
| Ok (Some packet) ->
|
||||
Firewall.ipv4_from_netvm router packet
|
||||
)
|
||||
~ipv6:(fun _ip -> return ())
|
||||
~ipv6:(fun _ip -> Lwt.return_unit)
|
||||
frame
|
||||
) >|= or_raise "Uplink listen loop" Netif.pp_error
|
||||
|
||||
let interface t = t.interface
|
||||
|
||||
let connect ~clock:_ config =
|
||||
let connect config =
|
||||
let ip = config.Dao.uplink_our_ip in
|
||||
Netif.connect "0" >>= fun net ->
|
||||
Eth.connect net >>= fun eth ->
|
||||
@ -67,5 +69,6 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
|
||||
let interface = new netvm_iface eth netvm_mac
|
||||
~my_ip:ip
|
||||
~other_ip:config.Dao.uplink_netvm_ip in
|
||||
return { net; eth; arp; interface }
|
||||
let fragments = Fragments.Cache.create (256 * 1024) in
|
||||
Lwt.return { net; eth; arp; interface ; fragments }
|
||||
end
|
||||
|
@ -5,15 +5,15 @@
|
||||
|
||||
open Fw_utils
|
||||
|
||||
module Make(Clock : Mirage_clock_lwt.MCLOCK) : sig
|
||||
module Make(Clock : Mirage_clock.MCLOCK) : sig
|
||||
type t
|
||||
|
||||
val connect : clock:Clock.t -> Dao.network_config -> t Lwt.t
|
||||
val connect : Dao.network_config -> t Lwt.t
|
||||
(** Connect to our NetVM (gateway). *)
|
||||
|
||||
val interface : t -> interface
|
||||
(** The network interface to NetVM. *)
|
||||
|
||||
val listen : t -> Router.t -> unit Lwt.t
|
||||
val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t
|
||||
(** Handle incoming frames from NetVM. *)
|
||||
end
|
||||
|
Loading…
Reference in New Issue
Block a user