Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-10-01 01:05:39 -04:00
Code Issues Packages Projects Releases Wiki Activity

use tcpip 3.7, ethernet, arp, mirage-nat 1.1.0

Browse Source
This commit is contained in:
Mindy 2019-03-17 16:32:17 -05:00
parent d7cd4e2961
commit 0852aa0f43
7 changed files with 63 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
client_eth.ml
View File

@ -82,7 +82,7 @@ module ARP = struct
let create ~net client_link = {net; client_link}
let input_query t arp =
let req_ipv4 = arp.Arpv4_packet.tpa in
let req_ipv4 = arp.Arp_packet.target_ip in
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 (fun f -> f "ignoring request for client's own IP");
@ -93,34 +93,32 @@ module ARP = struct
None
| Some req_mac ->
Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4));
let req_spa = arp.Arpv4_packet.spa in
let req_sha = arp.Arpv4_packet.sha in
Some { Arpv4_packet.
op = Arpv4_wire.Reply;
Some { Arp_packet.
operation = Arp_packet.Reply;
(* The Target Hardware Address and IP are copied from the request *)
tha = req_sha;
tpa = req_spa;
sha = req_mac;
spa = req_ipv4;
target_ip = arp.Arp_packet.source_ip;
target_mac = arp.Arp_packet.source_mac;
source_ip = req_ipv4;
source_mac = req_mac;
}
let input_gratuitous t arp =
let spa = arp.Arpv4_packet.spa in
let sha = arp.Arpv4_packet.sha in
match lookup t spa with
| Some real_mac when Macaddr.compare sha real_mac = 0 ->
let source_ip = arp.Arp_packet.source_ip in
let source_mac = arp.Arp_packet.source_mac in
match lookup t source_ip with
| Some real_mac when Macaddr.compare source_mac real_mac = 0 ->
Log.info (fun f -> f "client suggests updating %s -> %s (as expected)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha));
(Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac));
| Some 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));
(Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac) (Macaddr.to_string other_mac));
| None ->
Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)"
(Ipaddr.V4.to_string spa) (Macaddr.to_string sha))
(Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac))
let input t arp =
let op = arp.Arpv4_packet.op in
let op = arp.Arp_packet.operation in
match op with
| Arpv4_wire.Request -> input_query t arp
| Arpv4_wire.Reply -> input_gratuitous t arp; None
| Arp_packet.Request -> input_query t arp
| Arp_packet.Reply -> input_gratuitous t arp; None
end

2
client_eth.mli
View File

@ -47,7 +47,7 @@ module ARP : sig
(** [create ~net client_link] is an ARP responder for [client_link].
It answers only for the client's gateway address. *)
val input : arp -> Arpv4_packet.t -> Arpv4_packet.t option
val input : arp -> Arp_packet.t -> Arp_packet.t option
(** Process one ethernet frame containing an ARP message.
Returns a response frame, if one is needed. *)
end

37
client_net.ml
View File

@ -5,24 +5,24 @@ open Lwt.Infix
open Fw_utils
module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs))
module ClientEth = Ethif.Make(Netback)
module ClientEth = Ethernet.Make(Netback)
let src = Logs.Src.create "client_net" ~doc:"Client networking"
module Log = (val Logs.src_log src : Logs.LOG)
let writev eth data =
let writev eth dst proto fillfn =
Lwt.catch
(fun () ->
ClientEth.writev eth data >|= function
ClientEth.write eth dst proto fillfn >|= function
| Ok () -> ()
| Error e ->
Log.err (fun f -> f "error trying to send to client:@\n@[<v2> %a@]@\nError: @[%a@]"
Cstruct.hexdump_pp (Cstruct.concat data) ClientEth.pp_error e);
Log.err (fun f -> f "error trying to send to client: @[%a@]"
ClientEth.pp_error e);
)
(fun ex ->
(* Usually Netback_shutdown, because the client disconnected *)
Log.err (fun f -> f "uncaught exception trying to send to client:@\n@[<v2> %a@]@\nException: @[%s@]"
Cstruct.hexdump_pp (Cstruct.concat data) (Printexc.to_string ex));
Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]"
(Printexc.to_string ex));
Lwt.return ()
)
@ -32,10 +32,9 @@ class client_iface eth ~gateway_ip ~client_ip client_mac : client_link = object
method other_mac = client_mac
method my_ip = gateway_ip
method other_ip = client_ip
method writev proto ip =
method writev proto fillfn =
FrameQ.send queue (fun () ->
let eth_hdr = eth_header proto ~src:(ClientEth.mac eth) ~dst:client_mac in
writev eth (eth_hdr :: ip)
writev eth client_mac proto fillfn
)
end
@ -43,15 +42,15 @@ let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty
(** Handle an ARP message from the client. *)
let input_arp ~fixed_arp ~iface request =
match Arpv4_packet.Unmarshal.of_cstruct request with
match Arp_packet.decode request with
| Error e ->
Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arpv4_packet.Unmarshal.pp_error e);
Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arp_packet.pp_error e);
Lwt.return ()
| Ok arp ->
match Client_eth.ARP.input fixed_arp arp with
| None -> return ()
| Some response ->
iface#writev Ethif_wire.ARP [Arpv4_packet.Marshal.make_cstruct 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 ~client_ip ~router packet =
@ -81,8 +80,8 @@ 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
Netback.listen backend (fun frame ->
match Ethif_packet.Unmarshal.of_cstruct frame with
Netback.listen backend ~header_size:14 (fun frame ->
match Ethernet_packet.Unmarshal.of_cstruct frame with
| exception ex ->
Log.err (fun f -> f "Error unmarshalling ethernet frame from client: %s@.%a" (Printexc.to_string ex)
Cstruct.hexdump_pp frame
@ -90,10 +89,10 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks
Lwt.return_unit
| Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); return ()
| Ok (eth, payload) ->
match eth.Ethif_packet.ethertype with
| Ethif_wire.ARP -> input_arp ~fixed_arp ~iface payload
| Ethif_wire.IPv4 -> input_ipv4 ~client_ip ~router payload
| Ethif_wire.IPv6 -> return ()
match eth.Ethernet_packet.ethertype with
| `ARP -> input_arp ~fixed_arp ~iface payload
| `IPv4 -> input_ipv4 ~client_ip ~router payload
| `IPv6 -> return () (* TODO: oh no! *)
)
>|= or_raise "Listen on client interface" Netback.pp_error

8
config.ml
View File

@ -21,13 +21,17 @@ let main =
package "vchan";
package "cstruct";
package "astring";
package "tcpip" ~sublibs:["stack-direct"; "xen"; "arpv4"] ~min:"3.1.0";
package "tcpip" ~min:"3.7.0";
package "arp";
package "arp-mirage";
package "ethernet";
package "mirage-protocols";
package "shared-memory-ring" ~min:"3.0.0";
package "netchannel" ~min:"1.8.0";
package "mirage-net-xen" ~min:"1.7.1";
package "ipaddr" ~min:"3.0.0";
package "mirage-qubes";
package "mirage-nat";
package "mirage-nat" ~min:"1.1.0";
package "mirage-logs";
]
"Unikernel.Main" (mclock @-> job)

15
firewall.ml
View File

@ -13,9 +13,18 @@ module Log = (val Logs.src_log src : Logs.LOG)
let transmit_ipv4 packet iface =
Lwt.catch
(fun () ->
let transport = Nat_packet.to_cstruct packet in
Lwt.catch
(fun () -> iface#writev Ethif_wire.IPv4 transport)
(fun () ->
iface#writev `IPv4 (fun b ->
match Nat_packet.into_cstruct packet b with
| Error e ->
Log.warn (fun f -> f "Failed to write packet to %a: %a"
Ipaddr.V4.pp iface#other_ip
Nat_packet.pp_error e);
0
| Ok n -> n
)
)
(fun ex ->
Log.warn (fun f -> f "Failed to write packet to %a: %s"
Ipaddr.V4.pp iface#other_ip
@ -35,7 +44,7 @@ let forward_ipv4 t packet =
let `IPv4 (ip, _) = packet in
match Router.target t ip with
| Some iface -> transmit_ipv4 packet iface
| None -> return ()
| None -> Lwt.return_unit
(* Packet classification *)

4
fw_utils.ml
View File

@ -21,7 +21,7 @@ module IntMap = Map.Make(Int)
(** An Ethernet interface. *)
class type interface = object
method my_mac : Macaddr.t
method writev : Ethif_wire.ethertype -> Cstruct.t list -> unit Lwt.t
method writev : Mirage_protocols.Ethernet.proto -> (Cstruct.t -> int) -> unit Lwt.t
method my_ip : Ipaddr.V4.t
method other_ip : Ipaddr.V4.t
end
@ -34,7 +34,7 @@ end
(** An Ethernet header from [src]'s MAC address to [dst]'s with an IPv4 payload. *)
let eth_header ethertype ~src ~dst =
Ethif_packet.Marshal.make_cstruct { Ethif_packet.source = src; destination = dst; ethertype }
Ethernet_packet.Marshal.make_cstruct { Ethernet_packet.source = src; destination = dst; ethertype }
let error fmt =
let err s = Failure s in

15
uplink.ml
View File

@ -4,13 +4,13 @@
open Lwt.Infix
open Fw_utils
module Eth = Ethif.Make(Netif)
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 Arp = Arpv4.Make(Eth)(Clock)(OS.Time)
module Arp = Arp.Make(Eth)(OS.Time)
type t = {
net : Netif.t;
@ -24,16 +24,15 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
method my_mac = Eth.mac eth
method my_ip = my_ip
method other_ip = other_ip
method writev ethertype payload =
method writev ethertype fillfn =
FrameQ.send queue (fun () ->
mac >>= fun dst ->
let eth_hdr = eth_header ethertype ~src:(Eth.mac eth) ~dst in
Eth.writev eth (eth_hdr :: payload) >|= or_raise "Write to uplink" Eth.pp_error
Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
)
end
let listen t router =
Netif.listen t.net (fun frame ->
Netif.listen t.net ~header_size:14 (fun frame ->
(* Handle one Ethernet frame from NetVM *)
Eth.input t.eth
~arpv4:(Arp.input t.arp)
@ -56,11 +55,11 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct
let interface t = t.interface
let connect ~clock config =
let connect ~clock:_ config =
let ip = config.Dao.uplink_our_ip in
Netif.connect "0" >>= fun net ->
Eth.connect net >>= fun eth ->
Arp.connect eth clock >>= fun arp ->
Arp.connect eth >>= fun arp ->
Arp.add_ip arp ip >>= fun () ->
let netvm_mac =
Arp.query arp config.Dao.uplink_netvm_ip