Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-09-28 19:55:39 +00:00
Code Issues Packages Projects Releases Wiki Activity

update to dns 6.1.0

Browse Source
This commit is contained in:
Hannes Mehnert 2021-11-10 18:16:55 +01:00
parent 07c2d456ea
commit 748f803ca0
3 changed files with 15 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Dockerfile
View File

@ -7,7 +7,7 @@ FROM ocurrent/opam@sha256:fce44a073ff874166b51c33a4e37782286d48dbba1b5aa43563a0d
# Pin last known-good version for reproducible builds.
# Remove this line (and the base image pin above) if you want to test with the
# latest versions.
RUN cd ~/opam-repository && git fetch origin master && git reset --hard 87ef72b5cd492573258eb1b6f3b30c88af31ae3f && opam update
RUN cd ~/opam-repository && git fetch origin master && git reset --hard 295910defa4dedc27af45ca64d63e8927f8261ff && opam update
RUN opam depext -i -y mirage
RUN mkdir /home/opam/qubes-mirage-firewall

2
config.ml
View File

@ -33,7 +33,7 @@ let main =
package "mirage-nat" ~min:"2.2.1";
package "mirage-logs";
package "mirage-xen" ~min:"6.0.0";
package ~min:"6.0.0" "dns-client";
package ~min:"6.1.0" "dns-client";
package "pf-qubes";
]
"Unikernel.Main" (random @-> mclock @-> job)

35
my_dns.ml
View File

@ -11,7 +11,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
stack : stack ;
timeout_ns : int64 ;
}
type context = { t : t ; timeout_ns : int64 ref; mutable src_port : int }
type context = t
let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ]
let rng = R.generate ?g:None
@ -24,32 +24,23 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) = struct
in
{ protocol ; nameserver ; 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
let start = clock () in
Lwt.pick [ f ; timeout ] >|= fun result ->
let stop = clock () in
ctx.timeout_ns := Int64.sub !(ctx.timeout_ns) (Int64.sub stop start);
result
let with_timeout timeout_ns f =
let timeout = OS.Time.sleep_ns timeout_ns >|= fun () -> Error (`Msg "DNS request timeout") in
Lwt.pick [ f ; timeout ]
let connect (t : t) = Lwt.return (Ok { t ; timeout_ns = ref t.timeout_ns ; src_port = 0 })
let connect (t : t) = Lwt.return (Ok t)
let send (ctx : context) buf : (unit, [> `Msg of string ]) result Lwt.t =
let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t =
let open Router in
let open My_nat in
let dst, dst_port = ctx.t.nameserver in
let router, send_udp, _ = ctx.t.stack in
let dst, dst_port = ctx.nameserver in
let router, send_udp, answer = ctx.stack in
let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
ctx.src_port <- src_port;
with_timeout ctx (send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg)
let recv ctx =
let open Router in
let open My_nat in
let router, _, answers = ctx.t.stack in
with_timeout ctx
(Lwt_mvar.take answers >|= fun (_, dns_response) -> Ok dns_response) >|= fun result ->
router.ports.dns_udp := Ports.remove ctx.src_port !(router.ports.dns_udp);
with_timeout ctx.timeout_ns
((send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) >>= function
| Ok () -> (Lwt_mvar.take answer >|= fun (_, dns_response) -> Ok dns_response)
| Error _ as e -> Lwt.return e) >|= fun result ->
router.ports.dns_udp := Ports.remove src_port !(router.ports.dns_udp);
result
let close _ = Lwt.return_unit