Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

First try about DNS packets #10

Draft
wants to merge 1 commit into
base: main
Choose a base branch
from
Draft

First try about DNS packets #10

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions config.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@ let main =
package "mirage-qubes" ~min:"0.9.1";
package "mirage-xen" ~min:"8.0.0";
package "ipaddr";
package "hxd" ~sublibs:[ "core"; "string" ];
package "ethernet" ~min:"3.0.0";
package "arp" ~min:"2.3.0" ~sublibs:[ "mirage" ];
package ~sublibs:[ "mirage" ] "miragevpn";
Expand Down
86 changes: 79 additions & 7 deletions unikernel.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,13 +16,20 @@ module Main
struct
module O = Miragevpn_mirage.Client_router (R) (M) (P) (T) (S)

type 'a stream = 'a Lwt_stream.t * ('a option -> unit)

type t =
{ ovpn : O.t
; table : Mirage_nat_lru.t
; mutable oc_fragments : Fragments.Cache.t
; oc : Nat_packet.t Lwt_stream.t * (Nat_packet.t option -> unit)
; ic : (Vif.t * Nat_packet.t) Lwt_stream.t * ((Vif.t * Nat_packet.t) option -> unit)
; oc : from_server_to_clients_stream
; ic : from_clients_to_server_stream
; dns : (Ipaddr.V4.t * Ipaddr.V4.t) * dns_stream
; vif0 : S.t
; clients : Clients.t }
and dns_stream = (Vif.t * Nat_packet.t) stream
and from_clients_to_server_stream = (Vif.t * Nat_packet.t) stream
and from_server_to_clients_stream = Nat_packet.t stream

module Nat = struct
let fail_to_parse ~protocol ~payload =
Expand Down Expand Up @@ -97,18 +104,24 @@ struct

let local_network a b = Ipaddr.V4.compare a b = 0

let should_be_routed ipaddr hdr =
local_network ipaddr hdr.Ipv4_packet.src
&& not (local_network ipaddr hdr.Ipv4_packet.dst)

let for_dns (dns0, dns1) hdr =
Ipaddr.V4.compare dns0 hdr.Ipv4_packet.dst = 0
|| Ipaddr.V4.compare dns1 hdr.Ipv4_packet.dst = 0

let add_vif ~finalisers t ({ Dao.Client_vif.domid; device_id } as client_vif)
ipaddr () =
let open Lwt.Infix in
let* backend = Vif.Netbackend.make ~domid ~device_id in
let ic_fragments = ref (Fragments.Cache.empty (256 * 1024)) in
let dns_fragments = ref (Fragments.Cache.empty (256 * 1024)) in
let ic = Lwt_stream.create () in
let gateway = Clients.default_gateway t.clients in
let* vif = Vif.make backend client_vif ~gateway ipaddr in
let* () = Clients.add_client t.clients vif in
let should_be_routed hdr =
local_network ipaddr hdr.Ipv4_packet.src
&& not (local_network ipaddr hdr.Ipv4_packet.dst) in
Finaliser.add
~finaliser:(fun () -> Clients.rem_client t.clients vif)
finalisers;
Expand All @@ -119,7 +132,15 @@ struct
match Ipv4_packet.Unmarshal.of_cstruct payload with
| Error msg ->
Logs.err (fun m -> m "Couldn't decode IPv4 packet %s: %a" msg Cstruct.hexdump_pp payload)
| Ok (hdr, payload) when should_be_routed hdr ->
| Ok (hdr, payload) when for_dns (fst t.dns) hdr ->
Logs.debug (fun m -> m "Handle DNS packet");
let now = M.elapsed_ns () in
let fragments, packet = Fragments.process !dns_fragments now hdr payload in
let packet = Option.bind packet (fun (hdr, payload) -> Nat.of_ipv4 hdr payload) in
let packet = Option.map (fun packet -> (vif, packet)) packet in
dns_fragments := fragments;
Fun.flip Option.iter packet (snd (snd t.dns) % Option.some)
| Ok (hdr, payload) when should_be_routed ipaddr hdr ->
let now = M.elapsed_ns () in
let fragments, packet = Fragments.process !ic_fragments now hdr payload in
let packet = Option.bind packet (fun (hdr, payload) -> Nat.of_ipv4 hdr payload) in
Expand Down Expand Up @@ -231,6 +252,11 @@ struct
t.oc_fragments <- fragments;
ovpn_loop t

let rec dns_loop t =
(* TODO(dinosaure): something which read clear IP packets on some (?) ports/addresses. *)
let* () = Lwt.pause () in
dns_loop t

let output_tunnel t vif packet =
match Nat_packet.to_cstruct ~mtu:(O.mtu t.ovpn - Ipv4_wire.sizeof_ipv4) packet with
| Ok pkts ->
Expand Down Expand Up @@ -271,6 +297,42 @@ struct
(* TODO(dinosaure): should report ICMP error message to src. *)
ingest_private t end

let output_clear t vif packet =
match Nat_packet.to_cstruct (* mtu front-end *) packet with
| Ok pkts ->
Logs.debug (fun m -> m "Output DNS packet to front-end");
let fn pkt = Logs.debug (fun m -> m "@[<hov>%a@]" (Hxd_string.pp Hxd.default) (Cstruct.to_string pkt)) in
List.iter fn pkts;
(* TODO(dinosaure): outputs to [vif0]! *)
Lwt.return_unit
| Error err ->
Logs.err (fun m -> m "Nat_packet.to_cstruct failed for clear packets: %a" Nat_packet.pp_error err);
Lwt.return_unit

let rec ingest_dns ~xl_host t =
let* packet = Lwt_stream.get (fst (snd t.dns)) in
let vif, packet = Option.get packet in
match Mirage_nat_lru.translate t.table packet with
| Ok packet -> let* () = output_clear t vif packet in ingest_dns ~xl_host t
| Error `TTL_exceeded ->
Logs.warn (fun m -> m "TTL exceeded for DNS packets");
ingest_dns ~xl_host t
| Error `Untranslated ->
begin match Mirage_nat_lru.add t.table packet xl_host
(fun () -> Some (Randomconv.int16 R.generate)) `NAT with
| Error err ->
Logs.debug (fun m -> m "Failed to add a NAT rule for DNS packets: %a" Mirage_nat.pp_error err);
ingest_dns ~xl_host t
| Ok () -> match Mirage_nat_lru.translate t.table packet with
| Ok packet -> let* () = output_clear t vif packet in ingest_dns ~xl_host t
| Error `Untranslated ->
Logs.warn (fun m -> m "Can't translate DNS packet, giving up");
ingest_private t
| Error `TTL_exceeded ->
Logs.warn (fun m -> m "TTL exceeded for DNS packets");
(* TODO(dinosaure): should report ICMP error message to src. *)
ingest_dns ~xl_host t end

let openvpn_configuration disk config_key =
let* contents = KV.get disk (Mirage_kv.Key.v config_key) in
match contents with
Expand All @@ -284,6 +346,7 @@ struct
| Error _ -> Fmt.failwith "Invalid OpenVPN configuration")

let start _random _mclock _pclock _time qubesDB vif0 disk config_key =
Logs.set_level ~all:true (Some Logs.Debug);
Logs.debug (fun m -> m "Start the unikernel");
let shutdown =
let* value = Xen_os.Lifecycle.await_shutdown_request () in
Expand All @@ -309,7 +372,16 @@ struct
; oc_fragments= Fragments.Cache.empty (256 * 1024)
; oc= Lwt_stream.create ()
; ic= Lwt_stream.create ()
; dns= cfg.Dao.dns, Lwt_stream.create ()
; vif0
; clients } in
let* () = Lwt.pick [ shutdown; wait_clients t; ovpn_loop t; ingest_private t; packets_to_clients t ] in
let* () = Lwt.pick
[ shutdown
; wait_clients t
; ovpn_loop t
; ingest_private t
; packets_to_clients t
; dns_loop t
; ingest_dns ~xl_host:cfg.Dao.ip t ] in
S.disconnect vif0
end
Loading