2020-04-29 10:06:48 -04:00
|
|
|
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 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 = {
|
2021-11-10 09:26:17 -05:00
|
|
|
protocol : Dns.proto ;
|
|
|
|
nameserver : io_addr ;
|
2020-04-29 10:06:48 -04:00
|
|
|
stack : stack ;
|
|
|
|
timeout_ns : int64 ;
|
|
|
|
}
|
2021-11-10 12:16:55 -05:00
|
|
|
type context = t
|
2020-04-29 10:06:48 -04:00
|
|
|
|
2021-11-10 09:26:17 -05:00
|
|
|
let nameservers { protocol ; nameserver ; _ } = protocol, [ nameserver ]
|
2020-04-29 10:06:48 -04:00
|
|
|
let rng = R.generate ?g:None
|
|
|
|
let clock = C.elapsed_ns
|
|
|
|
|
2021-11-10 09:26:17 -05:00
|
|
|
let create ?nameservers ~timeout stack =
|
|
|
|
let protocol, nameserver = match nameservers with
|
|
|
|
| None | Some (_, []) -> invalid_arg "no nameserver found"
|
|
|
|
| Some (proto, ns :: _) -> proto, ns
|
|
|
|
in
|
|
|
|
{ protocol ; nameserver ; stack ; timeout_ns = timeout }
|
2020-04-29 10:06:48 -04:00
|
|
|
|
2021-11-10 12:16:55 -05:00
|
|
|
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 ]
|
2020-04-29 10:06:48 -04:00
|
|
|
|
2021-11-10 12:16:55 -05:00
|
|
|
let connect (t : t) = Lwt.return (Ok t)
|
2020-04-29 10:06:48 -04:00
|
|
|
|
2021-11-10 12:16:55 -05:00
|
|
|
let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t =
|
2020-04-29 10:06:48 -04:00
|
|
|
let open Router in
|
|
|
|
let open My_nat in
|
2021-11-10 12:16:55 -05:00
|
|
|
let dst, dst_port = ctx.nameserver in
|
|
|
|
let router, send_udp, answer = ctx.stack in
|
2020-04-29 10:06:48 -04:00
|
|
|
let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in
|
2021-11-10 12:16:55 -05:00
|
|
|
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);
|
2020-04-29 10:06:48 -04:00
|
|
|
result
|
|
|
|
|
|
|
|
let close _ = Lwt.return_unit
|
|
|
|
|
|
|
|
let bind = Lwt.bind
|
|
|
|
|
|
|
|
let lift = Lwt.return
|
|
|
|
end
|
|
|
|
|