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

Merge pull request #90 from talex5/cleanup

Browse Source 
Minor cleanups
This commit is contained in:
Thomas Leonard 2020-01-14 12:54:48 +00:00 committed by GitHub
commit 16581b1e2e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 83 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Dockerfile
View File

@ -9,7 +9,7 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155
# latest versions.
RUN cd ~/opam-repository && git fetch origin master && git reset --hard d205c265cee9a86869259180fd2238da98370430 && opam update
RUN opam depext -i -y mirage.3.7.4 lwt
RUN opam depext -i -y mirage.3.7.4 lwt.4.5.0
RUN mkdir /home/opam/qubes-mirage-firewall
ADD config.ml /home/opam/qubes-mirage-firewall/config.ml
WORKDIR /home/opam/qubes-mirage-firewall

2
build-with-docker.sh
View File

@ -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: 8a337e61e7d093f7c1f0fa5fe277dace4d606bfa06cfde3f2d61d6bdee6eefbc"
echo "SHA2 last known: 91c5bf44a85339aaf14e4763a29c2b64537f5bc41cd7dc2571af954ec9dd3cad"
echo "(hashes should match for released versions)"

42
firewall.ml
View File

@ -12,33 +12,23 @@ module Log = (val Logs.src_log src : Logs.LOG)
let transmit_ipv4 packet iface =
Lwt.catch
(fun () ->
Lwt.catch
(fun () ->
let fragments = ref [] in
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, 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_unit
)
)
let fragments = ref [] in
iface#writev `IPv4 (fun b ->
match Nat_packet.into_cstruct packet b with
| Error e ->
Log.warn (fun f -> f "Failed to NAT packet to %a: %a"
Ipaddr.V4.pp iface#other_ip
Nat_packet.pp_error e);
0
| 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.err (fun f -> f "Exception in transmit_ipv4: %s for:@.%a"
(Printexc.to_string ex)
Nat_packet.pp packet
);
Log.warn (fun f -> f "Failed to write packet to %a: %s"
Ipaddr.V4.pp iface#other_ip
(Printexc.to_string ex));
Lwt.return_unit
)

2
unikernel.ml
View File

@ -8,8 +8,6 @@ let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code"
module Log = (val Logs.src_log src : Logs.LOG)
module Main (Clock : Mirage_clock.MCLOCK) = struct
module Uplink = Uplink.Make(Clock)
(* Set up networking and listen for incoming packets. *)
let network nat qubesDB =
(* Read configuration from QubesDB *)

118
uplink.ml
View File

@ -9,66 +9,64 @@ 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.MCLOCK) = struct
module Arp = Arp.Make(Eth)(OS.Time)
module Arp = Arp.Make(Eth)(OS.Time)
type t = {
net : Netif.t;
eth : Eth.t;
arp : Arp.t;
interface : interface;
fragments : Fragments.Cache.t;
}
type t = {
net : Netif.t;
eth : Eth.t;
arp : Arp.t;
interface : interface;
fragments : Fragments.Cache.t;
}
class netvm_iface eth mac ~my_ip ~other_ip : interface = object
val queue = FrameQ.create (Ipaddr.V4.to_string other_ip)
method my_mac = Eth.mac eth
method my_ip = my_ip
method other_ip = other_ip
method writev ethertype fillfn =
FrameQ.send queue (fun () ->
mac >>= fun dst ->
Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
)
end
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 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
);
Lwt.return_unit
| Error e ->
Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
Lwt.return_unit
| Ok None -> Lwt.return_unit
| Ok (Some packet) ->
Firewall.ipv4_from_netvm router packet
)
~ipv6:(fun _ip -> Lwt.return_unit)
frame
) >|= or_raise "Uplink listen loop" Netif.pp_error
let interface t = t.interface
let connect config =
let ip = config.Dao.uplink_our_ip in
Netif.connect "0" >>= fun net ->
Eth.connect net >>= fun eth ->
Arp.connect eth >>= fun arp ->
Arp.add_ip arp ip >>= fun () ->
let netvm_mac =
Arp.query arp config.Dao.uplink_netvm_ip
>|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
let interface = new netvm_iface eth netvm_mac
~my_ip:ip
~other_ip:config.Dao.uplink_netvm_ip in
let fragments = Fragments.Cache.create (256 * 1024) in
Lwt.return { net; eth; arp; interface ; fragments }
class netvm_iface eth mac ~my_ip ~other_ip : interface = object
val queue = FrameQ.create (Ipaddr.V4.to_string other_ip)
method my_mac = Eth.mac eth
method my_ip = my_ip
method other_ip = other_ip
method writev ethertype fillfn =
FrameQ.send queue (fun () ->
mac >>= fun dst ->
Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error
)
end
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 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
);
Lwt.return_unit
| Error e ->
Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
Lwt.return_unit
| Ok None -> Lwt.return_unit
| Ok (Some packet) ->
Firewall.ipv4_from_netvm router packet
)
~ipv6:(fun _ip -> Lwt.return_unit)
frame
) >|= or_raise "Uplink listen loop" Netif.pp_error
let interface t = t.interface
let connect config =
let ip = config.Dao.uplink_our_ip in
Netif.connect "0" >>= fun net ->
Eth.connect net >>= fun eth ->
Arp.connect eth >>= fun arp ->
Arp.add_ip arp ip >>= fun () ->
let netvm_mac =
Arp.query arp config.Dao.uplink_netvm_ip
>|= or_raise "Getting MAC of our NetVM" Arp.pp_error in
let interface = new netvm_iface eth netvm_mac
~my_ip:ip
~other_ip:config.Dao.uplink_netvm_ip in
let fragments = Fragments.Cache.create (256 * 1024) in
Lwt.return { net; eth; arp; interface ; fragments }

16
uplink.mli
View File

@ -5,15 +5,13 @@
open Fw_utils
module Make(Clock : Mirage_clock.MCLOCK) : sig
type t
type t
val connect : Dao.network_config -> t Lwt.t
(** Connect to our NetVM (gateway). *)
val connect : Dao.network_config -> t Lwt.t
(** Connect to our NetVM (gateway). *)
val interface : t -> interface
(** The network interface to NetVM. *)
val interface : t -> interface
(** The network interface to NetVM. *)
val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t
(** Handle incoming frames from NetVM. *)
end
val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t
(** Handle incoming frames from NetVM. *)