Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-06-26 14:12:23 +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. *)
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
(** [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

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). *)
(* 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
(** Handle a packet from a client. Caller must check the source IP matches the client's
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
type +'a io = 'a Lwt.t
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 t = {
nameserver : ns_addr ;
nameservers : ns_addr ;
stack : stack ;
timeout_ns : int64 ;
}
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 clock = C.elapsed_ns
let create ?(nameserver = `UDP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) ~timeout stack =
{ nameserver ; stack ; timeout_ns = timeout }
let create ?(nameservers = `Udp, [(Ipaddr.V4.of_string_exn "91.239.100.100", 53)]) ~timeout stack =
{ nameservers ; stack ; timeout_ns = timeout }
let with_timeout ctx f =
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);
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 open Router 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 src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
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);
dns_client name >|= function
| 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
else `No_match
| Error (`Msg m) ->