qubes-mirage-firewall/uplink.ml
Thomas Leonard 0230cfaf1e Updates for mirage 2.9.0
- Unpin bootvar and use register ~argv:no_argv` instead.
- Use new name for uplink device ("0", not "tap0").
- Don't configure logging - mirage does that for us now.
2016-05-14 10:44:57 +01:00

62 lines
1.9 KiB
OCaml

(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Lwt.Infix
open Utils
module Eth = Ethif.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 : V1.CLOCK) = struct
module Arp = Arpv4.Make(Eth)(Clock)(OS.Time)
module IPv4 = Ipv4.Make(Eth)(Arp)
type t = {
net : Netif.t;
eth : Eth.t;
arp : Arp.t;
interface : interface;
}
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 ip =
FrameQ.send queue (fun () ->
mac >>= fun dst ->
let eth_hdr = eth_header_ipv4 ~src:(Eth.mac eth) ~dst in
Eth.writev eth (eth_hdr :: ip)
)
end
let listen t router =
Netif.listen t.net (fun frame ->
(* Handle one Ethernet frame from NetVM *)
Eth.input t.eth
~arpv4:(Arp.input t.arp)
~ipv4:(fun _ip -> Firewall.ipv4_from_netvm router frame)
~ipv6:(fun _ip -> return ())
frame
)
let interface t = t.interface
let connect config =
let ip = config.Dao.uplink_our_ip in
Netif.connect "0" >>= or_fail "Can't connect uplink device" >>= fun net ->
Eth.connect net >>= or_fail "Can't make Ethernet device for tap" >>= fun eth ->
Arp.connect eth >>= or_fail "Can't add ARP" >>= fun arp ->
Arp.add_ip arp ip >>= fun () ->
let netvm_mac = Arp.query arp config.Dao.uplink_netvm_ip >|= function
| `Timeout -> failwith "ARP timeout getting MAC of our NetVM"
| `Ok netvm_mac -> netvm_mac in
let interface = new netvm_iface eth netvm_mac
~my_ip:ip
~other_ip:config.Dao.uplink_netvm_ip in
return { net; eth; arp; interface }
end