Git-Mirrors/qubes-mirage-firewall
1
0
Fork 0
mirror of https://github.com/mirage/qubes-mirage-firewall.git synced 2024-12-29 00:56:13 -05:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #136 from hannesm/fixes

Browse Source 
update to dns 6.1.0
This commit is contained in:
Hannes Mehnert 2021-11-12 12:29:21 +01:00 committed by GitHub
commit 1d0aaf2666
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
4 changed files with 16 additions and 25 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
build-with-docker.sh
View File

@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall .
echo Building Firewall...
docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall
echo "SHA2 of build: $(sha256sum qubes_firewall.xen)"
echo "SHA2 last known: 14cc59ec7c3754f83f7422d48176bc0eb8e47d3c3ef116ae09619409b590d3cb"
echo "SHA2 last known: 4f4b21a8f9d131486700f8be9bd15067878907313b2ebc7a048c27af8a918e1e"
echo "(hashes should match for released versions)"

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