swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

111
unikernel/duniverse/ocaml-dns/mirage/certify/dns_certify_mirage.ml Normal file
View file

@ -0,0 +1,111 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let src = Logs.Src.create "dns_certify_mirage" ~doc:"effectful DNS certify"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (S : Tcpip.Stack.V4V6) = struct
module D = Dns_mirage.Make(S)
let nsupdate_csr flow host keyname zone dnskey csr =
match
Dns_certify.nsupdate Mirage_crypto_rng.generate Mirage_ptime.now
~host ~keyname ~zone dnskey csr
with
| Error s -> Lwt.return (Error s)
| Ok (out, cb) ->
D.send_tcp (D.flow flow) (Cstruct.of_string out) >>= function
| Error () -> Lwt.return (Error (`Msg "tcp sending error"))
| Ok () -> D.read_tcp flow >|= function
| Error () -> Error (`Msg "tcp receive err")
| Ok data -> match cb (Cstruct.to_string data) with
| Error e -> Error (`Msg (Fmt.str "nsupdate reply error %a" Dns_certify.pp_u_err e))
| Ok () -> Ok ()
let query_certificate flow name csr =
match Dns_certify.query Mirage_crypto_rng.generate (Mirage_ptime.now ()) name csr with
| Error e -> Lwt.return (Error e)
| Ok (out, cb) ->
D.send_tcp (D.flow flow) (Cstruct.of_string out) >>= function
| Error () -> Lwt.return (Error (`Msg "couldn't send tcp"))
| Ok () ->
D.read_tcp flow >|= function
| Error () -> Error (`Msg "error while reading answer")
| Ok data -> match cb (Cstruct.to_string data) with
| Error e -> Error e
| Ok cert -> Ok cert
let query_certificate_or_csr flow hostname keyname zone dnskey csr =
query_certificate flow hostname csr >>= function
| Ok certificate ->
Log.info (fun m -> m "found certificate in DNS") ;
Lwt.return (Ok certificate)
| Error (`Msg msg) ->
Log.err (fun m -> m "error %s" msg) ;
Lwt.return (Error (`Msg msg))
| Error ((`Decode _ | `Bad_reply _ | `Unexpected_reply _) as e) ->
Log.err (fun m -> m "query error %a, giving up" Dns_certify.pp_q_err e);
Lwt.return (Error (`Msg "query error"))
| Error `No_tlsa ->
Log.info (fun m -> m "no certificate in DNS, need to transmit the CSR") ;
nsupdate_csr flow hostname keyname zone dnskey csr >>= function
| Error (`Msg msg) ->
Log.err (fun m -> m "failed to nsupdate TLSA %s" msg) ;
Lwt.fail_with "nsupdate issue"
| Ok () ->
let rec wait_for_cert ?(retry = 10) () =
if retry = 0 then
Lwt.return (Error (`Msg "too many retries, giving up"))
else
query_certificate flow hostname csr >>= function
| Ok certificate ->
Log.info (fun m -> m "finally found a certificate") ;
Lwt.return (Ok certificate)
| Error (`Msg msg) ->
Log.err (fun m -> m "error while querying certificate %s" msg) ;
Lwt.return (Error (`Msg msg))
| Error (#Dns_certify.q_err as q) ->
Log.info (fun m -> m "still waiting for certificate, got error %a" Dns_certify.pp_q_err q) ;
Mirage_sleep.ns (Duration.of_sec 2) >>= fun () ->
wait_for_cert ~retry:(pred retry) ()
in
wait_for_cert ()
let retrieve_certificate stack (dns_key_name, dns_key) ~hostname ?(additional_hostnames = []) ?(key_type = `RSA) ?key_data ?key_seed ?bits dns port =
let zone = Domain_name.(host_exn (drop_label_exn ~amount:2 dns_key_name)) in
let not_sub subdomain = not (Domain_name.is_subdomain ~subdomain ~domain:zone) in
if not_sub hostname then
invalid_arg "hostname not a subdomain of zone provided by dns_key"
else
let key =
let seed_or_data, data = match key_data, key_seed with
| None, None -> invalid_arg "neither key_data nor key_seed is supplied"
| Some data, _ -> Some `Data, data
| None, Some seed -> Some `Seed, seed
in
Result.fold
~ok:Fun.id
~error:(function `Msg msg -> invalid_arg ("key generation failed: " ^ msg))
(X509.Private_key.of_string ?seed_or_data ?bits key_type data)
in
match
let more_hostnames = additional_hostnames in
Dns_certify.signing_request hostname ~more_hostnames key
with
| Error (`Msg m) -> invalid_arg ("create signing request failed: " ^ m)
| Ok csr ->
S.TCP.create_connection (S.tcp stack) (dns, port) >>= function
| Error e ->
Log.err (fun m -> m "error %a while connecting to name server"
S.TCP.pp_error e);
Lwt.return (Error (`Msg "couldn't connect to name server"))
| Ok flow ->
let flow = D.of_flow flow in
query_certificate_or_csr flow hostname dns_key_name zone dns_key csr >>= fun certificate ->
S.TCP.close (D.flow flow) >|= fun () ->
match certificate with
| Error e -> Error e
| Ok (cert, chain) -> Ok (cert :: chain, key)
end

21
unikernel/duniverse/ocaml-dns/mirage/certify/dns_certify_mirage.mli Normal file
View file

@ -0,0 +1,21 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
module Make (S : Tcpip.Stack.V4V6) : sig
val retrieve_certificate :
S.t -> ([`raw ] Domain_name.t * Dns.Dnskey.t) ->
hostname:[ `host ] Domain_name.t ->
?additional_hostnames:[ `raw ] Domain_name.t list ->
?key_type:X509.Key_type.t -> ?key_data:string -> ?key_seed:string ->
?bits:int -> S.TCP.ipaddr -> int ->
(X509.Certificate.t list * X509.Private_key.t, [ `Msg of string ]) result Lwt.t
(** [retrieve_certificate stack dns_key ~hostname ~key_type ~key_data ~key_seed ~bits server_ip port]
generates a private key (using [key_type], [key_data], [key_seed], and
[bits]), a certificate signing request for the given [hostname] and
[additional_hostnames], and sends [server_ip] an nsupdate (DNS-TSIG with
[dns_key]) with the csr as TLSA record, awaiting for a matching
certificate as TLSA record. Requires a service that interacts with let's
encrypt to transform the CSR into a signed certificate. If something
fails, an exception (via [Lwt.fail]) is raised. This is meant for
unikernels that require a valid TLS certificate before they can start
their service (i.e. most web servers, mail servers). *)
end

5
unikernel/duniverse/ocaml-dns/mirage/certify/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name dns_certify_mirage)
(public_name dns-certify.mirage)
(wrapped false)
(libraries dns dns-mirage dns-certify mirage-crypto-rng mirage-crypto-pk lwt duration mirage-sleep mirage-ptime tcpip))

482
unikernel/duniverse/ocaml-dns/mirage/client/dns_client_mirage.ml Normal file
View file

@ -0,0 +1,482 @@
open Lwt.Infix
let src = Logs.Src.create "dns_client_mirage" ~doc:"effectful DNS client layer"
module Log = (val Logs.src_log src : Logs.LOG)
module IM = Map.Make(Int)
module type S = sig
type happy_eyeballs
module Transport :
sig
include Dns_client.S
with type +'a io = 'a Lwt.t
and type io_addr = [
| `Plaintext of Ipaddr.t * int
| `Tls of Tls.Config.client * Ipaddr.t * int
]
val happy_eyeballs : t -> happy_eyeballs
end
include module type of Dns_client.Make(Transport)
val nameserver_of_string : string ->
(Dns.proto * Transport.io_addr, [> `Msg of string ]) result
val connect :
?cache_size:int ->
?edns:[ `None | `Auto | `Manual of Dns.Edns.t ] ->
?nameservers:string list ->
?timeout:int64 -> Transport.stack ->
t Lwt.t
end
module Make
(S : Tcpip.Stack.V4V6)
(H : Happy_eyeballs_mirage.S with type stack = S.t
and type flow = S.TCP.flow) = struct
type happy_eyeballs = H.t
module TLS = Tls_mirage.Make(S.TCP)
let auth_err = match X509.Authenticator.of_string "" with
| Ok _ -> "should not happen"
| Error `Msg m -> m
let format = {|
The format of an IP address and optional port is:
- '[::1]:port' for an IPv6 address, or
- '127.0.0.1:port' for an IPv4 address.
The format of a nameserver is:
- 'udp:IP' where the first element is the string "udp" and the [IP] as described
above (port defaults to 53): UDP packets to the provided IP address will be
sent from a random source port;
- 'tcp:IP' where the first element is the string "tcp" and the [IP] as described
above (port defaults to 53): a TCP connection to the provided IP address will
be established;
- 'tls:IP' where the first element is the string "tls", the [IP] as described
above (port defaults to 853): a TCP connection will be established, on top of
which a TLS handshake with the authenticator
(https://github.com/mirage/ca-certs-nss) will be done (which checks for the
IP address being in the certificate as SubjectAlternativeName);
- 'tls:IP!hostname' where the first element is the string "tls",
the [IP] as described above (port defaults to 853), the [hostname] a host name
used for the TLS authentication: a TCP connection will be established, on top
of which a TLS handshake with the authenticator
(https://github.com/mirage/ca-certs-nss) will be done;
- 'tls:IP!hostname!authenticator' where the first element is the string "tls",
the [IP] as described above (port defaults to 853), the [hostname] a host name
used for the TLS authentication, and the [authenticator] an X509
authenticator: a TCP connection will be established, on top of which a TLS
handshake with the authenticator will be done.
|} ^ auth_err
let nameserver_of_string str =
let ( let* ) = Result.bind in
begin match String.split_on_char ':' str with
| "tls" :: rest ->
let str = String.concat ":" rest in
( match String.split_on_char '!' str with
| [ nameserver ] ->
let* ipaddr, port = Ipaddr.with_port_of_string ~default:853 nameserver in
let* authenticator = Ca_certs_nss.authenticator () in
let* tls = Tls.Config.client ~authenticator () in
Ok (`Tcp, `Tls (tls, ipaddr, port))
| nameserver :: opt_hostname :: authenticator ->
let* ipaddr, port = Ipaddr.with_port_of_string ~default:853 nameserver in
let peer_name, data =
match
let* dn = Domain_name.of_string opt_hostname in
Domain_name.host dn
with
| Ok hostname -> Some hostname, String.concat "!" authenticator
| Error _ -> None, String.concat "!" (opt_hostname :: authenticator)
in
let* authenticator =
if data = "" then
Ca_certs_nss.authenticator ()
else
let* a = X509.Authenticator.of_string data in
Ok (a (fun () -> Some (Mirage_ptime.now ())))
in
let* tls = Tls.Config.client ~authenticator ?peer_name () in
Ok (`Tcp, `Tls (tls, ipaddr, port))
| [] -> assert false )
| "tcp" :: nameserver ->
let str = String.concat ":" nameserver in
let* ipaddr, port = Ipaddr.with_port_of_string ~default:53 str in
Ok (`Tcp, `Plaintext (ipaddr, port))
| "udp" :: nameserver ->
let str = String.concat ":" nameserver in
let* ipaddr, port = Ipaddr.with_port_of_string ~default:53 str in
Ok (`Udp, `Plaintext (ipaddr, port))
| _ ->
Error (`Msg ("Unable to decode nameserver " ^ str))
end |> Result.map_error (function `Msg e -> `Msg (e ^ format))
module Transport :
sig
include Dns_client.S
with type stack = S.t * happy_eyeballs
and type +'a io = 'a Lwt.t
and type io_addr = [
| `Plaintext of Ipaddr.t * int
| `Tls of Tls.Config.client * Ipaddr.t * int
]
val happy_eyeballs : t -> happy_eyeballs
end = struct
type stack = S.t * happy_eyeballs
type io_addr = [
| `Plaintext of Ipaddr.t * int
| `Tls of Tls.Config.client * Ipaddr.t * int
]
type +'a io = 'a Lwt.t
module IS = Set.Make(Int)
type t = {
nameservers : io_addr list ;
proto : Dns.proto ;
timeout_ns : int64 ;
stack : S.t ;
mutable udp_ports : IS.t ;
mutable flow : [`Plain of S.TCP.flow | `Tls of TLS.flow ] option ;
mutable connected_condition : (unit, [ `Msg of string ]) result Lwt_condition.t option ;
mutable requests : (Cstruct.t * (Cstruct.t, [ `Msg of string ]) result Lwt_condition.t) IM.t ;
he : H.t ;
}
type context = t
let clock = Mirage_mtime.elapsed_ns
let happy_eyeballs { he ; _ } = he
let read_udp t ip ip_us ~src ~dst ~src_port:_ data =
if Ipaddr.compare ip_us dst = 0 && Ipaddr.compare ip src = 0 &&
Cstruct.length data > 12 (* minimum DNS length (header length) *)
then
(let id = Cstruct.BE.get_uint16 data 0 in
(match IM.find_opt id t.requests with
| None -> Log.warn (fun m -> m "received unsolicited data, ignoring")
| Some (_, cond) -> Lwt_condition.broadcast cond (Ok data)));
Lwt.return_unit
let generate_udp_port t =
let rec go retries =
if retries = 0 then
Error (`Msg "couldn't find a free UDP port")
else
let port = 1024 + ((String.get_uint16_be (Mirage_crypto_rng.generate 2) 0) mod (65536 - 1024)) in
if IS.mem port t.udp_ports then
go (retries - 1)
else
(t.udp_ports <- IS.add port t.udp_ports;
Ok port)
in
go 32
let create ?nameservers ~timeout (stack, he) =
let proto, nameservers = match nameservers with
| None ->
let authenticator = match Ca_certs_nss.authenticator () with
| Ok a -> a
| Error `Msg m -> invalid_arg ("bad CA certificates " ^ m)
in
let tls_cfg =
let peer_name = Dns_client.default_resolver_hostname in
match Tls.Config.client ~authenticator ~peer_name () with
| Ok a -> a
| Error `Msg m -> invalid_arg ("invalid TLS configuration: " ^ m)
in
let ns =
List.map (fun ip -> `Tls (tls_cfg, ip, 853))
Dns_client.default_resolvers
in
`Tcp, ns
| Some (a, ns) -> a, ns
in
{
nameservers ;
proto ;
timeout_ns = timeout ;
stack ;
udp_ports = IS.empty ;
flow = None ;
connected_condition = None ;
requests = IM.empty ;
he ;
}
let nameservers { proto ; nameservers ; _ } = proto, nameservers
let rng n = Mirage_crypto_rng.generate ?g:None n
let with_timeout time_left f =
let timeout =
Mirage_sleep.ns time_left >|= fun () ->
Error (`Msg "DNS request timeout")
in
Lwt.pick [ f ; timeout ]
let bind = Lwt.bind
let lift = Lwt.return
let rec read_loop ?(linger = Cstruct.empty) t flow =
let process cs =
let rec handle_data data =
let cs_len = Cstruct.length data in
if cs_len > 2 then
let len = Cstruct.BE.get_uint16 data 0 in
if cs_len - 2 >= len then
let packet, rest =
if cs_len - 2 = len
then data, Cstruct.empty
else Cstruct.split data (len + 2)
in
let id = Cstruct.BE.get_uint16 packet 2 in
(match IM.find_opt id t.requests with
| None -> Log.warn (fun m -> m "received unsolicited data, ignoring")
| Some (_, cond) -> Lwt_condition.broadcast cond (Ok packet));
handle_data rest
else
read_loop ~linger:data t flow
else
read_loop ~linger:data t flow
in
handle_data (if Cstruct.length linger = 0 then cs else Cstruct.append linger cs)
in
match flow with
| `Plain flow ->
begin
S.TCP.read flow >>= function
| Error e ->
t.flow <- None;
Log.err (fun m -> m "error %a reading from resolver" S.TCP.pp_error e);
Lwt.return_unit
| Ok `Eof ->
t.flow <- None;
if not (IM.is_empty t.requests) then
Log.info (fun m -> m "end of file reading from resolver");
Lwt.return_unit
| Ok (`Data cs) ->
process cs
end
| `Tls flow ->
begin
TLS.read flow >>= function
| Error e ->
t.flow <- None;
Log.err (fun m -> m "error %a reading from resolver" TLS.pp_error e);
Lwt.return_unit
| Ok `Eof ->
t.flow <- None;
if not (IM.is_empty t.requests) then
Log.info (fun m -> m "end of file reading from resolver");
Lwt.return_unit
| Ok (`Data cs) ->
process cs
end
let query_one flow data =
match flow with
| `Plain flow ->
begin
S.TCP.write flow data >>= function
| Error e ->
Lwt.return (Error (`Msg (Fmt.to_to_string S.TCP.pp_write_error e)))
| Ok () -> Lwt.return (Ok ())
end
| `Tls flow ->
begin
TLS.write flow data >>= function
| Error e ->
Lwt.return (Error (`Msg (Fmt.to_to_string TLS.pp_write_error e)))
| Ok () -> Lwt.return (Ok ())
end
let req_all flow t =
IM.fold (fun _id (data, _) r ->
r >>= function
| Error _ as e -> Lwt.return e
| Ok () -> query_one flow data)
t.requests (Lwt.return (Ok ()))
let to_pairs =
List.map (function `Plaintext (ip, port)
| `Tls (_, ip, port) -> (ip, port))
let find_ns ns (addr, port) =
List.find (function `Plaintext (ip, p) | `Tls (_, ip, p) ->
Ipaddr.compare ip addr = 0 && p = port)
ns
let rec connect_ns t nameservers =
let connected_condition = Lwt_condition.create () in
t.connected_condition <- Some connected_condition ;
let ns = to_pairs nameservers in
(* The connect_timeout given here is a bit too much, since it should
be (a) connect to the remote NS (b) send query, receive answer.
At the moment, how this is done, is that we use the connect_timeout
for (a) and another separate one for (b). Since we do connection
pooling, it is slightly tricky to use only a single connect_timeout. *)
H.connect_ip ~connect_timeout:t.timeout_ns t.he ns >>= function
| Error `Msg msg ->
let err = Error (`Msg (Fmt.str "error %s connecting to resolver %a"
msg
Fmt.(list ~sep:(any ", ") (pair ~sep:(any ":") Ipaddr.pp int))
(to_pairs t.nameservers)))
in
Lwt_condition.broadcast connected_condition err;
t.connected_condition <- None;
Log.err (fun m -> m "error connecting to resolver %s" msg);
Lwt.return err
| Ok (addr, flow) ->
let continue flow =
t.flow <- Some flow;
Lwt.async (fun () ->
read_loop t flow >>= fun () ->
if not (IM.is_empty t.requests) then
connect_ns t t.nameservers >|= function
| Error `Msg msg ->
Log.err (fun m -> m "error while connecting to resolver: %s" msg)
| Ok () -> ()
else
Lwt.return_unit);
Lwt_condition.broadcast connected_condition (Ok ());
t.connected_condition <- None;
req_all flow t
in
let config = find_ns t.nameservers addr in
match config with
| `Plaintext _ -> continue (`Plain flow)
| `Tls (tls_cfg, _ip, _port) ->
TLS.client_of_flow tls_cfg flow >>= function
| Ok tls -> continue (`Tls tls)
| Error e ->
Log.warn (fun m -> m "error establishing TLS connection to %a:%d: %a"
Ipaddr.pp (fst addr) (snd addr) TLS.pp_write_error e);
let ns' =
List.filter (function
| `Tls (_, ip, port) ->
not (Ipaddr.compare ip (fst addr) = 0 && port = snd addr)
| _ -> true)
nameservers
in
if ns' = [] then begin
let err = Error (`Msg "no further nameservers configured") in
Lwt_condition.broadcast connected_condition err;
t.connected_condition <- None;
Lwt.return err
end else
connect_ns t ns'
let connect t =
let to_tcp = function
| Ok () -> Ok (`Tcp, t)
| Error `Msg msg -> Error (`Msg msg)
in
match t.proto with
| `Udp -> Lwt.return (Ok (`Udp, t))
| `Tcp -> match t.flow, t.connected_condition with
| Some _, _ -> Lwt.return (Ok (`Tcp, t))
| None, Some w -> Lwt_condition.wait w >|= to_tcp
| None, None -> connect_ns t t.nameservers >|= to_tcp
let close _f =
(* ignoring this here *)
Lwt.return_unit
let send_recv t tx =
let ( >>>= ) = Lwt_result.bind in
if Cstruct.length tx > 4 then
match t.proto, t.flow with
| `Udp, _ ->
let dst, dst_port = match t.nameservers with
| `Plaintext (ip, port) :: _ -> ip, port
| _ -> assert false
in
let src = S.IP.src (S.ip t.stack) ~dst in
let id = Cstruct.BE.get_uint16 tx 0 in
Lwt.return (generate_udp_port t) >>>= fun udp_port ->
with_timeout t.timeout_ns
(S.UDP.listen (S.udp t.stack) ~port:udp_port (read_udp t dst src);
(S.UDP.write ~src_port:udp_port ~dst ~dst_port (S.udp t.stack) tx >|= function
| Error e -> Error (`Msg (Fmt.to_to_string S.UDP.pp_error e))
| Ok () -> Ok ()) >>>= fun () ->
let cond = Lwt_condition.create () in
t.requests <- IM.add id (tx, cond) t.requests;
let open Lwt.Infix in
Lwt_condition.wait cond >|= fun data ->
match data with Ok _ | Error `Msg _ as r -> r) >|= fun r ->
S.UDP.unlisten (S.udp t.stack) ~port:udp_port;
t.udp_ports <- IS.remove udp_port t.udp_ports;
t.requests <- IM.remove id t.requests;
r
| `Tcp, None -> Lwt.return (Error (`Msg "no connection to resolver"))
| `Tcp, Some flow ->
let id = Cstruct.BE.get_uint16 tx 2 in
with_timeout t.timeout_ns
(let open Lwt_result.Infix in
query_one flow tx >>= fun () ->
let cond = Lwt_condition.create () in
t.requests <- IM.add id (tx, cond) t.requests;
let open Lwt.Infix in
Lwt_condition.wait cond >|= fun data ->
match data with Ok _ | Error `Msg _ as r -> r) >|= fun r ->
t.requests <- IM.remove id t.requests;
r
else
Lwt.return (Error (`Msg "invalid context (data length <= 4)"))
let send_recv t tx =
Lwt_result.map Cstruct.to_string (send_recv t (Cstruct.of_string tx))
end
include Dns_client.Make(Transport)
let decode_nameservers ?(nameservers= []) () =
let nameservers =
List.map
(fun nameserver -> match nameserver_of_string nameserver with
| Ok nameserver -> nameserver
| Error (`Msg err) -> invalid_arg err)
nameservers
in
let tcp, udp =
List.fold_left (fun (tcp, udp) -> function
| `Tcp, a -> a :: tcp, udp
| `Udp, a -> tcp, a :: udp)
([], []) nameservers
in
match tcp, udp with
| [], [] -> None
| [], _::_ -> Some (`Udp, udp)
| _::_, [] -> Some (`Tcp, tcp)
| _::_, udps ->
let pp_io_addr ppf = function
|`Plaintext (ip, port) -> Fmt.pf ppf "%a:%u" Ipaddr.pp ip port
| `Tls (_, ip, port) -> Fmt.pf ppf "TLS: %a:%u" Ipaddr.pp ip port
in
Log.warn (fun m -> m "ignoring UDP nameservers %a, using TCP nameservers %a"
Fmt.(list ~sep:(any ", ") pp_io_addr) udps
Fmt.(list ~sep:(any ", ") pp_io_addr) tcp);
Some (`Tcp, tcp)
let connect ?cache_size ?edns ?nameservers ?timeout (stack, he) =
let nameservers = decode_nameservers ?nameservers () in
let t = create ?cache_size ?edns ?nameservers ?timeout (stack, he) in
let getaddrinfo record domain_name =
let open Lwt_result.Infix in
match record with
| `A ->
getaddrinfo t Dns.Rr_map.A domain_name >|= fun (_ttl, set) ->
Ipaddr.V4.Set.fold (fun ipv4 -> Ipaddr.Set.add (Ipaddr.V4 ipv4))
set Ipaddr.Set.empty
| `AAAA ->
getaddrinfo t Dns.Rr_map.Aaaa domain_name >|= fun (_ttl, set) ->
Ipaddr.V6.Set.fold (fun ipv6 -> Ipaddr.Set.add (Ipaddr.V6 ipv6))
set Ipaddr.Set.empty
in
H.inject (Transport.happy_eyeballs (transport t)) getaddrinfo;
Lwt.return t
end

59
unikernel/duniverse/ocaml-dns/mirage/client/dns_client_mirage.mli Normal file
View file

@ -0,0 +1,59 @@
module type S = sig
type happy_eyeballs
module Transport :
sig
include Dns_client.S
with type +'a io = 'a Lwt.t
and type io_addr = [
| `Plaintext of Ipaddr.t * int
| `Tls of Tls.Config.client * Ipaddr.t * int
]
val happy_eyeballs : t -> happy_eyeballs
end
include module type of Dns_client.Make(Transport)
val nameserver_of_string : string ->
(Dns.proto * Transport.io_addr, [> `Msg of string ]) result
(** [nameserver_of_string authenticators str] returns a {!Transport.io_addr}
from the given string. The format is:
- [udp:<ipaddr>(:port)?] for a plain nameserver and we will communicate
with it {i via} the UDP protocol
- [tcp:<ipaddr>(:port)?] for a plain nameserver and we will communicate
with it {i via} the TCP protocol
- [tls:<ipaddr>(:port)?((!hostname)?!authenticator)?] for a nameserver and
we will communicate with it {i via} the TCP protocol plus the TLS
encrypted layer. The user can verify the nameserver {i via} an
{i authenticator} (see {!X509.Authenticator.of_string} for the format
of it). The {i hostname} can be provided to be used as peer name by the
authenticator. By default, {!Ca_certs_nss.authenticator} is used.
*)
val connect :
?cache_size:int ->
?edns:[ `None | `Auto | `Manual of Dns.Edns.t ] ->
?nameservers:string list ->
?timeout:int64 ->
Transport.stack -> t Lwt.t
(** [connect ?cache_size ?edns ?nameservers ?timeout (stack, happy_eyeballs)]
creates a DNS entity which is able to resolve domain-name. It expects
few optional arguments:
- [cache_size] the size of the LRU cache,
- [edns] the behaviour of whether or not to send edns in queries,
- [nameservers] a list of {i nameservers} used to resolve domain-names,
- [timeout] (in nanoseconds), passed to {create}.
The provided [happy_eyeballs] will use [t] for resolving hostnames.
@raise [Invalid_argument] if given strings don't respect formats explained
by {!nameserver_of_string}.
*)
end
module Make
(S : Tcpip.Stack.V4V6)
(H : Happy_eyeballs_mirage.S with type stack = S.t
and type flow = S.TCP.flow)
: S with type Transport.stack = S.t * H.t
and type happy_eyeballs = H.t

5
unikernel/duniverse/ocaml-dns/mirage/client/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name dns_client_mirage)
(public_name dns-client-mirage)
(libraries domain-name ipaddr mirage-crypto-rng mirage-sleep tcpip mirage-ptime mirage-mtime dns-client happy-eyeballs happy-eyeballs-mirage tls-mirage ca-certs-nss)
(wrapped false))

85
unikernel/duniverse/ocaml-dns/mirage/dns_mirage.ml Normal file
View file

@ -0,0 +1,85 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let src = Logs.Src.create "dns_mirage" ~doc:"effectful DNS layer"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (S : Tcpip.Stack.V4V6) = struct
module IPM = struct
include Map.Make(struct
type t = Ipaddr.t * int
let compare (ip, p) (ip', p') = match Ipaddr.compare ip ip' with
| 0 -> compare p p'
| x -> x
end)
let find k t = try Some (find k t) with Not_found -> None
end
module U = S.UDP
module T = S.TCP
type f = {
flow : T.flow ;
mutable linger : Cstruct.t ;
}
let of_flow flow = { flow ; linger = Cstruct.empty }
let flow { flow ; _ } = flow
let rec read_exactly f length =
let dst_ip, dst_port = T.dst f.flow in
if Cstruct.length f.linger >= length then
let a, b = Cstruct.split f.linger length in
f.linger <- b ;
Lwt.return (Ok a)
else
T.read f.flow >>= function
| Ok `Eof ->
Log.debug (fun m -> m "end of file on flow %a:%d" Ipaddr.pp dst_ip dst_port) ;
T.close f.flow >>= fun () ->
Lwt.return (Error ())
| Error e ->
Log.err (fun m -> m "error %a reading flow %a:%d" T.pp_error e Ipaddr.pp dst_ip dst_port) ;
T.close f.flow >>= fun () ->
Lwt.return (Error ())
| Ok (`Data b) ->
f.linger <- Cstruct.append f.linger b ;
read_exactly f length
let send_udp stack src_port dst dst_port data =
Log.debug (fun m -> m "udp: sending %d bytes from %d to %a:%d"
(Cstruct.length data) src_port Ipaddr.pp dst dst_port) ;
U.write ~src_port ~dst ~dst_port (S.udp stack) data >|= function
| Error e -> Log.warn (fun m -> m "udp: failure %a while sending from %d to %a:%d"
U.pp_error e src_port Ipaddr.pp dst dst_port)
| Ok () -> ()
let send_tcp flow answer =
let dst_ip, dst_port = T.dst flow in
Log.debug (fun m -> m "tcp: sending %d bytes to %a:%d" (Cstruct.length answer) Ipaddr.pp dst_ip dst_port) ;
let len = Cstruct.create 2 in
Cstruct.BE.set_uint16 len 0 (Cstruct.length answer) ;
T.write flow (Cstruct.append len answer) >>= function
| Ok () -> Lwt.return (Ok ())
| Error e ->
Log.err (fun m -> m "tcp: error %a while writing to %a:%d" T.pp_write_error e Ipaddr.pp dst_ip dst_port) ;
T.close flow >|= fun () ->
Error ()
let send_tcp_multiple flow datas =
Lwt_list.fold_left_s (fun acc d ->
match acc with
| Error () -> Lwt.return (Error ())
| Ok () -> send_tcp flow d)
(Ok ()) datas
let read_tcp flow =
read_exactly flow 2 >>= function
| Error () -> Lwt.return (Error ())
| Ok l ->
let len = Cstruct.BE.get_uint16 l 0 in
read_exactly flow len
end

36
unikernel/duniverse/ocaml-dns/mirage/dns_mirage.mli Normal file
View file

@ -0,0 +1,36 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
module Make (S : Tcpip.Stack.V4V6) : sig
module IPM : sig
include Map.S with type key = Ipaddr.t * int
val find : Ipaddr.t * int -> 'a t -> 'a option
end
(** [IPM] is a map using [ip * port] as key. *)
type f
(** A 2byte-length per message flow abstraction, the embedding of DNS frames
via TCP. *)
val of_flow : S.TCP.flow -> f
(** [of_flow flow] is [f]. *)
val flow : f -> S.TCP.flow
(** [flow f] is the underlying flow. *)
val read_tcp : f -> (Cstruct.t, unit) result Lwt.t
(** [read_tcp f] returns either a buffer or an error (logs actual error). *)
val send_tcp : S.TCP.flow -> Cstruct.t -> (unit, unit) result Lwt.t
(** [send_tcp flow buf] sends the buffer, either succeeds or fails (logs
actual error). *)
val send_tcp_multiple : S.TCP.flow -> Cstruct.t list ->
(unit, unit) result Lwt.t
(** [send_tcp_multiple flow bufs] sends the buffers, either succeeds or fails
(logs actual error). *)
val send_udp : S.t -> int -> Ipaddr.t -> int -> Cstruct.t -> unit Lwt.t
(** [send_udp stack source_port dst dst_port buf] sends the [buf] as UDP
packet to [dst] on [dst_port]. *)
end

5
unikernel/duniverse/ocaml-dns/mirage/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name dns_mirage)
(public_name dns-mirage)
(wrapped false)
(libraries dns tcpip ipaddr lwt))

437
unikernel/duniverse/ocaml-dns/mirage/resolver/dns_resolver_mirage.ml Normal file
View file

@ -0,0 +1,437 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let src = Logs.Src.create "dns_resolver_mirage" ~doc:"effectful DNS resolver"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (S : Tcpip.Stack.V4V6) = struct
module Dns = Dns_mirage.Make(S)
module T = S.TCP
module TLS = Tls_mirage.Make(T)
type t = {
push : (Ipaddr.t * int * string * (int32 * string) Lwt.u) option -> unit ;
primary_data : unit -> Dns_trie.t ;
with_primary_data : Dns_trie.t -> unit ;
update_tls : Tls.Config.server -> unit ;
}
type tls_flow = { tls_flow : TLS.flow ; mutable linger : Cstruct.t }
module FM = Map.Make(struct
type t = Ipaddr.t * int
let compare (ip, p) (ip', p') =
match Ipaddr.compare ip ip' with
| 0 -> compare p p'
| x -> x
end)
let resolver stack ?(root = false) ?(timer = 500) ?(udp = true) ?(tcp = true) ?tls ?(port = 53) ?(tls_port = 853) t =
let server_port = 53 in
let server_tls_port = 853 in
let state = ref t in
(* according to RFC5452 4.5, we can chose source port between 1024-49152 *)
let sport () = 1024 + Randomconv.int ~bound:48128 Mirage_crypto_rng.generate in
(* TODO limit these maps so we don't use too much memory *)
let tcp_in = ref FM.empty in
let ocaml_in = ref FM.empty in
let auth = ref Ipaddr.Map.empty in
let tls_auth = ref Ipaddr.Map.empty in
let stream, push = Lwt_stream.create () in
let opportunistic = List.mem `Opportunistic_tls_authoritative (Dns_resolver.features t) in
let send_tls flow data =
let len = Cstruct.create 2 in
Cstruct.BE.set_uint16 len 0 (Cstruct.length data);
TLS.writev flow [len; data] >>= function
| Ok () -> Lwt.return (Ok ())
| Error e ->
Log.err (fun m -> m "tls error %a while writing" TLS.pp_write_error e);
TLS.close flow >|= fun () ->
Error ()
in
let rec read_tls ({ tls_flow ; linger } as f) length =
if Cstruct.length linger >= length then
let a, b = Cstruct.split linger length in
f.linger <- b;
Lwt.return (Ok a)
else
TLS.read tls_flow >>= function
| Ok `Eof -> Log.debug (fun m -> m "end of file while reading"); TLS.close tls_flow >|= fun () -> Error ()
| Error e -> Log.warn (fun m -> m "error reading TLS: %a" TLS.pp_error e); TLS.close tls_flow >|= fun () -> Error ()
| Ok (`Data d) ->
f.linger <- Cstruct.append linger d;
read_tls f length
in
let read_tls_packet f =
read_tls f 2 >>= function
| Error () -> Lwt.return (Error ())
| Ok k ->
let len = Cstruct.BE.get_uint16 k 0 in
read_tls f len
in
let retry_tls = Duration.of_day 1 in (* from RFC 9539, 4.3 "damping" *)
let tls_timeout = Duration.of_sec 2 in (* RFC 9539, 4.3 "timeout" (4s), we use 2s *)
let rec client_tls_out cfg dst port =
tls_auth := Ipaddr.Map.add dst (`Tls_tried (Mirage_mtime.elapsed_ns ())) !tls_auth;
T.create_connection (S.tcp stack) (dst, port) >>= function
| Error e ->
(* do i need to report this back into the resolver? what are their options then? *)
Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d"
T.pp_error e Ipaddr.pp dst port) ;
Lwt.return (Error ())
| Ok flow ->
Log.debug (fun m -> m "established new outgoing TCP connection to %a:%d"
Ipaddr.pp dst port);
TLS.client_of_flow cfg flow >|= function
| Error e ->
Log.warn (fun m -> m "TLS error (to %a:%d): %a" Ipaddr.pp dst port
TLS.pp_write_error e);
Error ()
| Ok tls ->
let cfg =
match TLS.epoch tls with
| Error () -> cfg
| Ok ed ->
let anchors = Result.get_ok Ca_certs_nss.trust_anchors in
let authenticator =
let time () = Some (Mirage_ptime.now ()) in
match X509.Validation.verify_chain_of_trust ~host:None ~ip:dst
~time ~anchors ed.Tls.Core.peer_certificate_chain
with
| Ok _ ->
Log.info (fun m -> m "NS %a using ca-certs-nss authenticator"
Ipaddr.pp dst);
Result.get_ok (Ca_certs_nss.authenticator ())
| Error _ ->
match ed.peer_certificate with
| None ->
Log.info (fun m -> m "NS %a no certificate provided"
Ipaddr.pp dst);
fun ?ip:_ ~host:_ _certs -> Ok None
| Some cert ->
let fingerprint =
X509.(Public_key.fingerprint (Certificate.public_key cert))
in
Log.info (fun m -> m "NS %a using key-fingerprint %a authenticator"
Ohex.pp fingerprint Ipaddr.pp dst);
X509.Authenticator.key_fingerprint ~time ~hash:`SHA256 ~fingerprint
in
Result.get_ok (Tls.Config.client ~authenticator ())
in
tls_auth := Ipaddr.Map.add dst (`Tls_succeeded cfg) !tls_auth;
Log.debug (fun m -> m "tls connection to %a:%d" Ipaddr.pp dst port);
auth := Ipaddr.Map.add dst (`Tls tls) !auth ;
Lwt.async (fun () ->
let tls_and_linger = { tls_flow = tls ; linger = Cstruct.empty } in
let rec loop () =
read_tls_packet tls_and_linger >>= function
| Error () ->
Log.debug (fun m -> m "removing %a from auth" Ipaddr.pp dst) ;
auth := Ipaddr.Map.remove dst !auth ;
Lwt.return_unit
| Ok data ->
let now = Mirage_ptime.now () in
let ts = Mirage_mtime.elapsed_ns () in
let new_state, answers, queries =
let data = Cstruct.to_string data in
Dns_resolver.handle_buf !state now ts false `Tcp dst port data
in
state := new_state ;
Lwt_list.iter_p handle_answer answers >>= fun () ->
Lwt_list.iter_p handle_query queries >>= fun () ->
loop ()
in
loop ()) ;
Ok ()
and client_tcp_out dst port =
T.create_connection (S.tcp stack) (dst, port) >|= function
| Error e ->
(* do i need to report this back into the resolver? what are their options then? *)
Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d"
T.pp_error e Ipaddr.pp dst port) ;
Error ()
| Ok flow ->
Log.debug (fun m -> m "established new outgoing TCP connection to %a:%d"
Ipaddr.pp dst port);
auth := Ipaddr.Map.add dst (`Tcp flow) !auth ;
Lwt.async (fun () ->
let f = Dns.of_flow flow in
let rec loop () =
Dns.read_tcp f >>= function
| Error () ->
Log.debug (fun m -> m "removing %a from auth" Ipaddr.pp dst) ;
auth := Ipaddr.Map.remove dst !auth ;
Lwt.return_unit
| Ok data ->
let now = Mirage_ptime.now () in
let ts = Mirage_mtime.elapsed_ns () in
let new_state, answers, queries =
let data = Cstruct.to_string data in
Dns_resolver.handle_buf !state now ts false `Tcp dst port data
in
state := new_state ;
Lwt_list.iter_p handle_answer answers >>= fun () ->
Lwt_list.iter_p handle_query queries >>= fun () ->
loop ()
in
loop ()) ;
Ok ()
and client_tcp dst port ~tls_port data =
match Ipaddr.Map.find_opt dst !auth with
| None ->
begin
let try_it = match Ipaddr.Map.find_opt dst !tls_auth with
| None -> Some None
| Some `Tls_succeeded cfg -> Some (Some cfg)
| Some `Tls_tried ts ->
if Int64.(ts >= sub (Mirage_mtime.elapsed_ns ()) retry_tls) then
Some None
else
None
in
(match try_it with
| Some cfg when opportunistic ->
let cfg =
match cfg with
| None ->
let authenticator ?ip:_ ~host:_ _certs = Ok None in
Result.get_ok (Tls.Config.client ~authenticator ())
| Some cfg -> cfg
in
client_tls_out cfg dst tls_port
| _ ->
client_tcp_out dst port) >>= function
| Error () ->
let sport = sport () in
S.UDP.listen (S.udp stack) ~port:sport (udp_cb sport false) ;
Dns.send_udp stack sport dst port (Cstruct.of_string data)
| Ok () -> client_tcp dst port ~tls_port data
end
| Some `Tcp x ->
begin
Dns.send_tcp x (Cstruct.of_string data) >>= function
| Ok () -> Lwt.return_unit
| Error () ->
auth := Ipaddr.Map.remove dst !auth ;
client_tcp dst port ~tls_port data
end
| Some `Tls tls ->
begin
send_tls tls (Cstruct.of_string data) >>= function
| Ok () -> Lwt.return_unit
| Error () ->
auth := Ipaddr.Map.remove dst !auth ;
client_tcp dst port ~tls_port data
end
and maybe_tcp dst port data =
(match Ipaddr.Map.find_opt dst !auth with
| Some `Tcp flow -> Dns.send_tcp flow (Cstruct.of_string data)
| Some `Tls tls -> send_tls tls (Cstruct.of_string data)
| None -> Lwt.return (Error ())) >>= function
| Ok () -> Lwt.return_unit
| Error () ->
let try_tls =
match Ipaddr.Map.find_opt dst !tls_auth with
| None -> true
| Some `Tls_succeeded _ -> true
| Some `Tls_tried ts ->
Int64.(ts >= sub (Mirage_mtime.elapsed_ns ()) retry_tls)
in
(if try_tls then
Lwt.pick [
(Mirage_sleep.ns tls_timeout >|= fun () -> `Timeout);
(client_tcp dst port ~tls_port:server_tls_port data >|= fun () -> `Used_tls)
]
else
Lwt.return `Timeout) >>= function
| `Timeout ->
let sport = sport () in
S.UDP.listen (S.udp stack) ~port:sport (udp_cb sport false) ;
Dns.send_udp stack sport dst port (Cstruct.of_string data)
| `Used_tls -> Lwt.return_unit
and handle_query (proto, dst, data) = match proto with
| `Udp -> maybe_tcp dst server_port data
| `Tcp -> client_tcp dst server_port ~tls_port:server_tls_port data
and handle_answer (proto, dst, dst_port, ttl, data) = match proto with
| `Udp -> Dns.send_udp stack port dst dst_port (Cstruct.of_string data)
| `Tcp ->
let from_tcp = FM.find_opt (dst, dst_port) !tcp_in in
let from_ocaml = FM.find_opt (dst, dst_port) !ocaml_in in
match from_tcp, from_ocaml with
| None, None ->
Log.err (fun m -> m "wanted to answer %a:%d via TCP, but couldn't find a flow"
Ipaddr.pp dst dst_port) ;
Lwt.return_unit
| Some (`Tcp flow), None ->
(Dns.send_tcp flow (Cstruct.of_string data) >|= function
| Ok () -> ()
| Error () -> tcp_in := FM.remove (dst, dst_port) !tcp_in)
| Some (`Tls flow), None ->
(send_tls flow (Cstruct.of_string data) >|= function
| Ok () -> ()
| Error () -> tcp_in := FM.remove (dst, dst_port) !tcp_in)
| None, Some wk -> begin
ocaml_in := FM.remove (dst, dst_port) !ocaml_in;
Lwt.wakeup wk (ttl, data);
Lwt.return_unit end
| Some _, Some _ -> assert false
and udp_cb lport req ~src ~dst:_ ~src_port buf =
let buf = Cstruct.to_string buf in
let now = Mirage_ptime.now ()
and ts = Mirage_mtime.elapsed_ns ()
in
let new_state, answers, queries =
Dns_resolver.handle_buf !state now ts req `Udp src src_port buf
in
if not req then
S.UDP.unlisten (S.udp stack) ~port:lport;
state := new_state ;
Lwt_list.iter_p handle_answer answers >>= fun () ->
Lwt_list.iter_p handle_query queries
in
if udp then begin
S.UDP.listen (S.udp stack) ~port (udp_cb port true);
Log.info (fun f -> f "DNS resolver listening on UDP port %d" port);
end;
let rec ocaml_cb () =
Lwt_stream.get stream >>= function
| Some (dst_ip, dst_port, data, wk) ->
ocaml_in := FM.add (dst_ip, dst_port) wk !ocaml_in;
let now = Mirage_ptime.now () in
let ts = Mirage_mtime.elapsed_ns () in
let new_state, answers, queries =
Dns_resolver.handle_buf !state now ts true `Tcp dst_ip dst_port data in
state := new_state ;
Lwt_list.iter_p handle_answer answers >>= fun () ->
Lwt_list.iter_p handle_query queries >>= fun () ->
ocaml_cb ()
| None -> Lwt.return_unit in
Lwt.async ocaml_cb;
let tcp_cb query flow =
let dst_ip, dst_port = T.dst flow in
Log.debug (fun m -> m "tcp connection from %a:%d" Ipaddr.pp dst_ip dst_port) ;
tcp_in := FM.add (dst_ip, dst_port) (`Tcp flow) !tcp_in ;
let f = Dns.of_flow flow in
let rec loop () =
Dns.read_tcp f >>= function
| Error () ->
tcp_in := FM.remove (dst_ip, dst_port) !tcp_in ;
Lwt.return_unit
| Ok data ->
let data = Cstruct.to_string data in
let now = Mirage_ptime.now () in
let ts = Mirage_mtime.elapsed_ns () in
let new_state, answers, queries =
Dns_resolver.handle_buf !state now ts query `Tcp dst_ip dst_port data
in
state := new_state ;
Lwt_list.iter_p handle_answer answers >>= fun () ->
Lwt_list.iter_p handle_query queries >>= fun () ->
loop ()
in
loop ()
in
if tcp then begin
S.TCP.listen (S.tcp stack) ~port (tcp_cb true);
Log.info (fun m -> m "DNS resolver listening on TCP port %d" port);
end;
let tls_cb cfg flow =
let dst_ip, dst_port = T.dst flow in
TLS.server_of_flow cfg flow >>= function
| Error e ->
Log.warn (fun m -> m "TLS error (from %a:%d): %a" Ipaddr.pp dst_ip dst_port
TLS.pp_write_error e);
Lwt.return_unit
| Ok tls ->
Log.debug (fun m -> m "tls connection from %a:%d" Ipaddr.pp dst_ip dst_port);
tcp_in := FM.add (dst_ip, dst_port) (`Tls tls) !tcp_in ;
let tls_and_linger = { tls_flow = tls ; linger = Cstruct.empty } in
let rec loop () =
read_tls_packet tls_and_linger >>= function
| Error () ->
tcp_in := FM.remove (dst_ip, dst_port) !tcp_in ;
Lwt.return_unit
| Ok data ->
let data = Cstruct.to_string data in
let now = Mirage_ptime.now () in
let ts = Mirage_mtime.elapsed_ns () in
let new_state, answers, queries =
Dns_resolver.handle_buf !state now ts true `Tcp dst_ip dst_port data
in
state := new_state ;
Lwt_list.iter_p handle_answer answers >>= fun () ->
Lwt_list.iter_p handle_query queries >>= fun () ->
loop ()
in
loop ()
in
let update_tls tls_cfg =
S.TCP.listen (S.tcp stack) ~port:tls_port (tls_cb tls_cfg);
in
(match tls with
| None -> ()
| Some cfg ->
update_tls cfg;
Log.info (fun m -> m "DNS resolver listening on TLS port %d" tls_port));
let rec time () =
let new_state, answers, queries =
Dns_resolver.timer !state (Mirage_mtime.elapsed_ns ())
in
state := new_state ;
Lwt_list.iter_p handle_answer answers >>= fun () ->
Lwt_list.iter_p handle_query queries >>= fun () ->
Mirage_sleep.ns (Duration.of_ms timer) >>= fun () ->
time ()
in
Lwt.async time ;
let primary_data () =
Dns_resolver.primary_data !state
in
let with_primary_data data =
let (t, outs) =
Dns_resolver.with_primary_data !state
(Mirage_ptime.now ())
(Mirage_mtime.elapsed_ns ())
data
in
state := t;
if outs <> [] then
Log.warn (fun m -> m "Updating resolver's primary name server resulted
in 'notify's. Secondaries in the resolver's primary DNS is *not*
supported. The 'notify's are discarded.")
in
if root then begin
let rec root () =
let new_state, q = Dns_resolver.query_root !state (Mirage_mtime.elapsed_ns ()) `Tcp in
state := new_state ;
handle_query q >>= fun () ->
Mirage_sleep.ns (Duration.of_day 6) >>= fun () ->
root ()
in
Lwt.async root end ;
{ push; primary_data; with_primary_data; update_tls }
let resolve_external { push; _ } (dst_ip, dst_port) data =
let th, wk = Lwt.wait () in
push (Some (dst_ip, dst_port, data, wk));
th
let primary_data { primary_data; _ } = primary_data ()
let update_primary_data { with_primary_data; _ } data = with_primary_data data
let update_tls { update_tls; _ } tls_config = update_tls tls_config
end

16
unikernel/duniverse/ocaml-dns/mirage/resolver/dns_resolver_mirage.mli Normal file
View file

@ -0,0 +1,16 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
module Make (S : Tcpip.Stack.V4V6) : sig
type t
val resolver
: S.t -> ?root:bool -> ?timer:int -> ?udp:bool -> ?tcp:bool -> ?tls:Tls.Config.server -> ?port:int -> ?tls_port:int
-> Dns_resolver.t -> t
(** [resolver stack ~root ~timer ~udp ~tcp ~tls ~port ~tls_port resolver]
registers a caching resolver on the provided protocols [udp], [tcp], [tls]
using [port] for udp and tcp (defaults to 53), [tls_port] for tls (defaults
to 853) using the [resolver] configuration. The [timer] is in milliseconds
and defaults to 500 milliseconds.*)
include Dns_resolver_mirage_shared.S with type t := t
end

10
unikernel/duniverse/ocaml-dns/mirage/resolver/dns_resolver_mirage_shared.ml Normal file
View file

@ -0,0 +1,10 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
module type S = sig
type t
val resolve_external : t -> Ipaddr.t * int -> string -> (int32 * string) Lwt.t
val primary_data : t -> Dns_trie.t
val update_primary_data : t -> Dns_trie.t -> unit
val update_tls : t -> Tls.Config.server -> unit
end

22
unikernel/duniverse/ocaml-dns/mirage/resolver/dns_resolver_mirage_shared.mli Normal file
View file

@ -0,0 +1,22 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
module type S = sig
type t
val resolve_external : t -> Ipaddr.t * int -> string -> (int32 * string) Lwt.t
(** [resolve_external t (ip, port) data] resolves for [(ip, port)] the query
[data] and returns a pair of the minimum TTL and a response. *)
val primary_data : t -> Dns_trie.t
(** [primary_data t] is the DNS trie of the primary for the resolver [t]. *)
val update_primary_data : t -> Dns_trie.t -> unit
(** [update_primary_data t data] updates the primary for the resolver [t]
with the DNS trie [data]. Any 'notify's to secondaries are discarded -
secondary name servers are not supported in this setup. *)
val update_tls : t -> Tls.Config.server -> unit
(** [update_tls t tls_config] updates the tls configuration to [tls_config].
If the resolver wasn't already listening for TLS connections it will
start listening. *)
end

13
unikernel/duniverse/ocaml-dns/mirage/resolver/dune Normal file
View file

@ -0,0 +1,13 @@
(library
(name dns_resolver_mirage)
(public_name dns-resolver.mirage)
(wrapped false)
(modules dns_resolver_mirage)
(libraries dns dns-resolver dns-server dns-mirage lwt duration mirage-sleep mirage-ptime mirage-mtime tcpip mirage-crypto-rng tls tls-mirage ca-certs-nss dns-resolver.mirage.shared))
(library
(name dns_resolver_mirage_shared)
(public_name dns-resolver.mirage.shared)
(wrapped false)
(modules dns_resolver_mirage_shared)
(libraries ipaddr dns-server tcpip tls))

334
unikernel/duniverse/ocaml-dns/mirage/server/dns_server_mirage.ml Normal file
View file

@ -0,0 +1,334 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let src = Logs.Src.create "dns_server_mirage" ~doc:"effectful DNS server"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (S : Tcpip.Stack.V4V6) = struct
let inc =
let f = function
| `Udp_query -> "udp queries"
| `Udp_answer -> "udp answers"
| `Tcp_query -> "tcp queries"
| `Tcp_answer -> "tcp answers"
| `Tcp -> "tcp-server"
| `Tcp_client -> "tcp-client"
| `Tcp_keep -> "keep tcp flow"
| `Notify -> "request"
| `On_update -> "on update"
| `On_notify -> "on notify"
| `Tcp_cache_add -> "tcp cache add"
| `Tcp_cache_drop -> "tcp cache drop"
in
let src = Dns.counter_metrics ~f "dns-server-mirage" in
(fun x -> Metrics.add src (fun x -> x) (fun d -> d x))
module Dns = Dns_mirage.Make(S)
module T = S.TCP
let primary ?(on_update = fun ~old:_ ~authenticated_key:_ ~update_source:_ _ -> Lwt.return_unit) ?(on_notify = fun _ _ -> Lwt.return None) ?(timer = 2) ?(port = 53) stack t =
let state = ref t in
let tcp_out = ref Ipaddr.Map.empty in
let drop ip =
if Ipaddr.Map.mem ip !tcp_out then begin
inc `Tcp_cache_drop;
tcp_out := Ipaddr.Map.remove ip !tcp_out ;
state := Dns_server.Primary.closed !state ip
end
in
let connect recv_task ip =
inc `Tcp_client;
let dport = 53 in
Log.debug (fun m -> m "creating connection to %a:%d" Ipaddr.pp ip dport) ;
T.create_connection (S.tcp stack) (ip, dport) >>= function
| Error e ->
Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d"
T.pp_error e Ipaddr.pp ip port) ;
Lwt.return (Error ())
| Ok flow ->
inc `Tcp_cache_add;
tcp_out := Ipaddr.Map.add ip flow !tcp_out ;
Lwt.async (recv_task ip dport flow);
Lwt.return (Ok flow)
in
let send_notify recv_task (ip, data) =
inc `Notify;
let data = List.map Cstruct.of_string data in
let connect_and_send ip =
connect recv_task ip >>= function
| Ok flow -> Dns.send_tcp_multiple flow data
| Error () -> Lwt.return (Error ())
in
(match Ipaddr.Map.find_opt ip !tcp_out with
| None -> connect_and_send ip
| Some f -> Dns.send_tcp_multiple f data >>= function
| Ok () -> Lwt.return (Ok ())
| Error () -> drop ip ; connect_and_send ip) >>= function
| Ok () -> Lwt.return_unit
| Error () ->
drop ip;
Lwt_list.iter_p (Dns.send_udp stack port ip 53) data
in
let maybe_update_state key ip t =
let old = !state in
let trie server = Dns_server.Primary.data server in
state := t;
if Dns_trie.equal (trie t) (trie old) then
Lwt.return_unit
else begin
inc `On_update ; on_update ~old:(trie old) ~authenticated_key:key ~update_source:ip t
end
and maybe_notify recv_task t now ts = function
| None -> Lwt.return_unit
| Some n -> inc `On_notify ; on_notify n t >>= function
| None -> Lwt.return_unit
| Some (trie, keys) ->
let state', outs = Dns_server.Primary.with_keys t now ts keys in
let state'', outs' = Dns_server.Primary.with_data state' now ts trie in
state := state'';
Lwt_list.iter_p (send_notify recv_task) (outs @ outs')
in
let rec recv_task ip port flow () =
let f = Dns.of_flow flow in
let rec loop () =
Dns.read_tcp f >>= function
| Error () -> drop ip ; Lwt.return_unit
| Ok data ->
inc `Tcp_query;
let now = Mirage_ptime.now () in
let ts = Mirage_mtime.elapsed_ns () in
let t, answers, notify, n, key =
Dns_server.Primary.handle_buf !state now ts `Tcp ip port (Cstruct.to_string data)
in
let n' = match n with
| Some `Keep -> inc `Tcp_cache_add ; inc `Tcp_keep ; tcp_out := Ipaddr.Map.add ip flow !tcp_out ; None
| Some `Notify soa -> Some (`Notify soa)
| Some `Signed_notify soa -> Some (`Signed_notify soa)
| None -> None
in
maybe_update_state key ip t >>= fun () ->
maybe_notify recv_task t now ts n' >>= fun () ->
if answers <> [] then inc `Tcp_answer;
let answers = List.map Cstruct.of_string answers in
(Dns.send_tcp_multiple flow answers >|= function
| Ok () -> ()
| Error () -> drop ip) >>= fun () ->
Lwt_list.iter_p (send_notify recv_task) notify >>= fun () ->
loop ()
in
loop ()
in
let tcp_cb flow =
inc `Tcp;
let dst_ip, dst_port = T.dst flow in
recv_task dst_ip dst_port flow ()
in
S.TCP.listen (S.tcp stack) ~port tcp_cb ;
Log.info (fun m -> m "DNS server listening on TCP port %d" port) ;
let udp_cb ~src ~dst:_ ~src_port buf =
inc `Udp_query;
let buf = Cstruct.to_string buf in
let now = Mirage_ptime.now () in
let ts = Mirage_mtime.elapsed_ns () in
let t, answers, notify, n, key =
Dns_server.Primary.handle_buf !state now ts `Udp src src_port buf
in
let n' = match n with
| None | Some `Keep -> None
| Some `Notify soa -> Some (`Notify soa)
| Some `Signed_notify soa -> Some (`Signed_notify soa)
in
maybe_update_state key src t >>= fun () ->
maybe_notify recv_task t now ts n' >>= fun () ->
if answers <> [] then inc `Udp_answer;
let answers = List.map Cstruct.of_string answers in
(Lwt_list.iter_s (Dns.send_udp stack port src src_port) answers) >>= fun () ->
Lwt_list.iter_p (send_notify recv_task) notify
in
S.UDP.listen (S.udp stack) ~port udp_cb ;
Log.info (fun m -> m "DNS server listening on UDP port %d" port) ;
let rec time () =
let now = Mirage_ptime.now () in
let ts = Mirage_mtime.elapsed_ns () in
let t, notifies = Dns_server.Primary.timer !state now ts in
maybe_update_state None Ipaddr.(V4 V4.localhost) t >>= fun () ->
Lwt_list.iter_p (send_notify recv_task) notifies >>= fun () ->
Mirage_sleep.ns (Duration.of_sec timer) >>= fun () ->
time ()
in
Lwt.async time
let secondary ?(on_update = fun ~old:_ _trie -> Lwt.return_unit) ?(timer = 5) ?(port = 53) stack t =
let state = ref t in
let tcp_out = ref Ipaddr.Map.empty in
let maybe_update_state t =
let old = !state in
let trie server = Dns_server.Secondary.data server in
state := t ;
if Dns_trie.equal (trie t) (trie old) then
Lwt.return_unit
else begin
inc `On_update ; on_update ~old:(trie old) t
end
in
let rec close ~timer ip =
(match Ipaddr.Map.find_opt ip !tcp_out with
| None -> Lwt.return_unit
| Some f -> T.close f) >>= fun () ->
tcp_out := Ipaddr.Map.remove ip !tcp_out ;
let now = Mirage_ptime.now () in
let elapsed = Mirage_mtime.elapsed_ns () in
let state', out = Dns_server.Secondary.closed !state now elapsed ip in
state := state' ;
if not timer then
request ~timer (ip, out)
else
Lwt.return_unit
and read_and_handle ~timer ip f =
Dns.read_tcp f >>= function
| Error () ->
Log.debug (fun m -> m "removing %a from tcp_out" Ipaddr.pp ip) ;
close ~timer ip
| Ok data ->
inc `Tcp_query;
let now = Mirage_ptime.now () in
let elapsed = Mirage_mtime.elapsed_ns () in
let t, answer, out =
Dns_server.Secondary.handle_buf !state now elapsed `Tcp ip (Cstruct.to_string data)
in
maybe_update_state t >>= fun () ->
(match answer with
| None -> Lwt.return (Ok ())
| Some x ->
inc `Tcp_answer;
let x = Cstruct.of_string x in
Dns.send_tcp (Dns.flow f) x >>= function
| Error () ->
Log.debug (fun m -> m "removing %a from tcp_out" Ipaddr.pp ip) ;
close ~timer ip >|= fun () -> Error ()
| Ok () -> Lwt.return (Ok ())) >>= fun r ->
(match out with
| None -> Lwt.return_unit
| Some (ip, data) -> request_one ~timer (ip, data)) >>= fun () ->
match r with
| Ok () -> read_and_handle ~timer ip f
| Error () -> Lwt.return_unit
and request ~timer (ip, data) =
inc `Notify;
let dport = 53 in
match Ipaddr.Map.find_opt ip !tcp_out with
| None ->
begin
Log.debug (fun m -> m "creating connection to %a:%d" Ipaddr.pp ip dport) ;
inc `Tcp_client;
T.create_connection (S.tcp stack) (ip, dport) >>= function
| Error e ->
Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d"
T.pp_error e Ipaddr.pp ip dport) ;
close ~timer ip
| Ok flow ->
tcp_out := Ipaddr.Map.add ip flow !tcp_out ;
let data = List.map Cstruct.of_string data in
Dns.send_tcp_multiple flow data >>= function
| Error () -> close ~timer ip
| Ok () ->
Lwt.async (fun () -> read_and_handle ~timer ip (Dns.of_flow flow)) ;
Lwt.return_unit
end
| Some flow ->
let data = List.map Cstruct.of_string data in
Dns.send_tcp_multiple flow data >>= function
| Ok () -> Lwt.return_unit
| Error () ->
Log.warn (fun m -> m "closing tcp flow to %a:%d, retrying request"
Ipaddr.pp ip dport) ;
T.close flow >>= fun () ->
tcp_out := Ipaddr.Map.remove ip !tcp_out ;
let data = List.map Cstruct.to_string data in
request ~timer (ip, data)
and request_one ~timer (ip, d) = request ~timer (ip, [ d ])
in
let udp_cb ~src ~dst:_ ~src_port buf =
Log.debug (fun m -> m "udp frame from %a:%d" Ipaddr.pp src src_port) ;
inc `Udp_query;
let buf = Cstruct.to_string buf in
let now = Mirage_ptime.now () in
let elapsed = Mirage_mtime.elapsed_ns () in
let t, answer, out =
Dns_server.Secondary.handle_buf !state now elapsed `Udp src buf
in
maybe_update_state t >>= fun () ->
(match out with
| None -> ()
| Some (ip, cs) -> Lwt.async (fun () -> request_one ~timer:false (ip, cs))) ;
match answer with
| None -> Lwt.return_unit
| Some out ->
inc `Udp_answer;
let out = Cstruct.of_string out in
Dns.send_udp stack port src src_port out
in
S.UDP.listen (S.udp stack) ~port udp_cb ;
Log.info (fun m -> m "secondary DNS listening on UDP port %d" port) ;
let tcp_cb flow =
inc `Tcp;
let dst_ip, dst_port = T.dst flow in
tcp_out := Ipaddr.Map.add dst_ip flow !tcp_out ;
Log.debug (fun m -> m "tcp connection from %a:%d" Ipaddr.pp dst_ip dst_port) ;
let f = Dns.of_flow flow in
let rec loop () =
Dns.read_tcp f >>= function
| Error () -> tcp_out := Ipaddr.Map.remove dst_ip !tcp_out ; Lwt.return_unit
| Ok data ->
inc `Tcp_query;
let data = Cstruct.to_string data in
let now = Mirage_ptime.now () in
let elapsed = Mirage_mtime.elapsed_ns () in
let t, answer, out =
Dns_server.Secondary.handle_buf !state now elapsed `Tcp dst_ip data
in
maybe_update_state t >>= fun () ->
(match out with
| None -> ()
| Some (ip, cs) -> Lwt.async (fun () -> request_one ~timer:false (ip, cs)));
match answer with
| None ->
Log.warn (fun m -> m "no TCP output") ;
loop ()
| Some data ->
inc `Tcp_answer;
let data = Cstruct.of_string data in
Dns.send_tcp flow data >>= function
| Ok () -> loop ()
| Error () -> tcp_out := Ipaddr.Map.remove dst_ip !tcp_out ; Lwt.return_unit
in
loop ()
in
S.TCP.listen (S.tcp stack) ~port tcp_cb ;
Log.info (fun m -> m "secondary DNS listening on TCP port %d" port) ;
let rec time () =
let now = Mirage_ptime.now () in
let elapsed = Mirage_mtime.elapsed_ns () in
let t, out = Dns_server.Secondary.timer !state now elapsed in
maybe_update_state t >>= fun () ->
List.iter (fun (ip, cs) ->
Lwt.async (fun () -> request ~timer:true (ip, cs))) out ;
Mirage_sleep.ns (Duration.of_sec timer) >>= fun () ->
time ()
in
Lwt.async time
end

30
unikernel/duniverse/ocaml-dns/mirage/server/dns_server_mirage.mli Normal file
View file

@ -0,0 +1,30 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
module Make (S : Tcpip.Stack.V4V6) : sig
val primary :
?on_update:(old:Dns_trie.t -> authenticated_key:[`raw] Domain_name.t option -> update_source:Ipaddr.t -> Dns_server.Primary.s -> unit Lwt.t) ->
?on_notify:([ `Notify of Dns.Soa.t option | `Signed_notify of Dns.Soa.t option ] ->
Dns_server.Primary.s ->
(Dns_trie.t * ([ `raw ] Domain_name.t * Dns.Dnskey.t) list) option Lwt.t) ->
?timer:int -> ?port:int -> S.t -> Dns_server.Primary.s -> unit
(** [primary ~on_update ~timer ~port stack primary] starts a primary server on
[port] (default 53, both TCP and UDP) with the given [primary]
configuration. [timer] is the DNS notify timer in seconds, and defaults to
2 seconds. [on_update ~old ~authenticated_key ~update_source s] is a
callback if the data served by the primary server [s] got updated by a
potentially authenticated nsupdate packet, the used [authenticated_key]
and source [update_source] are passed to the callback. The
[on_notify notify s] callback is executed when a notify request is received
by the primary DNS server (may be used for signaling of a (hidden) DNS
secondary server). *)
val secondary :
?on_update:(old:Dns_trie.t -> Dns_server.Secondary.s -> unit Lwt.t) ->
?timer:int -> ?port:int -> S.t -> Dns_server.Secondary.s ->
unit
(** [secondary ~on_update ~timer ~port stack secondary] starts a secondary
server on [port] (default 53). The [on_update] callback is executed when
the zone changes. The [timer] (in seconds, defaults to 5 seconds) is used
for refreshing zones. *)
end

5
unikernel/duniverse/ocaml-dns/mirage/server/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name dns_server_mirage)
(public_name dns-server.mirage)
(wrapped false)
(libraries dns dns-server dns-mirage lwt duration randomconv mirage-sleep mirage-ptime mirage-mtime tcpip metrics))

402
unikernel/duniverse/ocaml-dns/mirage/stub/dns_stub_mirage.ml Normal file
View file

@ -0,0 +1,402 @@
(* mirage stub resolver *)
open Lwt.Infix
open Dns
let src = Logs.Src.create "dns_stub_mirage" ~doc:"effectful DNS stub layer"
module Log = (val Logs.src_log src : Logs.LOG)
module Make (S : Tcpip.Stack.V4V6) = struct
(* data in the wild:
- a request comes in hdr, q
- q to be found in cache
- q not found in cache (to be forwarded to the recursive resolver)
- unless q in transit (this to-be-done if it is worth it (is it?))
- a fresh hdr, q is generated and sent to the recursive resolver
- now hdr, q is registered to be awaited for
-- we can either signal the request task once we found something,
or preserve the original hdr, q together with ip and port
- a reply goes out hdr, q, answer
the "Client" is only concerned about the connection to the resolver, with
multiplexing.
the current API is:
dns_client calls connect .. -> flow
send flow data
recv flow (* potentially multiple times *)
i.e. our flow being (int * _):
connect <nothing>
send (id, _) data <- id <- data[2..3]
recv (id, _) <- registers condition in N[id] ; waits ; removes condition
or phrased differently:
a recv_loop reads continously, whenever a full packet is received,
N[id] is woken up with the packet
*)
let metrics =
let f = function
| `Udp_queries -> "udp-queries"
| `Tcp_queries -> "tcp-queries"
| `Ocaml_queries -> "ocaml-queries"
| `Tcp_connections -> "tcp-connections"
| `Authoritative_answers -> "authoritative-answers"
| `Authoritative_errors -> "authoritative-errors"
| `Reserved_answers -> "reserved-answers"
| `On_update -> "on-update"
| `Resolver_queries -> "resolver-queries"
| `Resolver_answers -> "resolver-answers"
| `Resolver_nodata -> "resolver-nodata"
| `Resolver_nodomain -> "resolver-nodomain"
| `Resolver_servfail -> "resolver-servfail"
| `Resolver_notimp -> "resolver-notimplemented"
in
let metrics = Dns.counter_metrics ~f "stub-resolver" in
(fun x -> Metrics.add metrics (fun x -> x) (fun d -> d x))
module H = Happy_eyeballs_mirage.Make(S)
module Client = Dns_client_mirage.Make(S)(H)
module TLS = Tls_mirage.Make(S.TCP)
(* likely this should contain:
- a primary server (handling updates)
- a client on steroids: multiplexing on connections
- listening for DNS requests from clients:
first find them in primary server
if not authoritative, use the client
*)
(* task management
- multiple requests for the same name, type can be done at the same "time"
-> need to remember outstanding requests and signal to clients
*)
(* take multiple resolver IPs and round-robin / ask both (take first answer,
ignoring ServFail etc.) *)
(* timeout of resolver, retransmission (to another resolver / another flow) *)
module Dns_flow = Dns_mirage.Make(S)
type t = {
client : Client.t ;
reserved : Dns_server.t ;
mutable server : Dns_server.t ;
on_update : old:Dns_trie.t -> ?authenticated_key:[`raw] Domain_name.t -> update_source:Ipaddr.t -> Dns_trie.t -> unit Lwt.t ;
push : (Ipaddr.t * int * string * (int32 * string) Lwt.u) option -> unit ;
mutable update_tls : Tls.Config.server -> unit ;
}
let primary_data { server ; _ } =
server.Dns_server.data
let update_primary_data t trie =
let server = Dns_server.with_data t.server trie in
t.server <- server
let resolve_external { push ; _ } (ip, port) data =
let th, wk = Lwt.wait () in
push (Some (ip, port, data, wk));
th
let update_tls { update_tls ; _ } tls = update_tls tls
let build_reply header question proto ?additional data =
let ttl = Packet.minimum_ttl data in
let packet = Packet.create ?additional header question data in
ttl, fst (Packet.encode proto packet)
let query_server trie question data header proto =
match Dns_server.handle_question trie question with
| Ok (_flags, answer, additional) ->
(* TODO do sth with flags *)
metrics `Authoritative_answers;
let data = `Answer answer in
let ttl = Packet.minimum_ttl data in
let packet = Packet.create ?additional header question data in
let packet =
match Dns_block.edns packet with
| None -> packet
| Some edns ->
Dns_resolver_metrics.resolver_stats `Blocked;
Dns.Packet.with_edns packet (Some edns)
in
let reply = ttl, fst (Packet.encode proto packet) in
Some reply
| Error (Rcode.NotAuth, _) -> None
| Error (rcode, answer) ->
metrics `Authoritative_errors;
let data = `Rcode_error (rcode, Packet.opcode_data data, answer) in
let reply = build_reply header question proto data in
Some reply
let tsig_decode_sign server proto packet buf header question =
let now = Mirage_ptime.now () in
match Dns_server.handle_tsig server now packet buf with
| Error _ ->
let data =
`Rcode_error (Rcode.Refused, Packet.opcode_data packet.Packet.data, None)
in
let reply = build_reply header question proto data in
Error reply
| Ok k ->
let key =
match k with None -> None | Some (keyname, _, _, _) -> Some keyname
in
let sign data =
let ttl = Packet.minimum_ttl data in
let packet = Packet.create header question data in
match k with
| None -> Some (ttl, fst (Packet.encode proto packet))
| Some (keyname, _tsig, mac, dnskey) ->
match Dns_tsig.encode_and_sign ~proto ~mac packet now dnskey keyname with
| Error s -> Log.err (fun m -> m "error %a while signing answer" Dns_tsig.pp_s s); None
| Ok (cs, _) -> Some (ttl, cs)
in
Ok (key, sign)
let axfr_server server proto packet question buf header =
match tsig_decode_sign server proto packet buf header question with
| Error e -> Some e
| Ok (key, sign) ->
match Dns_server.handle_axfr_request server proto key question with
| Error rcode ->
let err = `Rcode_error (rcode, Packet.opcode_data packet.Packet.data, None) in
let reply = build_reply header question proto err in
Some reply
| Ok axfr ->
sign (`Axfr_reply axfr)
let update_server t proto ip packet question u buf header =
let server = t.server in
match tsig_decode_sign server proto packet buf header question with
| Error e -> Lwt.return (Some e)
| Ok (key, sign) ->
match Dns_server.handle_update server proto key question u with
| Ok (trie, _) ->
let old = server.data in
let server' = Dns_server.with_data server trie in
t.server <- server';
metrics `On_update;
t.on_update ~old ?authenticated_key:key ~update_source:ip trie >|= fun () ->
sign `Update_ack
| Error rcode ->
Lwt.return (sign (`Rcode_error (rcode, Opcode.Update, None)))
let server t proto ip packet header question data buf =
match data with
| `Query -> Lwt.return (query_server t.server question data header proto)
| `Axfr_request ->
Lwt.return (axfr_server t.server proto packet question buf header)
| `Update u ->
update_server t proto ip packet question u buf header
| _ ->
let data =
`Rcode_error (Rcode.NotImp, Packet.opcode_data packet.Packet.data, None)
in
let pkt = build_reply header question proto data in
Lwt.return (Some pkt)
let resolve t question data header proto =
metrics `Resolver_queries;
let name = fst question in
match data, snd question with
| `Query, `K Rr_map.K key ->
begin Client.get_resource_record t.client key name >|= function
| Error `Msg msg ->
Log.err (fun m -> m "couldn't resolve %s" msg);
let data = `Rcode_error (Rcode.ServFail, Opcode.Query, None) in
metrics `Resolver_servfail;
let reply = build_reply header question proto data in
Some reply
| Error `No_data (domain, soa) ->
let answer = (Name_rr_map.empty, Name_rr_map.singleton domain Soa soa) in
let data = `Answer answer in
metrics `Resolver_nodata;
let reply = build_reply header question proto data in
Some reply
| Error `No_domain (domain, soa) ->
let answer = (Name_rr_map.empty, Name_rr_map.singleton domain Soa soa) in
let data = `Rcode_error (Rcode.NXDomain, Opcode.Query, Some answer) in
metrics `Resolver_nodomain;
let reply = build_reply header question proto data in
Some reply
| Ok reply ->
let answer = (Name_rr_map.singleton name key reply, Name_rr_map.empty) in
let data = `Answer answer in
metrics `Resolver_answers;
let reply = build_reply header question proto data in
Some reply
end
| _ ->
Log.err (fun m -> m "not implemented %a, data %a"
Dns.Packet.Question.pp question
Dns.Packet.pp_data data);
let data = `Rcode_error (Rcode.NotImp, Packet.opcode_data data, None) in
metrics `Resolver_notimp;
let reply = build_reply header question proto data in
Lwt.return (Some reply)
(* we're now doing up to three lookups for each request:
- in authoritative server (Dns_trie)
- in reserved trie (Dns_trie)
- in resolver cache (Dns_cache)
- asking a remote resolver
instead, on startup authoritative (from external) could be merged with
reserved (but that makes data store very big and not easy to understand
(lots of files for the reserved zones)) *)
let handle t proto ip buf =
match Packet.decode buf with
| Error err ->
Log.err (fun m -> m "couldn't decode %a" Packet.pp_err err);
Dns_resolver_metrics.response_metric 0L;
Dns_resolver_metrics.resolver_stats `Error;
let answer = Packet.raw_error buf Rcode.FormErr in
Lwt.return (Option.map (fun r -> 0l, r) answer)
| Ok packet ->
Dns_resolver_metrics.resolver_stats `Queries;
let start = Mirage_mtime.elapsed_ns () in
let header, question, data = packet.Packet.header, packet.question, packet.data in
(* check header flags: recursion desired (and send recursion available) *)
(server t proto ip packet header question data buf >>= function
| Some data -> Lwt.return (Some data)
| None ->
(* next look in reserved trie! *)
match query_server t.reserved question data header proto with
| Some data -> metrics `Reserved_answers ; Lwt.return (Some data)
| None -> resolve t question data header proto) >|= fun reply ->
let stop = Mirage_mtime.elapsed_ns () in
Dns_resolver_metrics.response_metric (Int64.sub stop start);
reply
let send_tls flow data =
let len = Cstruct.create 2 in
Cstruct.BE.set_uint16 len 0 (Cstruct.length data);
TLS.writev flow [len; data] >>= function
| Ok () -> Lwt.return (Ok ())
| Error e ->
Log.err (fun m -> m "tls error %a while writing" TLS.pp_write_error e);
TLS.close flow >|= fun () ->
Error ()
type tls_flow = { tls_flow : TLS.flow ; mutable linger : Cstruct.t }
let rec read_tls ({ tls_flow ; linger } as f) length =
if Cstruct.length linger >= length then
let a, b = Cstruct.split linger length in
f.linger <- b;
Lwt.return (Ok a)
else
TLS.read tls_flow >>= function
| Ok `Eof -> Log.debug (fun m -> m "end of file while reading"); TLS.close tls_flow >|= fun () -> Error ()
| Error e -> Log.warn (fun m -> m "error reading TLS: %a" TLS.pp_error e); TLS.close tls_flow >|= fun () -> Error ()
| Ok (`Data d) ->
f.linger <- Cstruct.append linger d;
read_tls f length
let read_tls_packet f =
read_tls f 2 >>= function
| Error () -> Lwt.return (Error ())
| Ok k ->
let len = Cstruct.BE.get_uint16 k 0 in
read_tls f len
let create ?(cache_size = 10000) ?(udp = true) ?(tcp = true) ?(port = 53) ?tls ?(tls_port = 853) ?edns ?nameservers ?timeout ?(on_update = fun ~old:_ ?authenticated_key:_ ~update_source:_ _trie -> Lwt.return_unit) primary ~happy_eyeballs stack : t Lwt.t =
Client.connect ~cache_size ?edns ?nameservers ?timeout (stack, happy_eyeballs) >|= fun client ->
let server = Dns_server.Primary.server primary in
let stream, push = Lwt_stream.create () in
let reserved = Dns_server.create Dns_resolver_root.reserved Mirage_crypto_rng.generate in
let update_tls _ = () in
let t = { client ; reserved ; server ; on_update ; push ; update_tls } in
let udp_cb ~src ~dst:_ ~src_port buf =
let buf = Cstruct.to_string buf in
metrics `Udp_queries;
handle t `Udp src buf >>= function
| None -> Lwt.return_unit
| Some (_ttl, data) ->
let data = Cstruct.of_string data in
S.UDP.write ~src_port:port ~dst:src ~dst_port:src_port (S.udp stack) data >|= function
| Error e -> Log.warn (fun m -> m "udp: failure %a while sending to %a:%d"
S.UDP.pp_error e Ipaddr.pp src src_port)
| Ok () -> ()
in
if udp then
S.UDP.listen (S.udp stack) ~port udp_cb ;
let tcp_cb flow =
metrics `Tcp_connections;
let dst_ip, dst_port = S.TCP.dst flow in
Log.debug (fun m -> m "tcp connection from %a:%d" Ipaddr.pp dst_ip dst_port) ;
let f = Dns_flow.of_flow flow in
let rec loop () =
Dns_flow.read_tcp f >>= function
| Error () -> Lwt.return_unit
| Ok data ->
metrics `Tcp_queries;
let data = Cstruct.to_string data in
handle t `Tcp dst_ip data >>= function
| None ->
Log.warn (fun m -> m "no TCP output") ;
loop ()
| Some (_ttl, data) ->
let data = Cstruct.of_string data in
Dns_flow.send_tcp flow data >>= function
| Ok () -> loop ()
| Error () -> Lwt.return_unit
in
loop ()
in
if tcp then
S.TCP.listen (S.tcp stack) ~port tcp_cb;
let rec ocaml_cb () =
Lwt_stream.get stream >>= function
| Some (dst_ip, _dst_port, data, wk) ->
metrics `Ocaml_queries;
begin
handle t `Tcp dst_ip data >|= function
| None ->
Log.warn (fun m -> m "no TCP output")
| Some (ttl, data) ->
Lwt.wakeup wk (ttl, data);
end >>= fun () ->
ocaml_cb ()
| None -> Lwt.return_unit in
Lwt.async ocaml_cb;
let tls_cb cfg flow =
let dst_ip, dst_port = S.TCP.dst flow in
TLS.server_of_flow cfg flow >>= function
| Error e ->
Log.warn (fun m -> m "TLS error (from %a:%d): %a" Ipaddr.pp dst_ip dst_port
TLS.pp_write_error e);
Lwt.return_unit
| Ok tls ->
Log.debug (fun m -> m "tls connection from %a:%d" Ipaddr.pp dst_ip dst_port);
let tls_and_linger = { tls_flow = tls ; linger = Cstruct.empty } in
let rec loop () =
read_tls_packet tls_and_linger >>= function
| Error () ->
Lwt.return_unit
| Ok data ->
let data = Cstruct.to_string data in
handle t `Tcp dst_ip data >>= function
| None ->
Log.warn (fun m -> m "no TLS output") ;
loop ()
| Some (_ttl, data) ->
let data = Cstruct.of_string data in
send_tls tls data >>= function
| Ok () -> loop ()
| Error () -> Lwt.return_unit
in
loop ()
in
let update_tls tls_cfg =
S.TCP.listen (S.tcp stack) ~port:tls_port (tls_cb tls_cfg);
in
t.update_tls <- update_tls;
(match tls with None -> () | Some cfg -> update_tls cfg);
t
end

28
unikernel/duniverse/ocaml-dns/mirage/stub/dns_stub_mirage.mli Normal file
View file

@ -0,0 +1,28 @@
(* (c) 2025 Hannes Mehnert, all rights reserved *)
module Make (S : Tcpip.Stack.V4V6) : sig
type t
module H : sig
include Happy_eyeballs_mirage.S with type stack = S.t and type flow = S.TCP.flow
val connect_device : ?aaaa_timeout:int64 -> ?connect_delay:int64 ->
?connect_timeout:int64 -> ?resolve_timeout:int64 -> ?resolve_retries:int ->
?timer_interval:int64 -> ?getaddrinfo:getaddrinfo -> stack -> t Lwt.t
end
val create : ?cache_size:int -> ?udp:bool -> ?tcp:bool -> ?port:int ->
?tls:Tls.Config.server -> ?tls_port:int ->
?edns:[ `Auto | `Manual of Dns.Edns.t | `None ] ->
?nameservers:string list ->
?timeout:int64 ->
?on_update:(old:Dns_trie.t -> ?authenticated_key:[ `raw ] Domain_name.t ->
update_source:Ipaddr.t -> Dns_trie.t -> unit Lwt.t) ->
Dns_server.Primary.s -> happy_eyeballs:H.t -> S.t -> t Lwt.t
(** [create ~cache_size ~edns ~nameservers ~timeout ~on_update server ~happy_eyeballs stack]
registers a stub resolver on the provided protocols [udp], [tcp], [tls]
using [port] for udp and tcp (defaults to 53), [tls_port] for tls (defaults
to 853) using the [resolver] configuration. The [timer] is in milliseconds
and defaults to 500 milliseconds.*)
include Dns_resolver_mirage_shared.S with type t := t
end

5
unikernel/duniverse/ocaml-dns/mirage/stub/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name dns_stub_mirage)
(public_name dns-stub.mirage)
(wrapped false)
(libraries dns dns-server dns-tsig metrics dns_resolver_shared dns-resolver.mirage.shared dns-mirage dns-client-mirage lwt mirage-ptime tcpip mirage-crypto-rng tls-mirage))