Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-06-28 23:22:26 +00:00
Code Issues Packages Projects Releases Wiki Activity

update to ocaml-dns 6.0.0 interface

Browse Source
This commit is contained in:
palainp 2021-10-28 13:39:32 +02:00
parent 6080e6db30
commit 4cb5cfa036
4 changed files with 11 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
client_net.mli
View File

@ -4,7 +4,7 @@
(** Handling client VMs. *) (** Handling client VMs. *)
val listen : (unit -> int64) -> val listen : (unit -> int64) ->
([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) -> ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) ->
Qubes.DB.t -> Router.t -> 'a Lwt.t Qubes.DB.t -> Router.t -> 'a Lwt.t
(** [listen get_timestamp resolver db router] is a thread that watches for clients being added to and (** [listen get_timestamp resolver db router] is a thread that watches for clients being added to and
removed from XenStore. Clients are connected to the client network and removed from XenStore. Clients are connected to the client network and

2
firewall.mli
View File

@ -7,7 +7,7 @@ val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t
(** Handle a packet from the outside world (this module will validate the source IP). *) (** Handle a packet from the outside world (this module will validate the source IP). *)
(* TODO the function type is a workaround, rework the module dependencies / functors to get rid of it *) (* TODO the function type is a workaround, rework the module dependencies / functors to get rid of it *)
val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Dns.Rr_map.Ipv4_set.t, [> `Msg of string ]) result Lwt.t) -> val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) ->
Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t
(** Handle a packet from a client. Caller must check the source IP matches the client's (** Handle a packet from a client. Caller must check the source IP matches the client's
before calling this. *) before calling this. *)

15
my_dns.ml
View File

@ -3,22 +3,22 @@ open Lwt.Infix
module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
type +'a io = 'a Lwt.t type +'a io = 'a Lwt.t
type io_addr = Ipaddr.V4.t * int type io_addr = Ipaddr.V4.t * int
type ns_addr = [ `TCP | `UDP ] * io_addr type ns_addr = Dns.proto * io_addr list
type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t
type t = { type t = {
nameserver : ns_addr ; nameservers : ns_addr ;
stack : stack ; stack : stack ;
timeout_ns : int64 ; timeout_ns : int64 ;
} }
type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int } type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int }
let nameserver t = t.nameserver let nameservers t = t.nameservers
let rng = R.generate ?g:None let rng = R.generate ?g:None
let clock = C.elapsed_ns let clock = C.elapsed_ns
let create ?(nameserver = `UDP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) ~timeout stack = let create ?(nameservers = `Udp, [(Ipaddr.V4.of_string_exn "91.239.100.100", 53)]) ~timeout stack =
{ nameserver ; stack ; timeout_ns = timeout } { nameservers ; stack ; timeout_ns = timeout }
let with_timeout ctx f = let with_timeout ctx f =
let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in let timeout = OS.Time.sleep_ns !(ctx.timeout_ns) >|= fun () -> Error (`Msg "DNS request timeout") in
@ -28,12 +28,13 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start); ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start);
result result
let connect ?nameserver:_ (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 }) let connect (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 })
let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t = let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t =
let open Router in let open Router in
let open My_nat in let open My_nat in
let dst, dst_port = snd ctx.t.nameserver in let nslist = snd ctx.t.nameservers in
let dst, dst_port = List.hd(nslist) in
let router, send_udp, _ = ctx.t.stack in let router, send_udp, _ = ctx.t.stack in
let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
ctx.src_port <- src_port; ctx.src_port <- src_port;

2
rules.ml
View File

@ -59,7 +59,7 @@ module Classifier = struct
Log.debug (fun f -> f "Resolving %a" Domain_name.pp name); Log.debug (fun f -> f "Resolving %a" Domain_name.pp name);
dns_client name >|= function dns_client name >|= function
| Ok (_ttl, found_ips) -> | Ok (_ttl, found_ips) ->
if Dns.Rr_map.Ipv4_set.mem ip found_ips if Ipaddr.V4.Set.mem ip found_ips
then `Match rule then `Match rule
else `No_match else `No_match
| Error (`Msg m) -> | Error (`Msg m) ->