Git-Mirrors
/
qubes-mirage-firewall
mirror of https://github.com/mirage/qubes-mirage-firewall.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Update to new Logs API 

Note: this reintroduces mirage-qubes pin, as that uses Logs too.
This commit is contained in:
Thomas Leonard 2016-01-08 11:31:27 +00:00
parent 54ad568612
commit e05a92da50
10 changed files with 59 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.travis.yml
View File

@ -19,4 +19,4 @@ addons:
- camlp4-extra
- time
env:
- FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.02 MIRAGE_BACKEND=xen PINS="mirage-xen:https://github.com/talex5/mirage-platform.git#mm mirage-nat:https://github.com/talex5/mirage-nat.git#simplify-checksum tcpip:https://github.com/mirage/mirage-tcpip.git mirage-net-xen:https://github.com/talex5/mirage-net-xen.git#disconnect"
- FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.02 MIRAGE_BACKEND=xen PINS="mirage-xen:https://github.com/talex5/mirage-platform.git#mm mirage-qubes:https://github.com/talex5/mirage-qubes.git mirage-nat:https://github.com/talex5/mirage-nat.git#simplify-checksum tcpip:https://github.com/mirage/mirage-tcpip.git mirage-net-xen:https://github.com/talex5/mirage-net-xen.git#disconnect"

1
README.md
View File

@ -22,6 +22,7 @@ To build (tested by creating a fresh Fedora 23 AppVM in Qubes):
opam pin add -y mirage-xen 'https://github.com/talex5/mirage-platform.git#mm'
opam pin add -y mirage-net-xen 'https://github.com/talex5/mirage-net-xen.git#disconnect'
opam pin add -y tcpip https://github.com/mirage/mirage-tcpip.git
opam pin add -y mirage-qubes https://github.com/talex5/mirage-qubes.git
opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum'
opam install mirage

22
client_eth.ml
View File

@ -109,16 +109,16 @@ module ARP = struct
let input_query t frame =
let open Arpv4_wire in
let req_ipv4 = Ipaddr.V4.of_int32 (get_arp_tpa frame) in
Log.info "who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4));
Log.info (fun f -> f "who-has %s?" (Ipaddr.V4.to_string req_ipv4));
if req_ipv4 = t.client_link#other_ip then (
Log.info "ignoring request for client's own IP" Logs.unit;
Log.info (fun f -> f "ignoring request for client's own IP");
None
) else match lookup t req_ipv4 with
| None ->
Log.info "unknown address; not responding" Logs.unit;
Log.info (fun f -> f "unknown address; not responding");
None
| Some req_mac ->
Log.info "responding to: who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4));
Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4));
Some (to_wire {
op = `Reply;
(* The Target Hardware Address and IP are copied from the request *)
@ -134,18 +134,18 @@ module ARP = struct
let sha = Macaddr.of_bytes_exn (copy_arp_sha frame) in
match lookup t spa with
| Some real_mac when Macaddr.compare sha real_mac = 0 ->
Log.info "client suggests updating %s -> %s (as expected)"
(fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
Log.info (fun f -> f "client suggests updating %s -> %s (as expected)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
| Some other_mac ->
Log.warn "client suggests incorrect update %s -> %s (should be %s)"
(fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac));
Log.warn (fun f -> f "client suggests incorrect update %s -> %s (should be %s)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac));
| None ->
Log.warn "client suggests incorrect update %s -> %s (unexpected IP)"
(fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha))
Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha))
let input t frame =
match Arpv4_wire.get_arp_op frame with
|1 -> input_query t frame
|2 -> input_gratuitous t frame; None
|n -> Log.warn "unknown message %d - ignored" (fun f -> f n); None
|n -> Log.warn (fun f -> f "unknown message %d - ignored" n); None
end

25
client_net.ml
View File

@ -33,16 +33,15 @@ let input_ipv4 ~client_ip ~router frame packet =
let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in
if src = client_ip then Firewall.ipv4_from_client router frame
else (
Log.warn "Incorrect source IP %a in IP packet from %a (dropping)"
(fun f -> f Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip);
Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)"
Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip);
return ()
)
(** Connect to a new client's interface and listen for incoming frames. *)
let add_vif { Dao.domid; device_id; client_ip } ~router ~cleanup_tasks =
Netback.make ~domid ~device_id >>= fun backend ->
Log.info "Client %d (IP: %s) ready" (fun f ->
f domid (Ipaddr.V4.to_string client_ip));
Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip));
ClientEth.connect backend >>= or_fail "Can't make Ethernet device" >>= fun eth ->
let client_mac = Netback.mac backend in
let client_eth = router.Router.client_eth in
@ -53,32 +52,32 @@ let add_vif { Dao.domid; device_id; client_ip } ~router ~cleanup_tasks =
let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in
Netback.listen backend (fun frame ->
match Wire_structs.parse_ethernet_frame frame with
| None -> Log.warn "Invalid Ethernet frame" Logs.unit; return ()
| None -> Log.warn (fun f -> f "Invalid Ethernet frame"); return ()
| Some (typ, _destination, payload) ->
match typ with
| Some Wire_structs.ARP -> input_arp ~fixed_arp ~eth payload
| Some Wire_structs.IPv4 -> input_ipv4 ~client_ip ~router frame payload
| Some Wire_structs.IPv6 -> return ()
| None -> Logs.warn "Unknown Ethernet type" Logs.unit; Lwt.return_unit
| None -> Logs.warn (fun f -> f "Unknown Ethernet type"); Lwt.return_unit
)
(** A new client VM has been found in XenStore. Find its interface and connect to it. *)
let add_client ~router domid =
let cleanup_tasks = Cleanup.create () in
Log.info "add client domain %d" (fun f -> f domid);
Log.info (fun f -> f "add client domain %d" domid);
Lwt.async (fun () ->
Lwt.catch (fun () ->
Dao.client_vifs domid >>= function
| [] ->
Log.warn "Client has no interfaces" Logs.unit;
Log.warn (fun f -> f "Client has no interfaces");
return ()
| vif :: others ->
if others <> [] then Log.warn "Client has multiple interfaces; using first" Logs.unit;
if others <> [] then Log.warn (fun f -> f "Client has multiple interfaces; using first");
add_vif vif ~router ~cleanup_tasks
)
(fun ex ->
Log.warn "Error connecting client domain %d: %s"
(fun f -> f domid (Printexc.to_string ex));
Log.warn (fun f -> f "Error connecting client domain %d: %s"
domid (Printexc.to_string ex));
return ()
)
);
@ -87,13 +86,13 @@ let add_client ~router domid =
(** Watch XenStore for notifications of new clients. *)
let listen router =
let backend_vifs = "backend/vif" in
Log.info "Watching %s" (fun f -> f backend_vifs);
Log.info (fun f -> f "Watching %s" backend_vifs);
Dao.watch_clients (fun new_set ->
(* Check for removed clients *)
!clients |> IntMap.iter (fun key cleanup ->
if not (IntSet.mem key new_set) then (
clients := !clients |> IntMap.remove key;
Log.info "client %d has gone" (fun f -> f key);
Log.info (fun f -> f "client %d has gone" key);
Cleanup.cleanup cleanup
)
);

6
command.ml
View File

@ -12,14 +12,14 @@ module Log = (val Logs.src_log src : Logs.LOG)
let set_date_time flow =
Flow.read_line flow >|= function
| `Eof -> Log.warn "EOF reading time from dom0" Logs.unit; 1
| `Ok line -> Log.info "TODO: set time to %S" (fun f -> f 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 "<< %s" (fun f -> f 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

35
firewall.ml
View File

@ -33,7 +33,7 @@ let ports transport =
let classify t frame =
match Nat_rewrite.layers frame with
| None ->
Log.warn "Failed to parse frame" Logs.unit;
Log.warn (fun f -> f "Failed to parse frame");
None
| Some (_eth, ip, transport) ->
let src, dst = Nat_rewrite.addresses_of_ip ip in
@ -81,31 +81,31 @@ let translate t frame =
let random_user_port () =
1024 + Random.int (0xffff - 1024)
let rec add_nat_rule_and_transmit ?(retries=100) t frame fn fmt logf =
let rec add_nat_rule_and_transmit ?(retries=100) t frame fn logf =
let xl_port = random_user_port () in
match fn xl_port with
| exception Out_of_memory ->
(* Because hash tables resize in big steps, this can happen even if we have a fair
chunk of free memory. *)
Log.warn "Out_of_memory adding NAT rule. Dropping NAT table..." Logs.unit;
Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table...");
Router.reset t;
add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn fmt logf
add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn logf
| Nat_rewrite.Overlap when retries < 0 -> return ()
| Nat_rewrite.Overlap ->
if retries = 0 then (
Log.warn "Failed to find a free port; resetting NAT table" Logs.unit;
Log.warn (fun f -> f "Failed to find a free port; resetting NAT table");
Router.reset t;
);
add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn fmt logf (* Try a different port *)
add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn logf (* Try a different port *)
| Nat_rewrite.Unparseable ->
Log.warn "Failed to add NAT rule: Unparseable" Logs.unit;
Log.warn (fun f -> f "Failed to add NAT rule: Unparseable");
return ()
| Nat_rewrite.Ok _ ->
Log.info fmt (logf xl_port);
Log.info (logf xl_port);
match translate t frame with
| Some frame -> forward_ipv4 t frame
| None ->
Log.warn "No NAT entry, even after adding one!" Logs.unit;
Log.warn (fun f -> f "No NAT entry, even after adding one!");
return ()
(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
@ -113,14 +113,13 @@ let add_nat_and_forward_ipv4 t ~frame =
let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in
add_nat_rule_and_transmit t frame
(Nat_rewrite.make_nat_entry t.Router.nat frame xl_host)
"added NAT entry: %s:%d -> firewall:%d -> %d:%s"
(fun xl_port f ->
match Nat_rewrite.layers frame with
| None -> assert false
| Some (_eth, ip, transport) ->
let src, dst = Nat_rewrite.addresses_of_ip ip in
let sport, dport = Nat_rewrite.ports_of_transport transport in
f (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst)
f "added NAT entry: %s:%d -> firewall:%d -> %d:%s" (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst)
)
(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *)
@ -131,14 +130,14 @@ let nat_to t ~frame ~host ~port =
(fun xl_port ->
Nat_rewrite.make_redirect_entry t.Router.nat frame (xl_host, xl_port) (target, port)
)
"added NAT redirect %s:%d -> %d:firewall:%d -> %d:%a"
(fun xl_port f ->
match Nat_rewrite.layers frame with
| None -> assert false
| Some (_eth, ip, transport) ->
let src, _dst = Nat_rewrite.addresses_of_ip ip in
let sport, dport = Nat_rewrite.ports_of_transport transport in
f (Ipaddr.to_string src) sport dport xl_port port pp_host host
f "added NAT redirect %s:%d -> %d:firewall:%d -> %d:%a"
(Ipaddr.to_string src) sport dport xl_port port pp_host host
)
(* Handle incoming packets *)
@ -149,21 +148,21 @@ let apply_rules t rules info =
| `Accept, `Client client_link -> transmit ~frame client_link
| `Accept, (`External _ | `NetVM) -> transmit ~frame t.Router.uplink
| `Accept, `Unknown_client _ ->
Log.warn "Dropping packet to unknown client %a" (fun f -> f pp_packet info);
Log.warn (fun f -> f "Dropping packet to unknown client %a" pp_packet info);
return ()
| `Accept, (`Firewall_uplink | `Client_gateway) ->
Log.warn "Bad rule: firewall can't accept packets %a" (fun f -> f pp_packet info);
Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info);
return ()
| `NAT, _ -> add_nat_and_forward_ipv4 t ~frame
| `NAT_to (host, port), _ -> nat_to t ~frame ~host ~port
| `Drop reason, _ ->
Log.info "Dropped packet (%s) %a" (fun f -> f reason pp_packet info);
Log.info (fun f -> f "Dropped packet (%s) %a" reason pp_packet info);
return ()
let handle_low_memory t =
match Memory_pressure.status () with
| `Memory_critical -> (* TODO: should happen before copying and async *)
Log.warn "Memory low - dropping packet and resetting NAT table" Logs.unit;
Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table");
Router.reset t;
`Memory_critical
| `Ok -> `Ok
@ -190,7 +189,7 @@ let ipv4_from_netvm t frame =
| Some info ->
match info.src with
| `Client _ | `Unknown_client _ | `Firewall_uplink | `Client_gateway ->
Log.warn "Frame from NetVM has internal source IP address! %a" (fun f -> f pp_packet info);
Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info);
return ()
| `External _ | `NetVM ->
match translate t frame with

4
memory_pressure.ml
View File

@ -12,8 +12,8 @@ let pagesize_kb = Io_page.page_size / 1024
let meminfo ~used =
let mem_total = total_pages * pagesize_kb in
let mem_free = (total_pages - used) * pagesize_kb in
Log.info "Writing meminfo: free %d / %d kB (%.2f %%)"
(fun f -> f mem_free mem_total (float_of_int mem_free /. float_of_int mem_total *. 100.0));
Log.info (fun f -> f "Writing meminfo: free %d / %d kB (%.2f %%)"
mem_free mem_total (float_of_int mem_free /. float_of_int mem_total *. 100.0));
Printf.sprintf "MemTotal: %d kB\n\
MemFree: %d kB\n\
Buffers: 0 kB\n\

5
mirage_logs.ml
View File

@ -19,7 +19,7 @@ let fmt_timestamp tm =
module Make (C : V1.CLOCK) = struct
let init_logging () =
let report src level k fmt msgf =
let report src level ~over k msgf =
let now = C.time () |> Clock.gmtime |> fmt_timestamp in
let lvl = string_of_level level in
let k _ =
@ -28,8 +28,9 @@ module Make (C : V1.CLOCK) = struct
output_string stderr (msg ^ "\n");
flush stderr;
MProf.Trace.label msg;
over ();
k () in
msgf @@ fun ?header:_ ?tags:_ ->
msgf @@ fun ?header:_ ?tags:_ fmt ->
Format.kfprintf k log_fmt ("%s: %s [%s] " ^^ fmt) now lvl (Logs.Src.name src) in
Logs.set_reporter { Logs.report }
end

4
router.ml
View File

@ -25,8 +25,8 @@ let target t buf =
match Client_eth.lookup t.client_eth dst_ip with
| Some client_link -> Some (client_link :> interface)
| None ->
Log.warn "Packet to unknown internal client %a - dropping"
(fun f -> f Ipaddr.V4.pp_hum dst_ip);
Log.warn (fun f -> f "Packet to unknown internal client %a - dropping"
Ipaddr.V4.pp_hum dst_ip);
None
) else Some t.uplink

12
unikernel.ml
View File

@ -21,8 +21,8 @@ module Main (Clock : V1.CLOCK) = struct
let network qubesDB =
(* Read configuration from QubesDB *)
let config = Dao.read_network_config qubesDB in
Logs.info "Client (internal) network is %a"
(fun f -> f Ipaddr.V4.Prefix.pp_hum config.Dao.clients_prefix);
Logs.info (fun f -> f "Client (internal) network is %a"
Ipaddr.V4.Prefix.pp_hum config.Dao.clients_prefix);
(* Initialise connection to NetVM *)
Uplink.connect config >>= fun uplink ->
(* Report success *)
@ -55,10 +55,12 @@ module Main (Clock : V1.CLOCK) = struct
gui >>= fun gui ->
Lwt.async (fun () -> GUI.listen gui);
qubesDB >>= fun qubesDB ->
Log.info "agents connected in %.3f s (CPU time used since boot: %.3f s)"
(fun f -> f (Clock.time () -. start_time) (Sys.time ()));
Log.info (fun f -> f "agents connected in %.3f s (CPU time used since boot: %.3f s)"
(Clock.time () -. start_time) (Sys.time ()));
(* Watch for shutdown requests from Qubes *)
let shutdown_rq = OS.Lifecycle.await_shutdown () >>= fun (`Poweroff | `Reboot) -> return () in
let shutdown_rq =
OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) ->
return () in
(* Set up networking *)
let net_listener = network qubesDB in
(* Report memory usage to XenStore *)