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

11
unikernel/duniverse/ocaml-dns/.gitignore vendored Normal file
View file

@ -0,0 +1,11 @@
_build/
*.install
.merlin
*pcap
*out
coverage/
*req
*key
*private
*pem

830
unikernel/duniverse/ocaml-dns/CHANGES.md Normal file
View file

@ -0,0 +1,830 @@
### v10.2.2 (2025-10-20)
* Expose a module type insotead of a module for Dns_mirage_resolver_shared.S,
and move it to dns-resolver.mirage.shared ocamlfind library (#396 @dinosaure)
* Expose dns-resolver.shared with Dns_root, Dns_metrics, Dns_block as a public
ocamlfind library (#396 @dinosaure)
* Mention RFC9460 in README (#397 @nickbetteridge)
### v10.2.1 (2025-09-25)
* dns-stub: provide a shared interface with dns-resolver.mirage
(named Dns_resolver_mirage_shared) (#394 @hannesm)
### v10.2.0 (2025-08-01)
* dns: add support for extended DNS error (RFC 8914) (#374 @hannesm)
* dns-resolver: instead of querying a single (ip, query), query up to three
(#375 @reynir @hannesm)
* dns-cache: fix metrics (#377 #379 @hannesm @reynir)
* dns-cache: support RFC 8020, if there's a NXDomain, nothing is underneath
(#390 @hannesm)
* dns-trie: canonicalize domain name before insertion, reducing allocations
(#388 @reynir)
* dns-server: make number of tries in cache (for IXFR) configurable
(#387 @reynir)
* dns-resolver: add metrics (#376 #378 @hannesm @reynir)
* dns-resolver: allow update to the primary, and the TLS state (#383 @reynir)
* dns-resolver: heuristics to detect blocked domains (#380 @reynir)
* dns-resolver: report extended DNS error when blocking
(#385 #384 @reynir @hannesm)
* dns-resolver: implement opportunistic TLS (#389 @hannesm)
* dns-resolver: support query name minimisation (RFC 9156) (#391 @hannesm)
* dns-resolver: features via flags (#392 @hannesm)
### v10.1.0 (2025-05-24)
* dns-mirage-resolver: adapt API to prepare for DoH (#373 @dinosaure @PizieDust
@reynir @hannesm)
* resolver: support DNSSEC
- #372 @reynir @hannesm
- #361 @reynir @hannesm
* dns: support SVCB and HTTPS resource records (RFC 9460, #359 @nickbetteridge)
* dns-cli: avoid deprecated cmdliner values (#367 @hannesm, fixes #366),
add app/resolver (#366)
* resolver: add further tests, fix the loop of a cyclic NS (#368 @hannesm)
### v10.0.0 (2025-02-07)
* dns-certify: use a pair instead of two separate arguments for the dns-key
(#357 @hannesm)
* add KSK 2024 (#358 @hannesm)
* update to mirage-crypto 1.2.0 API changes (#362 @hannesm)
* use dune variants, avoid functors (#363 @hannesm)
### v9.1.0 (2024-10-22)
* Dns.Dnskey: provide to_string and name_key_to_string (@hannesm, @dinosaure,
#356 - fixes #355)
* BREAKING: Dns.Dnskey remove pp_name_key (unused, irritating, #356)
* BREAKING Dns_certify_mirage.retrieve_certificate use separate dns_key_name
and dns_key arguments, avoid string decoding in that function (#356)
### v9.0.1 (2024-09-27)
* dns-client-miou: use String.get_uint16_be instead of String.get_int16_be
(#354 @dinosaure)
### v9.0.0 (2024-08-26)
* Remove `Cstruct.t` and use `string`/`bytes` (@hannesm, @dinosaure, @palainp, #351)
* Add a Miou implementation of `ocaml-dns` (@dinosaure, @hannesm, #352)
### v8.0.0 (2024-05-29)
* dns-client (lwt, mirage): depend on happy-eyeballs-{lwt,mirage} instead of
duplicating the code. This requires happy-eyeballs 1.1.0, and now the same
Happy_eyeballs_{lwt,mirage}.t is used for DNS (connecting to the nameserver)
and for the application (connecting to a remote host)
(@dinosaure @hannesm #346)
* server: improve API documentation (@hannesm
1a80bd4080e597687152cf351d035ef5f00c5946
000ae02dfc477d91c05891e3891a447328ae448a)
* server: add a `packet_callback` to `handle_packet` and `handle_buf`
(@RyanGibb #349)
* server: expose `update_data` (@RyanGibb #350)
* resolver: b root name server IP change (@hannesm #348)
* secondary server [mirage]: avoid infinite loop in connect (avoids SYN floods)
(@hannesm @reynir #347)
* resolver, dns_zone: use consistently `Log` instead of `Logs` (@palainp #342)
### v7.0.3 (2023-06-15)
* dns-client-lwt, dns-client-mirage: adapt to happy-eyeballs 0.6 changes,
also avoid unnecessary recursion (#340 @hannesm, @reynir)
### v7.0.2 (2023-06-13)
* dns-server: for secondary servers use the right zone transfers and keys, fixed
in #339 by @hannesm
* dns: add support for null record (arbitrary binary data) (#338 @RyanGibb)
### v7.0.1 (2023-02-27)
* dns-server.zone: fix parsing of zone files that contain tokens such as
`N` `S` `E` `W` `-<number>` `<number>m` `DS` `CAA` `TYPE<number>`.
There was an inconsistency in the Dns_zone_parser.keyword_or_number rule.
Test cases have been added, a comment has been added to the
Dns_zone_lexer.kw_or_cs function. Discovered while updating the primary NS
with an entry of "e.ns", fixed in #336 @hannesm
Broken since the early days of this development
### v7.0.0 (2023-02-16)
* BREAKING: dns-client is split into 3 packages: dns-client-lwt,
dns-client-mirage. If your dune file contains dns-client.lwt, use
dns-client-lwt now. If your dune file contains dns-client.mirage, use
dns-client-mirage now (#331 @hannesm)
* update to mirage-crypto 0.11.0 API changes and tls 0.16.0 packaging changes
(#331 @hannesm)
* dns-client.resolvconf: add line number to parser (#334 @hannesm, inspired by
#328 @bikallem)
* dns-client.resolvconf: allow zone idx (RFC 4007) for IPv6 entries
(#334 @hannesm, inspired by #328 @bikallem)
* dns-server.zone: allow zone files without final newline (add a newline to the
buffer if the last character is not \n) (#333 @hannesm)
* dns-client-{lwt,mirage}: do not log when the resolver closed the connection,
but there are no pending requests (#332 @reynir)
* dns-certify: in Dns_certify_mirage use X509.Private_key.of_string, the
behaviour when both key_data and key_seed is provided changed, and leads to
an exception now (#330 @hannesm)
### v6.4.1 (2022-12-02)
* dns-client: adapt to happy eyeballs 0.4.0 (#329 @reynir @hannesm)
* dns-resolver: dnssec validation is optional via a labeled parameter ~dnssec
passed to Dns_resolver.create (#325 @hannesm)
* upgrade to dune 2 (#327 @reynir)
### v6.4.0 (2022-10-24)
* dns-client: demote log level of response to debug (#317 @hannesm)
* dns-client: use DNS-over-TLS for uncensoreddns.org only (#320 @hannesm)
* API: dns-client: connect returns the protocol (UDP/TCP), allowing mixed UDP
and TCP namerservers being used (#322 @hannesm)
* dns-client-mirage: allow hostname in authenticator, improve error message and
documentation (#319 #322 @hannesm)
* dns-client-mirage: support UDP nameservers as "udp:<IP>" in
nameserver_of_string (#322 @reynir @hannesm)
* API: dns-client, dns-stub, dns-resolver: ?size is now ?cache_size (#322
@hannesm, suggested by @reynir)
### v6.3.0 (2022-07-26)
* dns-server: demote log level for various messages (#309 @hannesm)
* dns-zone: add additional glue: only add if authoritative for nameserver domain
(#309 @hannesm)
* BUGFIX: dns-trie: fix lookup when delegations are present, add tests
(#309 @hannesm)
* ozone: be more explicit when showing errors (#311 @psafont)
* dns: avoid polymorphic comparison (#314 @hannesm, reported by @RyanGibb)
* FEATURE: dns: add LOC resource records (RFC 1876) (#310 @RyanGibb)
### v6.2.2 (2022-04-08)
* BUGFIX dns-trie: the collect_entries function jumped over zone boundaries.
This lead dns-primary-git to detect changes in zones with subdomains delegated
to the same name servers, leading to dropping of zones (#308 @hannesm,
reported by @reynir)
* BUGFIX dns-server.text: add address glue records for name servers out of the
authority of this server. This is crucial since dns-primary-git supports
such glue records to notify these about zone updates (#307 @hannesm)
* New functionality in dns-zone (dns-server.zone): decode_keys, decode_zones,
and decode_zones_keys copied from dns-primary-git for reusing in other
projects (#307 @hannesm)
### v6.2.1 (2022-04-01)
* BUGFIX dns: RTYPE is 16 bit, previously 15 bit were accepted, also check for
being positive (#304, @hannesm @reynir)
* dns-server: dns-trie zone check no longer enforces that the nameserver is in
the nameserve set of the zone, this enables hidden primary setups (fixes #303,
@hannesm)
### v6.2.0 (2022-03-09)
* New opam package "dnssec" implementing dnssec validation (@reynir @hannesm)
* Use custom log sources, not the default one from Logs (@reynir @hannesm)
* BUGFIX dns-resolver: unlisten on the listen port, not the packet src_port
(#290 @hannesm)
* dns-resolver: add IPv6 addresses of root servers (fixes #262, @hannesm)
* dns-resolver: preliminary support for DNSSec (#262 @reynir @hannesm)
* dns-client: when /etc/resolv.conf modifies, update the list of nameservers
(#291 @hannesm @reynir)
* dns-cli: update to cmdliner 1.1.0 (#300 @hannesm)
* dns-client-mirage: add module type and nameserver_of_string and connect to
allow creation of a MirageOS device (#297 @dinosaure)
* dns-cache: add size, capacity, and weight to metrics (#301, fixes #299,
@hannesm)
### v6.1.4 (2022-01-11)
* dns-client-{mirage,lwt}: avoid multiple simultaneous connection attempts
to the same resolver. Now, before a connection is initiated, a Lwt_condition
is put into the client state which subsequent resolution requests wait for
(#285 @hannesm, review by @reynir, reported by @kit-ty-kate in
roburio/http-lwt-client#8)
### v6.1.3 (2021-12-17)
* dns-mirage: use tcpip >= 7.0.0 instead of deprecated mirage-stack and
mirage-protocols (#283 @dinosaure)
### v6.1.2 (2021-11-27)
* dns: avoid exceptions when decoding resource records (#282 @reynir @hannesm)
### v6.1.1 (2021-11-19)
* dns-client: by default, do not send EDNS (#280 @reynir @hannesm)
* BREAKING dns-certify.mirage: treat key_data as base64 encoded data
(#280 @reynir @hannesm)
* mirage: update to mirage-protocols 6.0.0 API (use TCP.listen / UDP.listen)
resolver: unlisten on UDP port after response has been received (#280 @reynir
@hannesm)
### v6.1.0 (2021-11-10)
* BUGFIX dns-client: avoid exception on TLS handshake failure (reported by @reynir)
* FEATURE dns-client: optionally send a edns in the query (reported by @orbitz #276)
* dns-client: combine send and recv, avoid resource leaks on timeout
### v6.0.2 (2021-10-27)
* dns: remove astring dependency (@hannesm)
* dns-client: adapt to happy-eyeballs 0.1.0 API (#274 @hannesm)
* dns-client: avoid List.concat_map, make it available on OCaml 4.08 (@hannesm)
### v6.0.1 (2021-10-25)
* remove rresult dependency (#273 @hannesm, review by @reynir)
### v6.0.0 (2021-10-19)
* use Cstruct.length instead of deprecated Cstruct.len
* avoid deprecated fmt functions
* dns-client: send EDNS tcp keepalive with a timeout of 120 seconds if TCP
is used (@reynir @hannesm)
* BREAKING dns: Rr_map.get_ttl is now ttl, and takes 'a key -> 'a -> int32
(instead of b -> int32), Rr_map.with_ttl now is 'a key -> 'a -> int32 -> 'a
(instead of b -> int32 -> b) (#264 @hannesm)
* BREAKING dns: Rr_map.A now uses Ipaddr.V4.Set.t, Aaaa uses Ipaddr.V6.Set.t
(requires ipaddr 5.2.0) (#268 @hannesm)
* BREAKING dns.cache: type entry now is polymorphic ('a entry = `Entry of 'a ...)
(instead of `Entry of Rr_map.b) (#263 @reynir and @hannesm)
* BREAKING dns.cache: use a LRU.F.t instead of LRU.M.t (#256 @hannesm)
* dns.cache: provide get_or_cname and get_any function (#256 #257 @hannesm)
* BUGFIX dns.cache: update if time to live of cached entry expired
(reported in #259 by @dinosaure, fix by @reynir and @hannesm)
* dns-client support DNS-over-TLS (RFC 7858): the type io_addr is now a variant
of `Plaintext (Ipaddr.t * int) or `Tls (Tls.Config.client * Ipaddr.t * int)
By default, ca-certs (ca-certs-nss for MirageOS) are used as trust anchors,
and the certificate is expected to contain the IP address of the resolver.
The default resolver (anycast.uncensoreddns.org) certificate is verified by
hostname, since the let's encrypt certificate does not include an IP address
in SubjectAlternativeNames (#270 @hannesm)
* BREAKING dns-client.mirage.Make is extended by a Mirage_clock.PCLOCK
(#270 @hannesm)
* BREAKING dns-client, dns-stub: use Dns.proto instead of custom [`TCP|`UDP]
(#266 @hannesm)
* dns-client: use a `mutable timeout_ns : int64` instead of
`timeout_ns : int64 ref` (#269 @hannesm)
* BREAKING dns-client: remove `?nameserver` from
getaddrinfo/gethostbyname/gehostbyname6/get_resource_record - if a custom
nameserver should be queried, a distinct Dns_client.t can be constructed
(#269 @reynir and @hannesm)
* dns-client: multiplex over TCP connections (#269 @reynir and @hannesm)
* dns-client: use happy-eyeballs to connect to all nameservers from
/etc/resolv.conf sequentially (lwt and mirage) (#269 @reynir and @hannesm)
* BREAKING dns-client remove UDP support from lwt (#270 @reynir and @hannesm)
* BREAKING dns-resolver.mirage add DNS-over-TLS support (@reynir @hannesm)
* BREAKING dns-resolver remove "mode" from codebase, default to recursive
(a stub resolver is available as dns-stub) (#260 @hannesm)
* dns-resolver: use dns.cache instead of copy in Dns_resolver_cache
(#256 @hannesm)
* BUGFIX dns-resolver: fix responses to queries (reported in #255 by @dinosaure,
fix in #258 by @reynir and @hannesm)
* dns-resolver: refactor and cleanup code, remove statistics, remove dead code
(#258 #261 @reynir @hannesm)
* dns-stub: reconnect to resolver, resend all outstanding queries
(#269 @hannesm)
### v5.0.1 (2021-04-22)
* dns-certify: adapt to X.509 0.13.0 API changes (#254 @hannesm)
### v5.0.0 (2021-04-14)
* IPv6 support for client and server (Mirage, Unix, Lwt) (#249 #252 @hannesm)
This results in breaking changes, especially in the Mirage boilerplate,
since now a Mirage_stack.V4V6 is needed instead of a Mirage_stack.V4.
* dns-certify: support EC private keys, now that X509 0.12.0 supports them
(#252 @hannesm)
### v4.6.3 (2021-01-11)
* dns-server: wildcard support (#248 @hannesm)
* dns-certify: only dnskey needs to be a valid hostname (#247 @hannesm),
allow [`raw] Domain_name.t in signing requests (#249 @hannesm)
* dns-client.resolvconf provides a parser for /etc/resolv.conf (#240 @hannesm),
used in dns-client.unix and dns-client.lwt (#241 @hannesm)
* BUGFIX dns-cli notify keys are accepted in namekey_c (#242 @hannesm)
* BUGFIX dns: revise TXT resource record encoding and storage (for DKIM usage)
previously RR were cut at 255 characters (fixes #244, #245 @hannesm)
* BUGFIX dns: decoding of TSIG packets (#250 @hannesm)
* BUGFIX ocertify: pem file may contain a certificate chain (#246 @hannesm)
### v4.6.2 (2020-08-07)
* fixes for 32 bit support (OCaml-CI now runs on 32 bit) in test suite and EDNS
* dns: fix EDNS flag decoding and encoding (16 bit only)
reported in #234 by @dinosaure, fix #235 by @hannesm
* dns-server: reply to unsupported EDNS version (not 0) with
rcode=16 (BadVersOrSig), as required by RFC 6891, and tested by DNS flag day
issue #166, fix in #237 by @hannesm
### v4.6.1 (2020-06-20)
* dns-client.lwt, dns-client.unix: initialize RNG (#232 @hannesm)
* dns-cli: compatible with mirage-crypto-rng 0.8 (#232 @hannesm)
### v4.6.0 (2020-06-02)
* dns: bugfix for name compression when encoding names at offset > (2 ^ 14) - 1
(#225 @hannesm)
* dns: allow unknown DNSKEY algorithm, TLSA certificate usage, selector,
matching type, SSHFP algorithm and typ. This makes the DNS library
future-proof for when new values are assigned (#228 @hannesm)
* dns: enforce a max_rdata_length for all resource records. This ensures that
when a resource record is loaded into the server, it can be extracted via a
DNS query and transferred via IXFR/AXFR
(#230 @hannesm, reported in #229 via #225)
* AXFR: encode and decode support for AXFR transfers spanning multiple messages
(#225 @hannesm)
* client: do not initialize the Mirage_crypto_rng in the library, initialize
the RNG in applications (#227 @hannesm)
* certify: provide cert_matches_csr function and use it (cleans up partial
ad-hoc matches which did not verify that all hostnames of the CSR are present
in the certificate) (#226 @hannesm, reported in #224)
### v4.5.0 (2020-04-23)
* client: add timeout for DNS requests (defaults to 5 seconds, as in resolv.h).
* dns-client-mirage functor requires a Mirage_time.S implementation (changes API).
Update your code as in this commit:
https://github.com/roburio/unikernels/commit/201e980f458ebb515298392227294e7b508a1009
#223 @linse @hannesm, review by @cfcs
### v4.4.1 (2020-03-29)
* client: treat '*.localhost' and '*.invalid' special, as specified in RFC 6761
and let-localhost-be-localhost. #221 @hannesm, review by @cfcs (who reported
#220, original report roburio/openvpn#28)
### v4.4.0 (2020-03-13)
* dns-stub, a new opam package, is a stub resolver #209 @hannesm, review by
@cfcs
* embed IP address of recursive resolver only once #214 @hannesm, fixes #210,
review by @cfcs
* Dns_trie.lookup returns NotAuthoritative if no SOA is present #217 @hannesm,
review by @cfcs
* Secondary server is looked up in trie properly (may be in another zone, which
primary is not authoritative for the other zone) #217 @hannesm, review by
@cfcs
* new function Dns.Dnskey.pp_name_key #218 @hannesm, review by @cfcs
* dns-certify uses new ACME protocol (where the intermediate certificate is
part of the issuance process) #219 @hannesm, review by @cfcs
* dns-certify/dns-tsig/dns-cli: use mirage-crypto #219 @hannesm, review by @cfcs
### v4.3.1 (2020-01-21)
* server (#207, @hannesm, review by @cfcs)
- provide return code and request vs reply statistics
- BUGFIX update only increase SOA.serial of zones which changed (including regression tests)
- expose Authentication.access_granted, Authentication.zone_and_operation, Authentication.operation_to_string
* dns (#207, @hannesm, review by @cfcs)
- expose Rcode.to_string for metrics above
### v4.3.0 (2020-01-09)
* dns
- BUGFIX Name_rr_map.remove_sub remove empty maps (#205, @hannesm)
* server (#205, @hannesm)
- authentication refactoring: given a key by its Domain_name.t (name._op.zone),
this is valid for operation `op` for `zone` and subdomains thereof. The
operation may be one of `update`, `transfer`, and `notify`, with an `update`
key being valid for any operation, and a `transfer` key valid for
notifications as well
- Primary.create has a new optional argument `unauthenticated_zone_transfer`
to allow unsigned zone transfer requests
- the type `Authentication.a` and value `Authentication.tsig_auth` are removed
- Primary.create and Secondary.create no longer have the `a` argument
- authentication uniformly uses `Authentication.access`
- handle_update / handle_axfr_request / handle_ixfr_request are provided and
under test
- tests for authentication and handle_question
* client (#204, @hannesm)
- introduce get_resource_record which is the same as getaddrinfo, but returns
the error as variant instead of [ `Msg of string ]
- BUGFIX follow_cname handles replies with a cname and no data for the alias
appropriately (and a regression test has been developed)
### v4.2.0 (2019-11-20)
* dns
relax resource record parsing, don't require the name to be a hostname it
used to be strict on the parser, but that violates RFC 2181 Sec 11
> The DNS itself places only one restriction on the particular labels that can
> be used to identify resource records. That one restriction relates to the
> length of the label and the full name.
previous code had already exceptions for DNSKEY, TXT, CNAME, TLSA (service
name or host name), SRV (service name) (#201 @hannesm)
* dns-certify
BUGFIX provide signing_request to create certificate signing requests,
now including all hostnames in subjectAlternativeName (previously, the
common name was left out which is not what RFC 5280 recommends)
(#198 @hannesm)
* dns-server.mirage
- provide metrics (using the metrics library) of connections and actions (#199 @hannesm)
- BREAKING the `on_update` callback passed to `primary` has more arguments (#200 @hannesm)
`~authenticated_key` : [`raw] Domain_name.t option
`~update_source` : Ipaddr.V4.t
* dns-server
- BREAKING handle_buf: returns Domain_name.t of key used for authentication (#200 @hannesm)
- BUGFIX handle_update: allow modification of multiple zones at once
still, each name must be within the zone given in Query.name (which
is authenticated against), allowing hidden let's encrypt secondary
for multiple zones, using a keys authorized for the root zone (#200 @hannesm)
- BUGFIX Dns_trie.zone returns the zone (Domain_name.t * Soa.t) of a
provided Domain_name.t, it now works for non-existing names, tests
were added (#200 @hannesm)
* dns-mirage: log packets on debug level instead of info (#198 @hannesm)
### v4.1.0 (2019-11-01)
* Client improvements (#191 #192 @olleolleolle @linse @cfcs @hannesm in marrakesh September)
- new sublibrary dns.cache providing an LRU cache, mostly copied from resolver
- it uses a LRU cache now (defaults to 32 entries) from dns.cache
- since #195 a mutable LRU.M.t
- tests were added
- Dns_client_flow has been migrated to Dns_client
- various code cleanups (extracted functions), better naming, improved docstrings
- Uflow is now known as Transport
- requires a monotonic clock on creation
* adapt to x509 0.8.0 API changes (#193 @hannesm)
* adapt to newer MirageOS interfaces (#196 @hannesm)
### v4.0.0 (2019-08-15)
* Switch to uDNS implementation, developed from scratch since 2017, primarily
focusing on a recursive caching resolver. The server part supports dynamic
updates (RFC 2135), transaction authentication with HMAC (RFC 2845), zone
transfer (RFC 5936), incremental zone transfer (RFC 1995), change
notifications (RFC 1996) amongst others.
* The core library uses a GADT for resource record sets, where the key (resource
record type) specifies the value type.
* The API does not leak exceptions, but uses the result type where appropriate.
* TCP transport is well supported and used widely (client uses it by default)
* Naming: client is a DNS client, resolver is the recursive resolver library
* The DNS library is split into the following opam packages and sublibraries:
- `dns` - the core library
- `dns-tsig` - transaction signatures
- `dns-cli` - command line utilities (odig, onotify, ..)
- `dns-client` - pure client implementation
- `.unix` - DNS client using the Unix module for communication
- `.lwt` - DNS client using Lwt_unix for communication
- `.mirage` - DNS client using MirageOS for communication
- `dns-certify` - helpers for let's encrypt provisioning
- `.mirage` - certificate provisioning with MirageOS
- `dns-mirage` - generic MirageOS communication layer
- `dns-server` - pure server implementation
- `.mirage` - MirageOS primary and secondary server
- `.zone` - zone file parser (mostly taken from the 1.x series)
- `dns-resolver` - pure recursive resolver implementation
- `.mirage` - MirageOS recursive resolver
* Only OCaml 4.07.0 and above are supported
* Multicast DNS has been dropped for now
* A client using async from JS has not been implemented yet
* The default recursive resolver, used by the client implementations, is
uncensoreddns.org
### v1.1.3 (2019-07-16)
* Support domain-name.0.3.0 interface, which bumps the minimum
OCaml version supported to 4.04 due to that dependency (@avsm)
* Fix tests with recent OCaml (use mmap/bigarray-compat) (@avsm)
### v1.1.2 (2019-02-28)
* Mirage: adapt to mirage-kv 2.0.0 interface (#156 by @samoht)
### v1.1.1 (2019-01-25)
* Support Base64.3.0.0 interface (@avsm)
### v1.1.0 (2019-01-05)
* Improve parsing robustness with:
- invalid pointers in packets
- taking total packet size limitations into account
- handling unknown opcodes gracefully without an exception
Work done by @Willy-Tan in #154.
* Port build from jbuilder to Dune (#155 #152 #153 by @paurkedal @samoht)
* Update opam metadata to the 2.0 format.
### v1.0.1 (2017-11-06)
* dns-lwt-unix: add missing dependency on cmdliner (#145 by @avsm)
* async: close reader and writer properly (#147 by @1yefuwang1)
* fix build with OCaml 4.06 (and -safe-string) (#148 by @djs55)
### v1.0.0 (2017-06-23)
Rearrange the `opam` packages to eliminate optional dependencies,
and have explicit and separate packages for the Lwt, Async and
Mirage implementations. The `opam` and `ocamlfind` layouts now
have the same names:
- `dns`: the core package
- `dns-lwt`: Lwt implementation
- `dns-lwt-unix`: Lwt Unix, including servers
- `dns-async`: Async implementation (this currently uses Unix)
This layout is not compatible with the older releases which had
ocamlfind subpackages, so an upper bound will be needed in OPAM
for those. However, porting should be relatively straightforward
to the new release, and in return your users will not have to deal
with specifying a myriad of optional dependencies in OPAM.
- This release also ports the build to use Jbuilder, which speeds
it up quite a bit and removes boilerplate files.
- Depend on Lwt 3.0.0 interfaces, including the blocking bind.
### v0.20.2 (2017-06-01)
* Depend explicitly on `Ipaddr_unix` and `Uri_services` modules.
* Add a basic server example which has a static lookup table and
does not use the Trie structure. It is in [examples/server.ml].
### v0.20.1 (2017-05-16)
* Port to lwt >= 3.0 (#136, @djs55)
### v0.20.0 (2017-03-23)
* Remove the `Dns.Buf` module that formerly wrapped Cstruct, now that the
latter is a mature library.
* Add an `?alloc` optional argument to functions that would formerly accept
a `Dns.Buf`. By default, this allocates a single page, but consumers of
this library can override it in order to supply their own allocation
logic (e.g. a pool allocator).
* Remove dependency on `io-page` to follow the `Dns.Buf` removal.
All these changes were part of #132 by @hannesm.
### v0.19.1 (2017-02-15)
* Use topkg instead of oasis (#126
* Do not reverse the order of resource records in the parser (#109 by @djs55)
* Restrict to OCaml 4.03.0+.
* Fix bug parsing pointers to pointers to DNS name labels (#129 by @yeungda-rea)
### v0.19.0 (2017-01-20)
* Port to MirageOS 3 module types.
* Remove runtime dependency on PPX from META file
* Bugfixes and improvements for async backend compilation (#100 by @vbmithr).
### v0.18.1 (2016-04-17)
* Clear AA bit on requests, as some servers will drop these otherwise
### v0.18.0 (2016-03-12)
* Remove dependency on camlp4, switch to ppx
### v0.17.0 (2016-03-11)
* This library now depends on the `hashcons` package rather than
containing a fork of it. Now that there is no LGPL (+ linking exception
code left, clarify that the license is ISC. Previously the `opam`
file claimed a mixture of licenses (#86 via @djs55)).
* Add multi-distro Travis testing support.
* Library now depends on OCaml 4.02+
### v0.16.0 (2015-10-21)
* Change source port randomization to avoid overflow in the port range
(#83 from @yomimono).
Improve mDNS support (#82 from Luke Dunstan):
* Add `Dns.Probe` to implement the unique name probing portion of mDNS.
* Expose the `Dns.Name.Set` construct.
* Added a functor `Mdns_resolver_mirage.Chain` that is intended to compose
an mDNS resolver with a normal DNS resolver such that `*.local` is resolved
via mDNS and everything else is done with DNS.
* Changed `Dns.Query` to not respond to queries for classes other than IN.
* Fixed mDNS legacy responses to use TTL <= 10 sec
* Fixed mDNS responses to use RD=0.
### v0.15.3 (2015-07-30)
* Fix regression in 0.15.2 which prevented `Dns_server_unix.listen` from
answering more than one query (#80 from Magnus Skjegstad)
### v0.15.2 (2015-07-04)
* Fix incorrect mirage dependency on tcpip
* Improve clarity and formatting of Lwt use
* Remove camlp4 dependency
* Now requires lwt >2.4.7
### v0.15.1 (2015-07-02)
* Fix critical DNS resolver timeout bug causing unexpected exceptions
### v0.15.0 (2015-05-14)
* Name.domain_name has been renamed to Name.t and is now abstract
* Name.domain_name_to_string has been renamed to Name.to_string
* Name.string_to_domain_name has been deprecated for Name.of_string
* Name.parse_name has been renamed to Name.parse
* Name.marshal_name has been renamed to Name.marshal
* Name.hashcons_charstring has been renamed to Name.hashcons_string
* Name.hashcons_domainname has been renamed to Name.hashcons
* Name.canon2key has been renamed to Name.to_key
* Name.for_reverse has been replaced by Name.of_ipaddr
* Name.of_ipaddr accepts a Ipaddr.t and produces a name suitable for reverse DNS
* We now require >= ipaddr.2.6.0 to support Name.of_ipaddr
* uri 1.7.0+ is now required for its uri.services service registry
* Named service lookups are now supported in zone files
* Dig string serializations are now in Dns.Dig (#61 from Heidi Howard
### v0.14.1 (2015-03-29)
* Reduce namespace pollution in `name.ml` to avoid breaking with Cstruct 1.6.0+.
* Add a `Dns_server.compose` function to make it easier to build
resolution pipelines (#58).
* Add a `Dns_server_mirage` functor (#55).
* Add `Dns_resolver.resolve_pkt` to support custom query packets (#49).
* Split out the experimental Async_resolver into a `Async_kernel` and
Unix libraries. This introduces the `dns.async-unix` library.
### v0.14.0 (2015-01-29)
* Renamed `Packet.QM` to `Packet.Q_Normal` and `QU` to `Q_mDNS_Unicast` for
clarity and added more detailed doc comments. Added constructor function
`Packet.make_question` for convenience. (#41
* Support `io-page` 1.3.0+ interface. (#40
### v0.13.0 (2015-01-26)
* Add support for multicast DNS (RFC6762) in the trie. (#35 from Luke Dunstan
* mDNS doesn't use SOA nor delegation (RFC 6762 section 12), so some minor changes
to Trie are required to handle this.
* mDNS doesn't echo the questions in the response (RFC 6762 section 6), except
in legacy mode, so a `bool` argument was added to `Query.response_of_answer`.
* `Query.answer` still exists but now `Query.answer_multiple` is also available
for answering multiple questions in one query to produce a single answer
(RFC 6762 section 5.3). One caveat is that responses may exceed the maximum
message length, but that is not really specific to mDNS. Also, in
theory multiple questions might require multiple separate response
messages in unusual cases, but that is complicated and the library
does not deal with that yet.
* `Query.answer_multiple` takes an optional function to allow the caller
to control the `cache-flush` bit. This bit is only set for records
that have been "confirmed as unique". Using a callback requires
minimal changes here but puts the burden of maintaining uniqueness
state elsewhere.
* `Query.answer_multiple` takes an optional function to filter the
answer, in order to support "known answer suppression" (RFC 6762
section 7.1). Again, using a callback requires minimal change to the
core, but later on the mDNS-specific known answer suppression logic
could move into the `Query` module if that turns out to be simpler.
* A query for `PTR` returns additional records for `SRV` and `TXT`, to
support efficient service discovery.
* `Trie.iter` was added to support mDNS announcements.
* Switch to `Bytes` instead of `String` for eventual `-safe-string` support.
* Partially remove some error printing to stderr. (#36
Unit tests were added for some of the changes above, including a test-only
dependency on `pcap-format`.
### v0.12.0 (2014-12-24)
* Parse and marshal the mDNS unicast-response bit (#29).
* Add OUnit tests for `Dns.Packet.parse` using `pcap` files.
* Fix parsing of `SRV` records (#30).
* Use `Bytes` instead of `String` for mutable buffers.
* Switch to `Base64` v2, which uses `B64` as the toplevel module name
to avoid linking conflicts with other community libraries.
### v0.11.0 (2014-11-02)
* Do not depend in Io_page; instead `Dns.Buf.create` now accepts an
optional `alloc` parameter to use a custom allocator such as `Io_page`.
* Add Async DNS resolver modules from @marklrh (#22).
* Add a Dns_resolver_mirage.Static for a static DNS interface.
### v0.10.0 (2014-08-20)
* Add `Dns_resolver_mirage` module for making stub resolution requests
using the Mirage module types.
* `Dns.Resolvconf` parses `/etc/resolv.conf` entries using `Ipaddr.t`
instead of `string` values now.
* Adapt `Dns_resolver` and `Dns_resolver_unix` to use `Ipaddr.t` more.
* Improve `mldig` to use `Ipaddr` more and add more RR printing to
match the conventional `dig` tool behaviour.
* Expose `Dns.Packet.Not_implemented` exception rather than a pattern
match failure.
* Depend on external `Base64` package instead of bundling one inside
the `Dns` packed module.
* Add a local `opam` file for easier pinning.
* Add an `examples/` directory with a DNS forwarder sample (#21).
### v0.9.1 (2014-07-29)
* Fix file descriptor leak in resolver (#15, #16) by expanding `commfn`
with a cleanup function.
### v0.9.0 (2014-06-16)
* Ensure that all `Dns.Buf.t` buffers are page-aligned, via `Io_page`.
* Remove a Unix dependency that snuck into the `Dns_resolver` portable
core, by adding a timeout argument to the `commfn` type.
* Improve ocamldoc in `Dns_resolver_unix`.
### v0.8.1 (2014-04-19)
* Add `process_of_zonebufs` to handle multiple zone files.
* Adapt `Dns_server_unix` to expose multiple zonebuf functions.
### v0.8.0 (2014-02-21)
* Use `Ipaddr.V6` to restore IPv6/AAAA RR support.
* `process_query` now takes an output buffer so it doesn't have to
overwrite the input buffer it just parsed.
* Add Travis continuous integration scripts.
* Regenerate with OASIS 0.4.1
* Split the `dns.lwt` into a portable `dns.lwt-core` that doesn't
require Unix (from which a Mirage version can be built). The only
change to existing applications is that Unix-specific functions
have shifted into `Dns_resolver_unix` or `Dns_server_unix`, with
the module types for `PROCESSOR` and `CLIENT` unchanged.
### v0.7.0 (2013-08-26)
* Add path argument to `Resolv_conf in Dns_resolver.config.
* `Dns_resolver.t` is now a record type rather than a first-class module.
* Fix `mldig` server and port options.
* Change `Zone.load_zone` to `Zone.load` and make it functional over `Loader.db`.
* Use `Ipaddr.V4.t` addresses in favor of Cstruct or Uri_IP representations.
* Fix `RRSIG` signed type to be of the answer rather than the question.
* Fix `ANY` queries.
* Add `Buf` to provide a nickname for `char Bigarray`s.
* Change `Packet.{parse,marshal}` to use Buf.t rather than exposing Cstruct.t
* Change `Packet.parse` to remove name map parameter
* Factor protocol modules into `Protocol` with default DNS implementations
* Add first-class `PROCESSOR` module to `Dns_server` for contextual
protocol extensions
* Change `Dns_server.listen` to accept processor
* Rename `Dns_server.listen_with_zonebuf` and `Dns_server.listen_with_zonefile`
to `Dns_server.serve_with_zonebuf` and `Dns_server.serve_with_zonefile` resp.
* Add `processor_of_process`, `process_of_zonebuf`,
`eventual_process_of_zonefile`, and `serve_with_processor` to `Dns_server`
* Rename `Query.query_answer` to `Query.answer`
* Add `Query.response_of_answer` and `Query.answer_of_response`
* Move `Dns_resolver.build_query` to `Query.create`
* By default, DNS packet IDs are randomly generated with Random
* `Dns_resolver` now supports simultaneous resolver protocol requests
* Fix reversed multiple TXT parse bug
* Move DNSSEC implementation to <//github.com/dsheets/ocaml-dnssec>
### v0.6.2 (2013-02-13)
* Fix Lwt compilation after switch to `Dns.Names.Map` instead of `Hashtbl`.
* Fix Lwt Makefile detection (`Lwt.unix` instead of `Lwt.ssl`
### v0.6.1 (2013-02-12)
* Improve performance of packet marshalling.
* Add a Mirage `Dns_server` subpackage.
### v0.6.0 (2012-12-31)
* (Very) experimental DNSSEC support.
* Use cstruct-0.6.0 API.
* Improve robustness of `Dns_resolver`.
* Add EDNS0 support for larger packet sizes.
### v0.5.2 (2012-11-28)
* Fix the server interface to be fully asynchronous.
* Correct `q_type`/`q_class` arguments being ignored in the Lwt
Dns_resolver (from Pierre Chambart).
### v0.5.1 (2012-10-05)
* Remain compatible with OCaml-3.12.1 with the more verbose
first-class module syntax.
### v0.5.0 (2012-09-29)
* Add mldig as a full(ish)-featured dig clone, with similar
output format.
* Add `Dns.Resolvconf` for parsing `/etc/resolv.conf` files on
POSIX hosts.
* Move the Lwt bits (resolver, server, cmdline client) into
a separate directory, to follow the Cohttp convention.
### v0.4.0 (2012-09-18)
* Initial public release.

23
unikernel/duniverse/ocaml-dns/LICENSE.md Normal file
View file

@ -0,0 +1,23 @@
Copyright (c) 2017, 2018, Hannes Mehnert
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice, this
list of conditions and the following disclaimer in the documentation and/or
other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

13
unikernel/duniverse/ocaml-dns/Makefile Normal file
View file

@ -0,0 +1,13 @@
.PHONY: build clean test doc
build:
dune build
test:
dune runtest
doc:
dune build @doc
clean:
dune clean

167
unikernel/duniverse/ocaml-dns/README.md Normal file
View file

@ -0,0 +1,167 @@
# ocaml-dns - a Domain Name System (DNS) library
(c) 2017-2019 Hannes Mehnert (robur.io, Center for the Cultivation of Technology)
v10.2.2
This library supports most of the domain name system used in the wild. It
adheres to strict conventions. Failing early and hard. It is mostly
implemented in the pure fragment of OCaml (no mutation, isolated IO, no
exceptions).
It all started out as an experiment to run a recursive resolver, but after
initial prototypes it turned out that every configurable recursive resolver
needs a fully-fledged authoritative nameserver as well (for overriding various
zones such as `.localhost` and reverse lookups of RFC 1918 IP ranges).
Legacy resource record types are not dealt with, and there is no plan to support
`ISDN`, `MAILA`, `MAILB`, `WKS`, `MB`, `HINFO`, ... . `AXFR`, `IXFR`,
and `UPDATE` is only handled via TCP connections. The only resource class
supported is `IN` (the Internet). Truncated hmac in `TSIG` are not supported
(always the full length of the hash algorithm is used).
Please read [the blog article](https://hannes.robur.coop/Posts/DNS) for a more
detailed overview.
This library is published under the 2 clause BSD license.
## Supported RFCs
* [RFC 1034](https://tools.ietf.org/html/rfc1034) Domain Names - Concepts and Facilities
* [RFC 1035](https://tools.ietf.org/html/rfc1035) Domain Names - Implementation and Specification
* [RFC 1876](https://tools.ietf.org/html/rfc1876) A Means for Expressing Location Information in the Domain Name System
* [RFC 1912](https://tools.ietf.org/html/rfc1912) Common DNS Operational and Configuration Errors
* [RFC 1995](https://tools.ietf.org/html/rfc1995) Incremental Zone Transfer in DNS
* [RFC 1996](https://tools.ietf.org/html/rfc1996) A Mechanism for Prompt Notification of Zone Changes (DNS NOTIFY)
* [RFC 2136](https://tools.ietf.org/html/rfc2136) Dynamic Updates in the domain name system (DNS UPDATE)
* [RFC 2181](https://tools.ietf.org/html/rfc2181) Clarifications to the DNS Specification
* [RFC 2308](https://tools.ietf.org/html/rfc2308) Negative Caching of DNS Queries (DNS NCACHE)
* [RFC 2782](https://tools.ietf.org/html/rfc2782) A DNS RR for specifying the location of services (DNS SRV)
* [RFC 2845](https://tools.ietf.org/html/rfc2845) Secret Key Transaction Authentication for DNS (TSIG)
* [RFC 3596](https://tools.ietf.org/html/rfc3596) DNS Extensions to Support IP Version 6
* [RFC 4033](https://tools.ietf.org/html/rfc4033) DNS Security Introduction and Requirements
* [RFC 4034](https://tools.ietf.org/html/rfc4034) Resource Records for the DNS Security Extensions
* [RFC 4035](https://tools.ietf.org/html/rfc4035) Protocol Modifications for the DNS Security Extensions
* [RFC 4255](https://tools.ietf.org/html/rfc4255) Using DNS to Securely Publish Secure Shell (SSH) Key Fingerprints
* [RFC 4343](https://tools.ietf.org/html/rfc4343) Domain Name System (DNS) Case Insensitivity Clarification
* [RFC 4509](https://tools.ietf.org/html/rfc4509) Use of SHA-256 in DNSSEC Delegation Signer (DS) Resource Records (RRs)
* [RFC 4592](https://tools.ietf.org/html/rfc4592) The Role of Wildcards in the Domain Name System
* [RFC 4635](https://tools.ietf.org/html/rfc4635) HMAC SHA TSIG Algorithm Identifiers
* `*` [RFC 5001](https://tools.ietf.org/html/rfc5001) DNS Name Server Identifier (NSID) Option
* [RFC 5155](https://tools.ietf.org/html/rfc5155) DNS Security (DNSSEC) Hashed Authenticated Denial of Existence
* [RFC 5358](https://tools.ietf.org/html/rfc5358) Preventing Use of Recursive Nameservers in Reflector Attacks
* [RFC 5452](https://tools.ietf.org/html/rfc5452) Measures for Making DNS More Resilient against Forged Answers
* [RFC 5936](https://tools.ietf.org/html/rfc5936) DNS Zone Transfer Protocol (AXFR)
* [RFC 6594](https://tools.ietf.org/html/rfc6594) Use of the SHA-256 Algorithm with RSA, Digital Signature Algorithm (DSA), and Elliptic Curve DSA (ECDSA) in SSHFP Resource Records
* [RFC 6605](https://tools.ietf.org/html/rfc6605) Elliptic Curve Digital Signature Algorithm (DSA) for DNSSEC
* [RFC 6698](https://tools.ietf.org/html/rfc6698.html) The DNS-Based Authentication of Named Entities (DANE) Transport Layer Security (TLS) Protocol: TLSA
* [RFC 6761](https://tools.ietf.org/html/rfc6761) Special-Use Domain Names
* `*` [RFC 6762](https://tools.ietf.org/html/rfc6762) Multicast DNS
* [RFC 6844](https://tools.ietf.org/html/rfc6844) DNS Certification Authority Authorization (CAA) Resource Record
* [RFC 6890](https://tools.ietf.org/html/rfc6890) Special-Purpose IP Address Registries
* [RFC 6891](https://tools.ietf.org/html/rfc6891) Extension Mechanisms for DNS (EDNS(0))
* [RFC 6895](https://tools.ietf.org/html/rfc6895) Domain Name System (DNS) IANA Considerations (BCP 42)
* [RFC 7129](https://tools.ietf.org/html/rfc7129) Authenticated Denial of Existence in the DNS
* [RFC 7479](https://tools.ietf.org/html/rfc7479) Using Ed25519 in SSHFP Resource Records
* [RFC 7626](https://tools.ietf.org/html/rfc7626) DNS Privacy Considerations
* [RFC 7766](https://tools.ietf.org/html/rfc7766) DNS Transport over TCP - Implementation Requirements
* [RFC 7816](https://tools.ietf.org/html/rfc7816) DNS Query Name Minimisation to Improve Privacy
* [RFC 7828](https://tools.ietf.org/html/rfc7828) The edns-tcp-keepalive EDNS0 Option
* `*` [RFC 7830](https://tools.ietf.org/html/rfc7830) The EDNS(0) Padding Option
* `*` [RFC 7873](https://tools.ietf.org/html/rfc7873) Domain Name System (DNS) Cookies
* [RFC 8020](https://tools.ietf.org/html/rfc8020) NXDOMAIN: There Really Is Nothing Underneath
* [RFC 8080](https://tools.ietf.org/html/rfc8080) Edwards-Curve Digital Security Algorithm (EdDSA) for DNSSEC
* [RFC 8109](https://tools.ietf.org/html/rfc8109) Initializing a DNS Resolver with Priming Queries
* [RFC 8914](https://tools.ietf.org/html/rfc8914) Extended DNS Errors
* [RFC 9156](https://tools.ietf.org/html/rfc8914) DNS Query Name Minimisation to Improve Privacy
* [RFC 9460](https://tools.ietf.org/html/rfc9460) Service Binding and Parameter Specification via the DNS (SVCB and HTTPS Resource Records)
* [RFC 9539](https://tools.ietf.org/html/rfc9539) Unilateral Opportunistic Deployment of Encrypted Recursive‑to‑Authoritative DNS
* [draft-ietf-dnsop-let-localhost-be-localhost-02](https://tools.ietf.org/html/draft-ietf-dnsop-let-localhost-be-localhost-02) Let 'localhost' be localhost.
`*`: Please note that the RFCs marked with `*` are only partially implemented
(i.e. only wire format, but no logic handling the feature).
## Installation
You first need to install [OCaml](https://ocaml.org) (at least 4.08.2) and
[opam](https://opam.ocaml.org), the OCaml package manager (at least 2.0.0) on
your machine (you can use opam to install an up-to-date OCaml (`opam switch
4.08.2`)).
You may want to follow the [mirage installation
instructions](https://mirage.io/wiki/install) to get `mirage` installed on your
computer.
To minimize the amount of run-time dependencies for each individual
functionality, the library is split into multiple opam packages (core, server,
client, resolver, cli, certify), with multiple ocamlfind libraries for the
different backends (no optional dependencies) -- i.e. `dns-server.mirage`
contains the MirageOS-specific DNS server code.
Now the µDNS library is installed, and you can try out the examples. Find some
examples at the [unikernel repository](https://github.com/roburio/unikernels).
## Documentation
API documentation [is available online](https://mirage.github.io/ocaml-dns/).
## Transition from older versions
The pre-4.0.0 versions of ocaml-dns had a significantly different interface,
and so applications using them will need to be rewritten to follow the
stricter coding style used in the post-4.0.0 branches. The major improvements
from 1.x to the 4.x series are:
- data (rrset) is defined in a single GADT in `Rr_map`
- added support for: notify, dynamic update, zone transfer, tsig (hmac authentication), edns
- no mutable data structures, leading to easier reasoning about library state
- switched to an independent `domain_name` library which uses a faster and more
compact `string array` instead of `string list` for storing domain names
- integration with LetsEncrypt for provisioning valid X.509 certificates
- no use of exceptions, instead preferring explicit result values from API functions
Please get in touch on <mirageos-devel@lists.xenproject.org> or on the Discuss forum
at <https://discuss.ocaml.org> (with the `mirageos` tag) if you have any questions
about migrating (or just general questions).
## Development
To work with the [opam](https://opam.ocaml.org/) packages provided when
developing modifications to DNS, or when pinning a specific version,
you will have to pin the same *version* for all of them:
```csh
: csh syntax
set version=4.99.0
set repo=git+https://github.com/mirage/ocaml-dns.git
# the -y parameter means "force" or
# "do go ahead and register a new package"
# the -n parameter means
# "just register the pin, don't actually install it yet"
foreach pkg ( dns dns-{certify,cli,client,resolver,server,mirage,tsig,stub} )
opam pin add -y -n $pkg.$version --dev $repo
end
```
```bash
: bash syntax
version=4.99.0
repo=git+https://github.com/mirage/ocaml-dns.git
for pkg in dns dns-{certify,cli,client,resolver,server,mirage,tsig,stub}
do
opam pin add -y -n $pkg.$version --dev $repo
done
```
Now you can install the packages you need, for instance:
```shell
opam install dns-client
```
or
```shell
opam install dns-resolver
```

110
unikernel/duniverse/ocaml-dns/app/dns_cli.ml Normal file
View file

@ -0,0 +1,110 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
let reporter_with_ts ~dst () =
let pp_tags f tags =
let pp tag () =
let (Logs.Tag.V (def, value)) = tag in
Format.fprintf f " %s=%a" (Logs.Tag.name def) (Logs.Tag.printer def) value;
()
in
Logs.Tag.fold pp tags ()
in
let report src level ~over k msgf =
let tz_offset_s = Ptime_clock.current_tz_offset_s () in
let posix_time = Ptime_clock.now () in
let src = Logs.Src.name src in
let k _ =
over ();
k ()
in
msgf @@ fun ?header ?tags fmt ->
Format.kfprintf k dst
("%a:%a %a [%s] @[" ^^ fmt ^^ "@]@.")
(Ptime.pp_rfc3339 ?tz_offset_s ())
posix_time
Fmt.(option ~none:(any "") pp_tags)
tags Logs_fmt.pp_header (level, header) src
in
{ Logs.report }
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (reporter_with_ts ~dst:Format.std_formatter ())
let connect_tcp ip port =
let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) in
let fam = match ip with Ipaddr.V4 _ -> Unix.PF_INET | Ipaddr.V6 _ -> Unix.PF_INET6 in
let sock = Unix.(socket fam SOCK_STREAM 0) in
Unix.(setsockopt sock SO_REUSEADDR true) ;
Unix.connect sock sa ;
sock
(* TODO EINTR, SIGPIPE *)
let send_tcp sock buf =
let size = String.length buf in
let size_buf =
let b = Bytes.create 2 in
Bytes.set_int16_be b 0 size ;
b
in
let data = Bytes.cat size_buf (Bytes.of_string buf) in
let whole = size + 2 in
let rec out off =
if off = whole then ()
else
let bytes = Unix.send sock data off (whole - off) [] in
out (bytes + off)
in
out 0
let recv_tcp sock =
let rec read_exactly buf len off =
if off = len then ()
else
let n = Unix.recv sock buf off (len - off) [] in
read_exactly buf len (off + n)
in
let buf = Bytes.create 2 in
read_exactly buf 2 0 ;
let len = Bytes.get_int16_be buf 0 in
let buf' = Bytes.create len in
read_exactly buf' len 0 ;
Bytes.unsafe_to_string buf'
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let ip_c = Arg.conv (Ipaddr.of_string, Ipaddr.pp)
let namekey_c =
let parse s =
let ( let* ) = Result.bind in
let* (name, key) = Dns.Dnskey.name_key_of_string s in
let is_op s =
Domain_name.(equal_label s "_update" || equal_label s "_transfer" || equal_label s "_notify")
in
let amount = match Domain_name.find_label ~rev:true name is_op with
| None -> 0
| Some x -> succ x
in
let* zone = Domain_name.drop_label ~amount name in
let* zone = Domain_name.host zone in
Ok (name, zone, key)
in
let pp ppf (name, zone, key) =
Fmt.pf ppf "key name %a zone %a dnskey %a"
Domain_name.pp name Domain_name.pp zone Dns.Dnskey.pp key
in
Arg.conv (parse, pp)
let name_c =
Arg.conv
((fun s -> Result.bind (Domain_name.of_string s) Domain_name.host),
Domain_name.pp)
let domain_name_c =
Arg.conv (Domain_name.of_string, Domain_name.pp)

57
unikernel/duniverse/ocaml-dns/app/dune Normal file
View file

@ -0,0 +1,57 @@
(library
(name dns_cli)
(public_name dns-cli)
(wrapped false)
(modules dns_cli)
(libraries dns cmdliner ptime.clock.os logs.fmt fmt.cli logs.cli fmt.tty ipaddr.unix))
(executable
(name ocertify)
(public_name ocertify)
(package dns-cli)
(modules ocertify)
(libraries dns dns-certify dns-cli bos fpath x509 ptime ptime.clock.os mirage-crypto-pk mirage-crypto-rng mirage-crypto-rng.unix))
(executable
(name oupdate)
(public_name oupdate)
(package dns-cli)
(modules oupdate)
(libraries dns dns-tsig dns-cli ptime ptime.clock.os mirage-crypto-rng mirage-crypto-rng.unix randomconv))
(executable
(name onotify)
(public_name onotify)
(package dns-cli)
(modules onotify)
(libraries dns dns-tsig dns-cli ptime ptime.clock.os mirage-crypto-rng mirage-crypto-rng.unix randomconv))
(executable
(name ozone)
(public_name ozone)
(package dns-cli)
(modules ozone)
(libraries dns dns-cli dns-server.zone dns-server bos))
(executable
(name odns)
(public_name odns)
(modules odns)
(package dns-cli)
(libraries dns dns-client-lwt dns-cli cmdliner mtime.clock.os
lwt.unix ohex bos))
(executable
(name odnssec)
(public_name odnssec)
(modules odnssec)
(package dns-cli)
(libraries dns dns-client-lwt dns-cli cmdliner mtime.clock.os
lwt.unix dnssec))
(executable
(name resolver)
(public_name resolver)
(modules resolver)
(package dns-cli)
(libraries dns-cli dns-resolver dns-resolver.mirage lwt.unix tcpip.stack-socket mirage-mtime.unix logs.fmt mirage-crypto-rng.unix))

205
unikernel/duniverse/ocaml-dns/app/ocertify.ml Normal file
View file

@ -0,0 +1,205 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
let ( let* ) = Result.bind
let find_or_generate_key key_filename keytype keydata seed bits =
let* f_exists = Bos.OS.File.exists key_filename in
if f_exists then
let* data = Bos.OS.File.read key_filename in
X509.Private_key.decode_pem data
else
let* key =
match keydata with
| None -> Ok (X509.Private_key.generate ?seed ~bits keytype)
| Some s ->
let* s = Base64.decode s in
X509.Private_key.of_octets s keytype
in
let pem = X509.Private_key.encode_pem key in
let* () = Bos.OS.File.write ~mode:0o600 key_filename pem in
Ok key
let query_certificate sock fqdn csr =
match Dns_certify.query Mirage_crypto_rng.generate (Ptime_clock.now ()) fqdn csr with
| Error e -> Error e
| Ok (out, cb) ->
Dns_cli.send_tcp sock out;
let data = Dns_cli.recv_tcp sock in
cb data
let nsupdate_csr sock host keyname zone dnskey csr =
match Dns_certify.nsupdate Mirage_crypto_rng.generate Ptime_clock.now ~host ~keyname ~zone dnskey csr with
| Error s -> Error s
| Ok (out, cb) ->
Dns_cli.send_tcp sock out;
let data = Dns_cli.recv_tcp sock in
match cb data with
| Ok () -> Ok ()
| Error e -> Error (`Msg (Fmt.str "nsupdate reply error %a" Dns_certify.pp_u_err e))
let jump _ server_ip port hostname more_hostnames dns_key_opt csr key keytype keydata seed bits cert force =
Mirage_crypto_rng_unix.use_default ();
let fn suffix = function
| None -> Fpath.(v (Domain_name.to_string hostname) + suffix)
| Some x -> Fpath.v x
in
let csr_filename = fn "req" csr
and key_filename = fn "key" key
and cert_filename = fn "pem" cert
in
let* csr =
let* f_exists = Bos.OS.File.exists csr_filename in
if f_exists then
let* data = Bos.OS.File.read csr_filename in
X509.Signing_request.decode_pem data
else
let* key = find_or_generate_key key_filename keytype keydata seed bits in
let* csr = Dns_certify.signing_request hostname ~more_hostnames key in
let pem = X509.Signing_request.encode_pem csr in
let* () = Bos.OS.File.write csr_filename pem in
Ok csr
in
(* before doing anything, let's check whether cert_filename is present,
the public key matches, and the certificate is still valid *)
let now = Ptime_clock.now () in
let tomorrow =
let (d, ps) = Ptime.Span.to_d_ps (Ptime.to_span now) in
Ptime.v (succ d, ps)
in
let* cert =
let* f_exists = Bos.OS.File.exists cert_filename in
if f_exists then
let* data = Bos.OS.File.read cert_filename in
let* certs = X509.Certificate.decode_pem_multiple data in
match List.filter (fun c -> X509.Certificate.supports_hostname c hostname) certs with
| [] -> Ok None
| [ cert ] -> Ok (Some cert)
| _ -> Error (`Msg "multiple certificates that match the hostname")
else
Ok None
in
let* () =
match cert with
| Some cert ->
if not force && Dns_certify.cert_matches_csr ~until:tomorrow now csr cert then
Error (`Msg "valid certificate with matching key already present")
else
Ok ()
| None -> Ok ()
in
(* strategy: unless force is provided, we can request DNS, and if a
certificate is present, compare its public key with csr public key *)
let write_certificate certs =
let data = X509.Certificate.encode_pem_multiple certs in
let* () = Bos.OS.File.delete cert_filename in
Bos.OS.File.write cert_filename data
in
let sock = Dns_cli.connect_tcp server_ip port in
let* should_update =
if force then
Ok true
else match query_certificate sock hostname csr with
| Ok (server, chain) ->
Logs.app (fun m -> m "found cached certificate in DNS");
let* () = write_certificate (server :: chain) in
Ok false
| Error `No_tlsa ->
Logs.debug (fun m -> m "no TLSA found, sending update");
Ok true
| Error (`Msg m) -> Error (`Msg m)
| Error ((`Decode _ | `Bad_reply _ | `Unexpected_reply _) as e) ->
Error (`Msg (Fmt.str "error %a while parsing TLSA reply"
Dns_certify.pp_q_err e))
in
if not should_update then
Ok ()
else
let* () =
match dns_key_opt with
| None -> Error (`Msg "no dnskey provided, but required for uploading CSR")
| Some (keyname, zone, dnskey) ->
let* () = nsupdate_csr sock hostname keyname zone dnskey csr in
let rec request retries =
match query_certificate sock hostname csr with
| Error (`Msg msg) -> Error (`Msg msg)
| Error #Dns_certify.q_err when retries = 0 ->
Error (`Msg "failed to retrieve certificate (tried 10 times)")
| Error `No_tlsa ->
Logs.warn (fun m -> m "still no tlsa, sleeping two more seconds");
Unix.sleep 2;
request (pred retries)
| Error (#Dns_certify.q_err as e) ->
Logs.err (fun m -> m "error %a while handling TLSA reply (retrying)"
Dns_certify.pp_q_err e);
request (pred retries)
| Ok (server, chain) -> write_certificate (server :: chain)
in
request 10
in
Logs.app (fun m -> m "success! your certificate is stored in %a (private key %a, csr %a)"
Fpath.pp cert_filename Fpath.pp key_filename Fpath.pp csr_filename);
Ok ()
open Cmdliner
let dns_server =
let doc = "DNS server IP" in
Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"IP")
let port =
let doc = "Port to connect to" in
Arg.(value & opt int 53 & info [ "port" ] ~doc)
let dns_key =
let doc = "nsupdate key (name:alg:b64key, where name is YYY._update.zone)" in
Arg.(value & opt (some Dns_cli.namekey_c) None & info [ "dns-key" ] ~doc ~docv:"KEY")
let hostname =
let doc = "Hostname (FQDN) to issue a certificate for" in
Arg.(required & pos 1 (some Dns_cli.name_c) None & info [] ~doc ~docv:"HOSTNAME")
let more_hostnames =
let doc = "Additional hostnames to be included in the certificate as SubjectAlternativeName extension" in
Arg.(value & opt_all Dns_cli.domain_name_c [] & info ["additional"] ~doc ~docv:"HOSTNAME")
let csr =
let doc = "certificate signing request filename (defaults to hostname.req)" in
Arg.(value & opt (some string) None & info [ "csr" ] ~doc)
let key =
let doc = "private key filename (default to hostname.key)" in
Arg.(value & opt (some string) None & info [ "key" ] ~doc)
let seed =
let doc = "private key seed (or full private key if keytype is a EC key)" in
Arg.(value & opt (some string) None & info [ "seed" ] ~doc)
let bits =
let doc = "private key bits" in
Arg.(value & opt int 4096 & info [ "bits" ] ~doc)
let keydata =
let doc = "private key (base64 encoded)" in
Arg.(value & opt (some string) None & info [ "data" ] ~doc)
let keytype =
let doc = "keytype to generate" in
Arg.(value & opt (enum X509.Key_type.strings) `RSA & info [ "type" ] ~doc)
let cert =
let doc = "certificate filename (defaults to hostname.pem)" in
Arg.(value & opt (some string) None & info [ "certificate" ] ~doc)
let force =
let doc = "force signing request to DNS" in
Arg.(value & flag & info [ "force" ] ~doc)
let ocertify =
let doc = "ocertify requests a signed certificate" in
let man = [ `S "BUGS"; `P "Submit bugs to me";] in
let term =
Term.(term_result (const jump $ Dns_cli.setup_log $ dns_server $ port $ hostname $ more_hostnames $ dns_key $ csr $ key $ keytype $ keydata $ seed $ bits $ cert $ force))
and info = Cmd.info "ocertify" ~version:"10.2.2" ~doc ~man
in
Cmd.v info term
let () = exit (Cmd.eval ocertify)

433
unikernel/duniverse/ocaml-dns/app/odns.ml Normal file
View file

@ -0,0 +1,433 @@
(* odns client utility. *)
(* RFC 768 DNS over UDP *)
(* RFC 7766 DNS over TCP: https://tools.ietf.org/html/rfc7766 *)
(* RFC 6698 DANE: https://tools.ietf.org/html/rfc6698*)
let pp_zone ppf (domain,query_type,query_value) =
(* TODO dig also prints 'IN' after the TTL, we don't... *)
Fmt.string ppf
(Dns.Rr_map.text_b domain (Dns.Rr_map.B (query_type, query_value)))
let pp_zone_tlsa ppf (domain,ttl,(tlsa:Dns.Tlsa.t)) =
(* TODO this implementation differs a bit from Dns_map.text and tries to
follow the `dig` output to make it easier to port existing scripts *)
Fmt.pf ppf "%a.\t%ld\tIN\t%d\t%d\t%d\t%s"
Domain_name.pp domain
ttl
(Dns.Tlsa.cert_usage_to_int tlsa.cert_usage)
(Dns.Tlsa.selector_to_int tlsa.selector)
(Dns.Tlsa.matching_type_to_int tlsa.matching_type)
( (* this produces output similar to `dig`, splitting the hex string
in chunks of 56 chars (28 bytes): *)
let hex = Ohex.decode tlsa.data in
let hlen = String.length hex in
let rec loop acc = function
| n when n + 56 >= hlen ->
String.concat " " (List.rev (String.sub hex n (hlen-n)::acc))
|> String.uppercase_ascii
| n -> loop ((String.sub hex n 56)::acc) (n+56)
in loop [] 0)
let pp_nameserver ppf = function
| `Plaintext (ip, port) -> Fmt.pf ppf "TCP %a:%d" Ipaddr.pp ip port
| `Tls (tls_cfg, ip, port) ->
Fmt.pf ppf "TLS %a:%d%a" Ipaddr.pp ip port
Fmt.(option ~none:(any "") (append (any "#") Domain_name.pp))
((Tls.Config.of_client tls_cfg).Tls.Config.peer_name)
let do_a nameservers domains () =
let happy_eyeballs = Happy_eyeballs_lwt.create () in
let t = Dns_client_lwt.create ?nameservers happy_eyeballs in
let (_, ns) = Dns_client_lwt.nameservers t in
Logs.info (fun m -> m "querying NS %a for A records of %a"
pp_nameserver (List.hd ns) Fmt.(list ~sep:(any ", ") Domain_name.pp) domains);
let job =
Lwt_list.iter_p (fun domain ->
let open Lwt in
Logs.debug (fun m -> m "looking up %a" Domain_name.pp domain);
Dns_client_lwt.(getaddrinfo t A domain)
>|= function
| Ok (_ttl, addrs) when Ipaddr.V4.Set.is_empty addrs ->
(* handle empty response? *)
Logs.app (fun m -> m ";%a. IN %a"
Domain_name.pp domain
Dns.Rr_map.ppk (Dns.Rr_map.K A))
| Ok resp ->
Logs.app (fun m -> m "%a" pp_zone (domain, A, resp))
| Error (`Msg msg) ->
Logs.err (fun m -> m "Failed to lookup %a: %s\n"
Domain_name.pp domain msg)
) domains
in
match Lwt_main.run job with
| () -> Ok () (* TODO handle errors *)
let for_all_domains nameservers ~domains typ f =
(* [for_all_domains] is a utility function that lets us avoid duplicating
this block of code in all the subcommands.
We leave {!do_a} simple to provide a more readable example. *)
let happy_eyeballs = Happy_eyeballs_lwt.create () in
let t = Dns_client_lwt.create ?nameservers happy_eyeballs in
let _, ns = Dns_client_lwt.nameservers t in
Logs.info (fun m -> m "NS: %a" pp_nameserver (List.hd ns));
let open Lwt in
match
Lwt_main.run
(Lwt_list.iter_p
(fun domain ->
Dns_client_lwt.getaddrinfo t typ domain >|= function
| Error `Msg msg ->
Logs.err (fun m ->
m "Failed to lookup %a for %a: %s\n%!"
Dns.Rr_map.ppk (Dns.Rr_map.K typ)
Domain_name.pp domain msg) ;
()
| Ok x -> f domain x)
domains)
with
| () -> Ok () (* TODO catch failed jobs *)
let output_response typ domain resp =
Logs.app (fun m -> m "%a" pp_zone (domain, typ, resp))
let do_aaaa nameserver domains () =
for_all_domains nameserver ~domains Dns.Rr_map.Aaaa
(output_response Dns.Rr_map.Aaaa)
let do_mx nameserver domains () =
for_all_domains nameserver ~domains Dns.Rr_map.Mx
(output_response Dns.Rr_map.Mx)
let do_tlsa nameserver domains () =
for_all_domains nameserver ~domains Dns.Rr_map.Tlsa
(fun domain (ttl, tlsa_resp) ->
Dns.Rr_map.Tlsa_set.iter (fun tlsa ->
Logs.app (fun m -> m "%a" pp_zone_tlsa (domain, ttl, tlsa))
) tlsa_resp)
let do_txt nameserver domains () =
for_all_domains nameserver ~domains Dns.Rr_map.Txt
(fun _domain (ttl, txtset) ->
Dns.Rr_map.Txt_set.iter (fun txtrr ->
Logs.app (fun m -> m "%ld: @[<v>%s@]" ttl txtrr)
) txtset)
let do_any _nameserver _domains () =
(* TODO *)
Error (`Msg "ANY functionality is not present atm due to refactorings, come back later")
let do_dkim nameserver (selector:string) domains () =
let domains = List.map (fun original_domain ->
Domain_name.prepend_label_exn
(Domain_name.prepend_label_exn
(original_domain) "_domainkey") selector
) domains in
for_all_domains nameserver ~domains Dns.Rr_map.Txt
(fun _domain (_ttl, txtset) ->
Dns.Rr_map.Txt_set.iter (fun txt ->
Logs.app (fun m -> m "%s" txt)
) txtset)
let do_type nameserver typ domains () =
match Dns.Rr_map.of_int typ with
| Ok K k ->
for_all_domains nameserver ~domains k
(fun domain resp ->
Logs.app (fun m -> m "%a" pp_zone (domain, k, resp)))
| _ -> Error (`Msg "bad argument")
let do_loc nameserver domains () =
for_all_domains nameserver ~domains Dns.Rr_map.Loc
(output_response Dns.Rr_map.Loc)
open Cmdliner
let sdocs = Manpage.s_common_options
let setup_log =
let setup_log (style_renderer:Fmt.style_renderer option) level : unit =
Fmt_tty.setup_std_outputs ?style_renderer () ;
Logs.set_level level ;
Logs.set_reporter (Logs_fmt.reporter ())
in
Term.(const setup_log $ Fmt_cli.style_renderer ~docs:sdocs ()
$ Logs_cli.level ~docs:sdocs ())
let arg_ns : 'a Term.t =
let doc = "IP of nameserver to use" in
Arg.(value & opt (some Dns_cli.ip_c) None & info ~docv:"NS-IP" ~doc ["ns"])
let arg_port : 'a Term.t =
let doc = "Port of nameserver" in
Arg.(value & opt int 53 & info ~docv:"NS-PORT" ~doc ["ns-port"])
let tls_hostname =
let doc = "Hostname to use for TLS authentication" in
Arg.(value & opt (some Dns_cli.name_c) None &
info ~docv:"HOSTNAME" ~doc ["tls-hostname"])
let tls_ca_file =
let doc = "TLS trust anchor file" in
Arg.(value & opt (some file) None &
info ~docv:"CAs" ~doc ["tls-ca-file"])
let tls_ca_dir =
let doc = "TLS trust anchor directory" in
Arg.(value & opt (some dir) None &
info ~docv:"CAs" ~doc ["tls-ca-directory"])
let tls_cert_fp =
let doc = "TLS certificate fingerprint" in
Arg.(value & opt (some string) None &
info ~docv:"FP" ~doc ["tls-cert-fingerprint"])
let tls_key_fp =
let doc = "TLS public key fingerprint" in
Arg.(value & opt (some string) None &
info ~docv:"FP" ~doc ["tls-key-fingerprint"])
let no_tls =
let doc = "Disable DNS-over-TLS" in
Arg.(value & flag & info ~docv:"no-tls" ~doc ["no-tls"])
let nameserver =
let ( let* ) = Result.bind in
let ns no_tls ca_file ca_dir cert_fp key_fp hostname ip port =
if no_tls then
Option.map (fun ip -> `Tcp, [ `Plaintext (ip, port)]) ip
else
match ip with
| None -> None
| Some ip ->
let auth peer_name ip =
let cfg auth =
Result.join
(Result.map
(fun authenticator -> Tls.Config.client ~authenticator ?peer_name ?ip ()) auth)
in
let time () = Some (Ptime_clock.now ()) in
let of_fp data =
let hash, fp =
let h_of_string = function
| "md5" -> Some `MD5
| "sha" | "sha1" -> Some `SHA1
| "sha224" -> Some `SHA224
| "sha256" -> Some `SHA256
| "sha384" -> Some `SHA384
| "sha512" -> Some `SHA512
| _ -> None
in
match String.split_on_char ':' data with
| [] -> invalid_arg "empty fingerprint"
| [ fp ] -> `SHA256, fp
| hash :: rt -> match h_of_string (String.lowercase_ascii hash) with
| Some h -> h, String.concat "" rt
| None -> invalid_arg ("unknown hash: " ^ hash)
in
let hex = Ohex.encode fp in
hash, hex
in
match ca_file, ca_dir, cert_fp, key_fp with
| None, None, None, None -> cfg (Ca_certs.authenticator ())
| Some f, None, None, None ->
let* data = Bos.OS.File.read (Fpath.v f) in
let* certs = X509.Certificate.decode_pem_multiple data in
cfg (Ok (X509.Authenticator.chain_of_trust ~time certs))
| None, Some d, None, None ->
let* files = Bos.OS.Dir.contents (Fpath.v d) in
let* certs =
List.fold_left (fun r f ->
let* acc = r in
let* data = Bos.OS.File.read f in
let* cert = X509.Certificate.decode_pem data in
Ok (cert :: acc))
(Ok []) files
in
cfg (Ok (X509.Authenticator.chain_of_trust ~time certs))
| None, None, Some fp, None ->
let hash, fingerprint = of_fp fp in
cfg (Ok (X509.Authenticator.cert_fingerprint ~time ~hash ~fingerprint))
| None, None, None, Some fp ->
let hash, fingerprint = of_fp fp in
cfg (Ok (X509.Authenticator.key_fingerprint ~time ~hash ~fingerprint))
| _ -> invalid_arg "only one of cert-file, cert-dir, key-fingerprint, cert-fingerprint is supported"
in
let ip' = match hostname with None -> Some ip | Some _ -> None in
let tls = match auth hostname ip' with
| Ok a -> a
| Error `Msg msg -> invalid_arg msg
in
Some (`Tcp, [ `Tls (tls, ip, if port = 53 then 853 else port);
`Plaintext (ip, port) ])
in
Term.(const ns $ no_tls $ tls_ca_file $ tls_ca_dir $ tls_cert_fp $ tls_key_fp $ tls_hostname $ arg_ns $ arg_port)
let arg_domains : [ `raw ] Domain_name.t list Term.t =
let doc = "Domain names to operate on" in
Arg.(non_empty & pos_all Dns_cli.domain_name_c []
& info [] ~docv:"DOMAIN(s)" ~doc)
let arg_selector : string Term.t =
let doc = "DKIM selector string" in
Arg.(required & opt (some string) None
& info ["selector"] ~docv:"SELECTOR" ~doc)
let cmd_a : unit Cmd.t =
let doc = "Query a NS for A records" in
let man = [
`P {| Output mimics that of $(b,dig A )$(i,DOMAIN)|}
] in
let term =
Term.(term_result (const do_a $ nameserver $ arg_domains $ setup_log))
and info =
Cmd.info "a" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
in
Cmd.v info term
let cmd_aaaa : unit Cmd.t =
let doc = "Query a NS for AAAA records" in
let man = [
`P {| Output mimics that of $(b,dig AAAA )$(i,DOMAIN)|}
] in
let term =
Term.(term_result (const do_aaaa $ nameserver $ arg_domains $ setup_log))
and info =
Cmd.info "aaaa" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
in
Cmd.v info term
let cmd_mx : unit Cmd.t =
let doc = "Query a NS for mailserver (MX) records" in
let man = [
`P {| Output mimics that of $(b,dig MX )$(i,DOMAIN)|}
] in
let term =
Term.(term_result (const do_mx $ nameserver $ arg_domains $ setup_log))
and info =
Cmd.info "mx" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
in
Cmd.v info term
let cmd_tlsa : unit Cmd.t =
let doc = "Query a NS for TLSA records (see DANE / RFC 7671)" in
let man = [
`S Manpage.s_arguments ;
`S Manpage.s_description ;
`P {|Note that you must specify which $(b,service name)
you want to retrieve the key(s) of.
To retrieve the $(b,HTTPS) cert of $(i,www.example.com),
you would query the NS:
$(mname) $(tname) $(b,_443._tcp.)$(i,www.example.com)
|} ;
`P {|Brief list of other handy service name prefixes:|};
`P {| $(b,_5222._tcp) (XMPP); |} ;
`P {| $(b,_853._tcp) (DNS-over-TLS); |} ;
`P {| $(b,_25._tcp) (SMTP with STARTTLS); |} ;
`P {| $(b,_465._tcp)(SMTP); |} ;
`P {| $(b,_993._tcp) (IMAP) |} ;
`S Manpage.s_options ;
] in
let term =
Term.(term_result (const do_tlsa $ nameserver $ arg_domains $ setup_log))
and info =
Cmd.info "tlsa" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
in
Cmd.v info term
let cmd_txt : unit Cmd.t =
let doc = "Query a NS for TXT records" in
let man = [
`S Manpage.s_arguments ;
`S Manpage.s_description ;
`P {| Output format is currently: $(i,{TTL}: {text escaped in OCaml format})
It would be nice to mirror `dig` output here.|} ;
`S Manpage.s_options ;
] in
let term =
Term.(term_result (const do_txt $ nameserver $ arg_domains $ setup_log))
and info =
Cmd.info "txt" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
in
Cmd.v info term
let cmd_any : unit Cmd.t =
let doc = "Query a NS for ANY records" in
let man = [
`S Manpage.s_arguments ;
`S Manpage.s_description ;
`P {| The output will be fairly similar to $(b,dig ANY )$(i,example.com)|} ;
`S Manpage.s_options ;
] in
let term =
Term.(term_result (const do_any $ nameserver $ arg_domains $ setup_log))
and info =
Cmd.info "any" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
in
Cmd.v info term
let cmd_dkim : unit Cmd.t =
let doc = "Query a NS for DKIM (RFC 6376) records for a given selector" in
let man = [
`S Manpage.s_arguments ;
`S Manpage.s_description ;
`S {| Looks up DKIM (DomainKeys Identified Mail) Signatures in
accordance with RFC 6376.
Basically it's a recursive TXT lookup on
$(i,SELECTOR)._domainkeys.$(i,DOMAIN).
Each key is printed on its own concatenated line.
|} ;
`S Manpage.s_options ;
] in
let term =
Term.(term_result (const do_dkim $ nameserver $ arg_selector
$ arg_domains $ setup_log))
and info =
Cmd.info "dkim" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
in
Cmd.v info term
let arg_typ : int Term.t =
let doc = "Type to query" in
Arg.(required & opt (some int) None
& info ["type"] ~docv:"TYPE" ~doc)
let cmd_type : unit Cmd.t =
let doc = "Query a NS for a type, providing its integer number" in
let term =
Term.(term_result (const do_type $ nameserver $ arg_typ
$ arg_domains $ setup_log))
and info =
Cmd.info "type" ~version:(Manpage.escape "v10.2.2") ~doc ~sdocs
in
Cmd.v info term
let cmd_loc : unit Cmd.t =
let doc = "Query a NS for LOC records" in
let term =
Term.(term_result (const do_loc $ nameserver $ arg_domains $ setup_log))
and info =
Cmd.info "loc" ~version:(Manpage.escape "v10.2.2") ~doc ~sdocs
in
Cmd.v info term
let cmd_help : 'a Term.t =
let help _ = `Help (`Pager, None) in
Term.(ret (const help $ setup_log))
let cmds =
[ cmd_a ; cmd_tlsa; cmd_txt ; cmd_any; cmd_dkim ; cmd_aaaa ; cmd_mx ; cmd_type ; cmd_loc ]
let () =
let doc = "OCaml uDns alternative to `dig`" in
let man = [
`P {|For more information about the available subcommands,
run them while passing the help flag: $(tname) $(i,SUBCOMMAND) $(b,--help)
|}
] in
let info =
Cmd.info "odns" ~version:(Manpage.escape "v10.2.2") ~man ~doc ~sdocs
in
let group = Cmd.group ~default:cmd_help info cmds in
exit (Cmd.eval group)

201
unikernel/duniverse/ocaml-dns/app/odnssec.ml Normal file
View file

@ -0,0 +1,201 @@
open Lwt.Infix
open Dns
let ( let* ) = Result.bind
let pp_zone ppf (domain, query_type, query_value) =
Fmt.string ppf
(Rr_map.text_b domain (Rr_map.B (query_type, query_value)))
let pp_nameserver ppf = function
| `Plaintext (ip, port) -> Fmt.pf ppf "TCP %a:%d" Ipaddr.pp ip port
| `Tls (tls_cfg, ip, port) ->
Fmt.pf ppf "TLS %a:%d%a" Ipaddr.pp ip port
Fmt.(option ~none:(any "") (append (any "#") Domain_name.pp))
((Tls.Config.of_client tls_cfg).Tls.Config.peer_name)
let jump () hostname typ ns =
match Dns.Rr_map.of_string typ with
| Ok K k ->
Lwt_main.run (
let edns = Edns.create ~dnssec_ok:true ~payload_size:4096 () in
let nameservers = match ns with
| None -> None
| Some ip -> Some (`Tcp, [ `Plaintext (ip, 53) ])
in
let happy_eyeballs = Happy_eyeballs_lwt.create () in
let t = Dns_client_lwt.create ?nameservers ~edns:(`Manual edns) happy_eyeballs in
let (_, ns) = Dns_client_lwt.nameservers t in
Logs.info (fun m -> m "querying NS %a for A records of %a"
pp_nameserver (List.hd ns) Domain_name.pp hostname);
let log_err = function
| `Msg msg ->
Logs.err (fun m -> m "error from resolver %s" msg);
Error (`Msg "bad request")
| `Partial ->
Logs.err (fun m -> m "partial from resolver");
Error (`Msg "partial")
| #Dnssec.err as e ->
Logs.err (fun m -> m "dnssec error %a" Dnssec.pp_err e);
Error (`Msg "error")
in
let now = Ptime_clock.now () in
let retrieve_dnskey dnskeys ds_set requested_domain =
Dns_client_lwt.(get_raw_reply t Dnskey requested_domain) >|= function
| Error e -> log_err e
| Ok reply ->
let keys =
match reply with
| `Answer (answer, _) ->
Option.map
(fun (_, keys) ->
let valid_keys =
Rr_map.Ds_set.fold (fun ds acc ->
match Dnssec.validate_ds requested_domain keys ds with
| Ok key -> Rr_map.Dnskey_set.add key acc
| Error `Msg msg ->
Logs.warn (fun m -> m "couldn't validate DS (for %a): %s"
Domain_name.pp requested_domain msg);
acc
| Error `Extended e ->
Logs.warn (fun m -> m "couldn't validate DS (for %a): %a"
Domain_name.pp requested_domain
Extended_error.pp e);
acc)
ds_set Rr_map.Dnskey_set.empty
in
Logs.debug (fun m -> m "found %d DNSKEYS with matching DS"
(Rr_map.Dnskey_set.cardinal valid_keys));
valid_keys)
(Name_rr_map.find requested_domain Dnskey answer)
| _ -> None
in
let keys = Option.value ~default:dnskeys keys in
match Dnssec.verify_reply now keys requested_domain Dnskey reply with
| Error (`No_domain _ | `No_data _) ->
Logs.warn (fun m -> m "no DNSKEY for %a"
Domain_name.pp requested_domain);
Error (`Msg (Fmt.str "missing DNSKEY for %a"
Domain_name.pp requested_domain))
| Error e -> log_err e
| Ok (_, keys) ->
Logs.info (fun m -> m "verified RRSIG for DNSKEYS");
let keys =
Rr_map.Dnskey_set.filter
(fun k -> Dnskey.F.mem `Zone k.Dnskey.flags)
keys
in
Ok keys
in
let retrieve_ds dnskeys name =
Dns_client_lwt.(get_raw_reply t Ds name) >|= function
| Error e -> log_err e
| Ok reply ->
match Dnssec.verify_reply ~follow_cname:false now dnskeys name Ds reply with
| Ok (_, ds) -> Ok (Some ds)
| Error (`No_domain _ | `No_data _) ->
Logs.warn (fun m -> m "no data or no domain for DS in %a"
Domain_name.pp name);
Ok None
| Error (`Cname a) ->
Logs.warn (fun m -> m "cname alias for %a (DS) to %a"
Domain_name.pp name
Domain_name.pp a);
Ok None
| Error e->
log_err e
in
let rec retrieve_validated_dnskeys hostname =
Logs.info (fun m -> m "validating and retrieving DNSKEYS for %a" Domain_name.pp hostname);
if Domain_name.equal hostname Domain_name.root then begin
Logs.info (fun m -> m "retrieving DNSKEYS for %a" Domain_name.pp hostname);
retrieve_dnskey Rr_map.Dnskey_set.empty Dnssec.root_ds hostname
end else
let open Lwt_result.Infix in
retrieve_validated_dnskeys Domain_name.(drop_label_exn hostname) >>= fun parent_dnskeys ->
Logs.info (fun m -> m "retrieving DS for %a" Domain_name.pp hostname);
retrieve_ds parent_dnskeys hostname >>= function
| Some ds_set ->
(* following 4509 - if there's a sha2 DS, drop sha1 ones *)
let ds_set' =
if
Rr_map.Ds_set.exists
(fun ds ->
match ds.Ds.digest_type with
| Ds.SHA256 | Ds.SHA384 -> true
| _ -> false)
ds_set
then
Rr_map.Ds_set.filter
(fun ds -> not (ds.Ds.digest_type = Ds.SHA1))
ds_set
else
ds_set
in
if Rr_map.Ds_set.cardinal ds_set > Rr_map.Ds_set.cardinal ds_set' then
Logs.warn (fun m -> m "dropped %d DS records (SHA1)"
(Rr_map.Ds_set.cardinal ds_set' - Rr_map.Ds_set.cardinal ds_set));
Logs.info (fun m -> m "retrieving DNSKEYS for %a" Domain_name.pp hostname);
retrieve_dnskey parent_dnskeys ds_set' hostname
| None ->
Logs.info (fun m -> m "no DS for %a, continuing with old keys" Domain_name.pp hostname);
Lwt.return (Ok parent_dnskeys)
in
retrieve_validated_dnskeys hostname >>= function
| Error _ as e -> Lwt.return e
| Ok dnskeys ->
Dns_client_lwt.(get_raw_reply t k hostname) >|= function
| Error e -> log_err e
| Ok reply ->
match Dnssec.verify_reply now dnskeys hostname k reply with
| Ok rrs ->
Logs.app (fun m -> m "%a" pp_zone (hostname, k, rrs));
Ok ()
| Error (`No_domain _ | `No_data _) ->
Logs.warn (fun m -> m "no data or no domain for %a (%a)"
Domain_name.pp hostname Rr_map.ppk (K k));
Ok ()
| Error e -> log_err e
)
| _ -> Error (`Msg "couldn't decode type")
open Cmdliner
let parse_domain : [ `raw ] Domain_name.t Arg.conv =
Arg.conv'
((fun name ->
Result.map_error
(function `Msg m -> Fmt.str "Invalid domain: %S: %s" name m)
(Domain_name.of_string name)),
Domain_name.pp)
let arg_domain : [ `raw ] Domain_name.t Term.t =
let doc = "Host to operate on" in
Arg.(value & opt parse_domain (Domain_name.of_string_exn "cloudflare.com")
& info [ "host" ] ~docv:"HOST" ~doc)
let parse_ip =
Arg.conv'
((fun s ->
match Ipaddr.of_string s with
| Ok ip -> Ok ip
| Error (`Msg m) -> Error ("failed to parse IP address: " ^ m)),
Ipaddr.pp)
let nameserver : Ipaddr.t option Term.t =
let doc = "Nameserver to use" in
Arg.(value & opt (some parse_ip) None & info [ "nameserver" ] ~docv:"NAMESERVER" ~doc)
let arg_typ : string Term.t =
let doc = "Type to query" in
Arg.(value & opt string "A" & info ["type"] ~docv:"TYPE" ~doc)
let cmd =
let term =
Term.(term_result (const jump $ Dns_cli.setup_log $ arg_domain $ arg_typ $ nameserver))
and info = Cmd.info "odnssec" ~version:"10.2.2"
in
Cmd.v info term
let () = exit (Cmd.eval cmd)

95
unikernel/duniverse/ocaml-dns/app/onotify.ml Normal file
View file

@ -0,0 +1,95 @@
(* (c) 2019 Hannes Mehnert, all rights reserved *)
open Dns
let notify zone serial key now =
let raw_zone = Domain_name.raw zone in
let question = Packet.Question.create raw_zone Soa
and soa =
{ Soa.nameserver = raw_zone ; hostmaster = raw_zone ; serial ;
refresh = 0l; retry = 0l ; expiry = 0l ; minimum = 0l }
and header = Randomconv.int16 Mirage_crypto_rng.generate, Packet.Flags.singleton `Authoritative
in
let p = Packet.create header question (`Notify (Some soa)) in
match key with
| None -> Ok (p, fst (Packet.encode `Tcp p), None)
| Some (keyname, _, dnskey) ->
Logs.debug (fun m -> m "signing with key %a: %a" Domain_name.pp keyname Dnskey.pp dnskey) ;
match Dns_tsig.encode_and_sign ~proto:`Tcp p now dnskey keyname with
| Ok (cs, mac) -> Ok (p, cs, Some mac)
| Error e -> Error e
let jump _ serverip port zone key serial =
Mirage_crypto_rng_unix.use_default ();
let now = Ptime_clock.now () in
Logs.app (fun m -> m "notifying to %a:%d zone %a serial %lu"
Ipaddr.pp serverip port Domain_name.pp zone serial) ;
match notify zone serial key now with
| Error s -> Error (`Msg (Fmt.str "signing %a" Dns_tsig.pp_s s))
| Ok (request, data, mac) ->
let data_len = String.length data in
Logs.debug (fun m -> m "built data %d" data_len) ;
let socket = Dns_cli.connect_tcp serverip port in
Dns_cli.send_tcp socket data ;
let read_data = Dns_cli.recv_tcp socket in
Unix.close socket ;
match key with
| None ->
begin match Packet.decode read_data with
| Ok reply ->
begin match Packet.reply_matches_request ~request reply with
| Ok `Notify_ack ->
Logs.app (fun m -> m "successful notify!") ;
Ok ()
| Ok r -> Error (`Msg (Fmt.str "expected notify ack, got %a" Packet.pp_reply r))
| Error e -> Error (`Msg (Fmt.str "notify reply %a is not ok %a"
Packet.pp reply Packet.pp_mismatch e))
end
| Error e ->
Error (`Msg (Fmt.str "failed to decode notify reply! %a" Packet.pp_err e))
end
| Some (keyname, _, dnskey) ->
match Dns_tsig.decode_and_verify now dnskey keyname ?mac read_data with
| Error e ->
Error (`Msg (Fmt.str "failed to decode TSIG signed notify reply! %a" Dns_tsig.pp_e e))
| Ok (reply, _, _) ->
match Packet.reply_matches_request ~request reply with
| Ok `Notify_ack ->
Logs.app (fun m -> m "successful TSIG signed notify!") ;
Ok ()
| Ok r -> Error (`Msg (Fmt.str "expected notify ack, got %a" Packet.pp_reply r))
| Error e ->
Error (`Msg (Fmt.str "expected reply to %a %a, got %a!"
Packet.pp_mismatch e
Packet.pp request Packet.pp reply))
open Cmdliner
let serverip =
let doc = "IP address of DNS server" in
Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"SERVERIP")
let port =
let doc = "Port to connect to" in
Arg.(value & opt int 53 & info [ "port" ] ~doc)
let serial =
let doc = "Serial number" in
Arg.(value & opt int32 1l & info [ "serial" ] ~doc)
let key =
let doc = "DNS HMAC secret (name:alg:b64key)" in
Arg.(value & opt (some Dns_cli.namekey_c) None & info [ "key" ] ~doc ~docv:"KEY")
let zone =
let doc = "Zone to notify" in
Arg.(required & pos 1 (some Dns_cli.name_c) None & info [] ~doc ~docv:"ZONE")
let cmd =
let info = Cmd.info "onotify" ~version:"10.2.2"
and term =
Term.(term_result (const jump $ Dns_cli.setup_log $ serverip $ port $ zone $ key $ serial))
in
Cmd.v info term
let () = exit (Cmd.eval cmd)

91
unikernel/duniverse/ocaml-dns/app/oupdate.ml Normal file
View file

@ -0,0 +1,91 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Dns
let create_update zone hostname ip_address =
let zone = Packet.Question.create zone Soa
and update =
let up =
Domain_name.Map.singleton hostname
[
Packet.Update.Remove (Rr_map.K A) ;
Packet.Update.Add Rr_map.(B (A, (60l, Ipaddr.V4.Set.singleton ip_address)))
]
in
(Domain_name.Map.empty, up)
and header = Randomconv.int16 Mirage_crypto_rng.generate, Packet.Flags.empty
in
Packet.create header zone (`Update update)
let jump _ serverip port (keyname, zone, dnskey) hostname ip_address =
Mirage_crypto_rng_unix.use_default ();
let now = Ptime_clock.now () in
Logs.app (fun m -> m "updating to %a:%d zone %a A 600 %a %a"
Ipaddr.pp serverip port
Domain_name.pp zone
Domain_name.pp hostname
Ipaddr.V4.pp ip_address) ;
Logs.debug (fun m -> m "using key %a: %a" Domain_name.pp keyname Dns.Dnskey.pp dnskey) ;
let p = create_update zone hostname ip_address in
match Dns_tsig.encode_and_sign ~proto:`Tcp p now dnskey keyname with
| Error s ->
Error (`Msg (Fmt.str "tsig sign error %a" Dns_tsig.pp_s s))
| Ok (data, mac) ->
let data_len = String.length data in
Logs.debug (fun m -> m "built data %d" data_len) ;
let socket = Dns_cli.connect_tcp serverip port in
Dns_cli.send_tcp socket data ;
let read_data = Dns_cli.recv_tcp socket in
(try (Unix.close socket) with _ -> ()) ;
match Dns_tsig.decode_and_verify now dnskey keyname ~mac read_data with
| Error e ->
Error (`Msg (Fmt.str "nsupdate error %a" Dns_tsig.pp_e e))
| Ok (reply, _, _) ->
match Packet.reply_matches_request ~request:p reply with
| Ok `Update_ack ->
Logs.app (fun m -> m "successful and signed update!") ;
Ok ()
| Ok r ->
Error (`Msg (Fmt.str "nsupdate expected update ack, received %a" Packet.pp_reply r))
| Error e ->
Error (`Msg (Fmt.str "nsupdate error %a (reply %a does not match request %a)"
Packet.pp_mismatch e Packet.pp reply Packet.pp p))
open Cmdliner
let serverip =
let doc = "IP address of DNS server" in
Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"SERVERIP")
let port =
let doc = "Port to connect to" in
Arg.(value & opt int 53 & info [ "port" ] ~doc)
let key =
let doc = "DNS HMAC secret (name:alg:b64key where name is yyy._update.zone)" in
Arg.(required & pos 1 (some Dns_cli.namekey_c) None & info [] ~doc ~docv:"KEY")
let hostname =
let doc = "Hostname to modify" in
Arg.(required & pos 2 (some Dns_cli.domain_name_c) None & info [] ~doc ~docv:"HOSTNAME")
let ipv4_c =
Arg.conv'
((fun s ->
match Ipaddr.V4.of_string s with
| Ok ip -> Ok ip
| Error (`Msg m) -> Error ("failed to parse IP address: " ^ m)),
Ipaddr.V4.pp)
let ip_address =
let doc = "New IP address" in
Arg.(required & pos 3 (some ipv4_c) None & info [] ~doc ~docv:"IP")
let cmd =
let term =
Term.(term_result (const jump $ Dns_cli.setup_log $ serverip $ port $ key $ hostname $ ip_address))
and info = Cmd.info "oupdate" ~version:"10.2.2"
in
Cmd.v info term
let () = exit (Cmd.eval cmd)

72
unikernel/duniverse/ocaml-dns/app/ozone.ml Normal file
View file

@ -0,0 +1,72 @@
(* (c) 2019 Hannes Mehnert, all rights reserved *)
(* goal is to check a given zonefile whether it is valid (and to-be-used
by an authoritative NS - i.e. there must be a SOA record, TTL are good)
if a NS/MX name is within the zone, it needs an address record
the name of the file is taken as the domain name *)
open Dns
let ( let* ) = Result.bind
let load_zone zone =
let* data = Bos.OS.File.read Fpath.(v zone) in
let* rrs = Dns_zone.parse data in
let domain = Domain_name.of_string_exn Fpath.(basename (v zone)) in
let bad = Domain_name.Map.filter
(fun name _ -> not (Domain_name.is_subdomain ~domain ~subdomain:name))
rrs
in
if not (Domain_name.Map.is_empty bad) then
Error (`Msg (Fmt.str "Entries of domain '%a' are not in its zone, won't handle this:@.%a"
Domain_name.pp domain Dns.Name_rr_map.pp bad))
else
Ok (Dns_trie.insert_map rrs Dns_trie.empty)
let jump _ zone old =
let* trie = load_zone zone in
let* () =
Result.map_error
(fun e -> `Msg (Fmt.to_to_string Dns_trie.pp_zone_check e))
(Dns_trie.check trie)
in
Logs.app (fun m -> m "successfully checked zone") ;
let zones =
Dns_trie.fold Soa trie
(fun name _ acc -> Domain_name.Set.add name acc)
Domain_name.Set.empty
in
if Domain_name.Set.cardinal zones = 1 then
let zone = Domain_name.Set.choose zones in
let* zone_data = Dns_server.text zone trie in
Logs.debug (fun m -> m "assembled zone data %s" zone_data) ;
(match old with
| None -> Ok ()
| Some fn ->
let* old = load_zone fn in
match Dns_trie.lookup zone Soa trie, Dns_trie.lookup zone Soa old with
| Ok fresh, Ok old when Soa.newer ~old fresh ->
Logs.debug (fun m -> m "zone %a newer than old" Domain_name.pp zone) ;
Ok ()
| _ ->
Error (`Msg "SOA comparison wrong"))
else
Error (`Msg "expected exactly one zone")
open Cmdliner
let newzone =
let doc = "New zone file" in
Arg.(required & pos 0 (some file) None & info [] ~doc ~docv:"ZONE")
let oldzone =
let doc = "Old zone file" in
Arg.(value & opt (some file) None & info [ "old" ] ~doc ~docv:"ZONE")
let cmd =
let term =
Term.(term_result (const jump $ Dns_cli.setup_log $ newzone $ oldzone))
and info = Cmd.info "ozone" ~version:"10.2.2"
in
Cmd.v info term
let () = exit (Cmd.eval cmd)

97
unikernel/duniverse/ocaml-dns/app/resolver.ml Normal file
View file

@ -0,0 +1,97 @@
module Resolver = Dns_resolver_mirage.Make(Tcpip_stack_socket.V4V6)
open Lwt.Infix
let pp_val ppf f =
let open Metrics in
match value f with
| V (String, s) -> Fmt.pf ppf "%S" s
| V (Int, i) -> Fmt.pf ppf "%d" i
| V (Int32, i32) -> Fmt.pf ppf "%ld" i32
| V (Int64, i64) -> Fmt.pf ppf "%Ld" i64
| V (Uint, u) -> Fmt.pf ppf "%u" u
| V (Uint32, u32) -> Fmt.pf ppf "%lu" u32
| V (Uint64, u64) -> Fmt.pf ppf "%Lu" u64
| _ -> pp_value ppf f
let print_resolver_stats () =
let map = Metrics.get_cache () in
let dns_resolver_src =
List.find (fun src -> Metrics.Src.name src = "dns-resolver") (Metrics.Src.list ())
in
let dns_resolver_metrics =
match Metrics.SM.find_opt dns_resolver_src map with
| None ->
print_endline "no dns-resolver found";
[]
| Some ms ->
List.concat_map (fun (_tags, data) -> Metrics.Data.fields data) ms
in
List.iter (fun field ->
Logs.app (fun m -> m "%s %a" (Metrics.key field) pp_val field))
dns_resolver_metrics;
exit 130
let main dnssec qname_min opportunistic =
Mirage_crypto_rng_unix.use_default ();
let reporter = Metrics.cache_reporter () in
Metrics.set_reporter reporter;
Metrics.enable_all ();
Udpv4v6_socket.connect ~ipv4_only:true ~ipv6_only:false Ipaddr.V4.Prefix.global None >>= fun udp ->
Tcpv4v6_socket.connect ~ipv4_only:true ~ipv6_only:false Ipaddr.V4.Prefix.global None >>= fun tcp ->
Tcpip_stack_socket.V4V6.connect udp tcp >>= fun stack ->
let resolver =
let primary_t =
(* setup DNS server state: *)
Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate Dns_trie.empty
in
let features =
(if dnssec then [ `Dnssec ] else []) @
(if qname_min then [ `Qname_minimisation ] else []) @
(if opportunistic then [ `Opportunistic_tls_authoritative ] else [])
in
Dns_resolver.create features ~ip_protocol:`Ipv4_only
(Mirage_mtime.elapsed_ns ()) Mirage_crypto_rng.generate primary_t
in
let _resolver = Resolver.resolver ~port:53530 stack resolver in
let _ : Sys.signal_behavior =
Sys.signal Sys.sigint
(Signal_handle
(fun _ -> print_resolver_stats ()))
in
Tcpip_stack_socket.V4V6.listen stack >|= fun () ->
Ok ()
let jump () dnssec qname_min opportunistic =
Lwt_main.run (main dnssec qname_min opportunistic)
open Cmdliner
let dnssec =
let doc =
Arg.info ~doc:"Validate DNS replies and cache DNSSEC data." [ "dnssec" ]
in
Arg.(value & flag doc)
let qname_minimisation =
let doc =
Arg.info ~doc:"Use qname minimisation (RFC 9156)." [ "qname-minimisation" ]
in
Arg.(value & flag doc)
let opportunistic_tls =
let doc =
Arg.info ~doc:"Use opportunistic TLS from recursive resolver to authoriative (RFC 9539)."
[ "opportunistic-tls-authoritative" ]
in
Arg.(value & flag doc)
let cmd =
let term =
Term.(term_result (const jump $ Dns_cli.setup_log $ dnssec $ qname_minimisation $ opportunistic_tls))
and info = Cmd.info "resolver" ~version:"10.2.2"
in
Cmd.v info term
let () = exit (Cmd.eval cmd)

378
unikernel/duniverse/ocaml-dns/cache/dns_cache.ml vendored Normal file
View file

@ -0,0 +1,378 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
let src = Logs.Src.create "dns_cache" ~doc:"DNS cache"
module Log = (val Logs.src_log src : Logs.LOG)
type rank =
| ZoneFile
| ZoneTransfer
| AuthoritativeAnswer of Rrsig.t option
| AuthoritativeAuthority of Rrsig.t option
| ZoneGlue
| NonAuthoritativeAnswer
| Additional
let compare_rrsig_opt a b =
match a, b with
| None, None -> 0
| Some _, None -> 1
| None, Some _ -> -1
| Some a, Some b ->
Ptime.compare a.Rrsig.signature_expiration b.Rrsig.signature_expiration
let compare_rank a b = match a, b with
| ZoneFile, ZoneFile -> 0
| ZoneFile, _ -> 1
| _, ZoneFile -> -1
| ZoneTransfer, ZoneTransfer -> 0
| ZoneTransfer, _ -> 1
| _, ZoneTransfer -> -1
| AuthoritativeAnswer signed, AuthoritativeAnswer signed' ->
compare_rrsig_opt signed signed'
| AuthoritativeAnswer _, _ -> 1
| _, AuthoritativeAnswer _ -> -1
| AuthoritativeAuthority signed, AuthoritativeAuthority signed' ->
compare_rrsig_opt signed signed'
| AuthoritativeAuthority _, _ -> 1
| _, AuthoritativeAuthority _ -> -1
| ZoneGlue, ZoneGlue -> 0
| ZoneGlue, _ -> 1
| _, ZoneGlue -> -1
| NonAuthoritativeAnswer, NonAuthoritativeAnswer -> 0
| NonAuthoritativeAnswer, _ -> 1
| _, NonAuthoritativeAnswer -> -1
| Additional, Additional -> 0
let pp_rank ppf = function
| ZoneFile -> Fmt.string ppf "zone file data"
| ZoneTransfer -> Fmt.string ppf "zone transfer data"
| AuthoritativeAnswer signed ->
Fmt.pf ppf "authoritative answer data (signed: %a)"
Fmt.(option ~none:(any "no") Rrsig.pp) signed
| AuthoritativeAuthority signed ->
Fmt.pf ppf "authoritative authority data (signed: %a)"
Fmt.(option ~none:(any "no") Rrsig.pp) signed
| ZoneGlue -> Fmt.string ppf "zone file glue"
| NonAuthoritativeAnswer -> Fmt.string ppf "non-authoritative answer"
| Additional -> Fmt.string ppf "additional data"
type 'a entry = [
| `Entry of 'a
| `No_data of [ `raw ] Domain_name.t * Soa.t
| `No_domain of [ `raw ] Domain_name.t * Soa.t
| `Serv_fail of [ `raw ] Domain_name.t * Soa.t
]
module RRMap = Map.Make(struct
type t = Rr_map.k
let compare = Rr_map.comparek
end)
module Entry = struct
type meta = int64 * rank
let pp_meta ppf (ts, rank) =
Fmt.pf ppf "%a created %Lu" pp_rank rank ts
type rr_map_entry =
| Entry of Rr_map.b
| No_data of [ `raw ] Domain_name.t * Soa.t
| Serv_fail of [ `raw ] Domain_name.t * Soa.t
let pp_map_entry ppf entry = match entry with
| Entry b -> Fmt.pf ppf "entry %a" Rr_map.pp_b b
| No_data (name, soa) -> Fmt.pf ppf "no data %a SOA %a" Domain_name.pp name Soa.pp soa
| Serv_fail (name, soa) -> Fmt.pf ppf "server fail %a SOA %a" Domain_name.pp name Soa.pp soa
let to_entry : type a. a Rr_map.key -> rr_map_entry -> a entry = fun typ r -> match r with
| Entry (B (k, v)) -> begin match Rr_map.K.compare typ k with Gmap.Order.Eq -> `Entry v | _ -> assert false end
| No_data (name, soa) -> `No_data (name, soa)
| Serv_fail (name, soa) -> `Serv_fail (name, soa)
let of_entry typ = function
| `Entry v -> Entry (B (typ, v))
| `No_data (name, soa) -> No_data (name, soa)
| `Serv_fail (name, soa) -> Serv_fail (name, soa)
| _ -> assert false
type t =
| No_domain of meta * [ `raw ] Domain_name.t * Soa.t
| Rr_map of (meta * rr_map_entry) RRMap.t
(* Part of the LRU.Weighted interface *)
let weight = function
| No_domain _ -> 1
| Rr_map tm -> RRMap.cardinal tm
let pp_entry ppf (meta, entry) = Fmt.pf ppf "e (%a) %a" pp_meta meta pp_map_entry entry
let pp ppf = function
| No_domain (meta, name, soa) ->
Fmt.pf ppf "no domain (%a) %a SOA %a" pp_meta meta Domain_name.pp name Soa.pp soa
| Rr_map rr ->
Fmt.pf ppf "entries: %a"
Fmt.(list ~sep:(any ";@,") (pair Rr_map.ppk pp_entry))
(RRMap.bindings rr)
end
module Key = struct
type t = [ `raw ] Domain_name.t
let compare = Domain_name.compare
end
module LRU = Lru.F.Make(Key)(Entry)
type t = LRU.t
let metrics =
let f = function
| `Lookup -> "lookups"
| `Hit -> "hits"
| `Miss -> "misses"
| `Drop -> "drops"
| `Insert -> "insertions"
in
let incr, get = create_counter ~f in
let data (cache, thing) =
incr thing;
Metrics.Data.v
(Metrics.uint "size" (LRU.size cache) ::
Metrics.uint "weight" (LRU.weight cache) ::
Metrics.uint "capacity" (LRU.capacity cache) ::
get ())
in
let src = Metrics.Src.v ~tags:Metrics.Tags.[] ~data "dns-cache" in
(fun cache r -> Metrics.add src (fun x -> x) (fun d -> d (cache, r)))
let empty = LRU.empty
let size = LRU.size
let capacity = LRU.capacity
let pp = LRU.pp Fmt.(pair ~sep:(any ": ") Domain_name.pp Entry.pp)
module N = Domain_name.Set
let compute_updated_ttl ~created ~now ttl =
Int32.sub ttl (Int32.of_int (Duration.to_sec (Int64.sub now created)))
let pp_entry key ppf entry =
let pp_ns ppf (name, soa) = Fmt.pf ppf "%a SOA %a" Domain_name.pp name Soa.pp soa in
match entry with
| `Entry v -> Fmt.pf ppf "entry %a" Rr_map.pp_b (B (key, v))
| `No_data ns -> Fmt.(append (any "no data ") pp_ns) ppf ns
| `No_domain ns -> Fmt.(append (any "no domain ") pp_ns) ppf ns
| `Serv_fail ns -> Fmt.(append (any "serv fail ") pp_ns) ppf ns
let get_ttl k = function
| `Entry v -> Rr_map.ttl k v
| `No_data (_, soa) -> soa.Soa.minimum
| `No_domain (_, soa) -> soa.Soa.minimum
| `Serv_fail (_, soa) -> soa.Soa.minimum
let with_ttl : type a . a Rr_map.key -> int32 -> a entry -> a entry = fun k ttl r -> match r with
| `Entry v ->
let v' = Rr_map.with_ttl k v ttl in
`Entry v'
| `No_data (name, soa) -> `No_data (name, { soa with Soa.minimum = ttl })
| `No_domain (name, soa) -> `No_domain (name, { soa with Soa.minimum = ttl })
| `Serv_fail (name, soa) -> `Serv_fail (name, { soa with Soa.minimum = ttl })
let rec no_dom_upwards cache name =
if Domain_name.count_labels name > 1 then
let name' = Domain_name.drop_label_exn name in
match LRU.find name' cache with
| None -> no_dom_upwards cache name'
| Some No_domain (meta, name, soa) -> None, Ok (meta, `No_domain (name, soa))
| Some _ -> None, Error `Cache_miss
else
None, Error `Cache_miss
let find cache name query_type =
match LRU.find name cache with
| None -> no_dom_upwards cache name
| Some No_domain (meta, name, soa) -> None, Ok (meta, `No_domain (name, soa))
| Some Rr_map resource_records ->
Some resource_records,
match RRMap.find_opt (K query_type) resource_records with
| Some (meta, entry) -> Ok (meta, Entry.to_entry query_type entry)
| None -> Error `Cache_miss
let insert cache ?map ts name query_type rank entry =
let meta = ts, rank in
let cache = match entry with
| `No_domain (name', soa) -> LRU.add name (No_domain (meta, name', soa)) cache
| `Entry _ | `No_data _ | `Serv_fail _ ->
let map = match map with None -> RRMap.empty | Some x -> x in
let map' = RRMap.add (K query_type) (meta, Entry.of_entry query_type entry) map in
LRU.add name (Rr_map map') cache
in
(* Make sure we are within memory bounds *)
LRU.trim cache
let update_ttl typ entry ~created ~now =
let ttl = get_ttl typ entry in
let updated_ttl = compute_updated_ttl ~created ~now ttl in
if updated_ttl < 0l then Error `Cache_drop else Ok (with_ttl typ updated_ttl entry)
let get cache ts name query_type =
metrics cache `Lookup;
match snd (find cache name query_type) with
| Error e -> metrics cache `Miss; cache, Error e
| Ok ((created, rank), entry) ->
match update_ttl query_type entry ~created ~now:ts with
| Ok entry' -> metrics cache `Hit; LRU.promote name cache, Ok (entry', rank)
| Error e -> metrics cache `Drop; cache, Error e
let find_any cache name =
match LRU.find name cache with
| None -> Error `Cache_miss
| Some No_domain (meta, name, soa) -> Ok (`No_domain (meta, name, soa))
| Some Rr_map rrs -> Ok (`Entries rrs)
let get_any cache ts name =
metrics cache `Lookup;
match find_any cache name with
| Error e -> metrics cache `Miss; cache, Error e
| Ok r ->
let ttl created curr =
let ttl = compute_updated_ttl ~created ~now:ts curr in
if ttl < 0l then Error `Cache_drop else Ok ttl
in
LRU.promote name cache,
match r with
| `No_domain ((created, rank), name, soa) ->
begin match ttl created soa.Soa.minimum with
| Error _ as e -> metrics cache `Drop; e
| Ok minimum ->
metrics cache `Hit;
Ok (`No_domain (name, { soa with Soa.minimum }), rank)
end
| `Entries rrs ->
let rrs, r =
RRMap.fold (fun _k ((created, rank), v) (acc, r) ->
match v with
| Entry.Entry B (k, v) ->
begin match ttl created (Rr_map.ttl k v) with
| Ok ttl ->
let v' = Rr_map.with_ttl k v ttl in
Rr_map.add k v' acc, rank
| Error _ -> acc, r
end
| _ -> acc, r) rrs (Rr_map.empty, Additional)
in
match Rr_map.is_empty rrs with
| true -> metrics cache `Drop; Error `Cache_drop
| false -> metrics cache `Hit; Ok (`Entries rrs, r)
let get_or_cname : type a . t -> int64 -> [`raw] Domain_name.t -> a Rr_map.key ->
t * ([ a entry | `Alias of int32 * [`raw] Domain_name.t] * rank,
[ `Cache_drop | `Cache_miss ]) result =
fun cache ts name query_type ->
metrics cache `Lookup;
let map_result : _ -> t * ([ a entry | `Alias of int32 * [`raw] Domain_name.t] * rank, [ `Cache_drop | `Cache_miss ]) result = function
| Error e -> metrics cache `Miss; cache, Error e
| Ok ((created, rank), entry) ->
match update_ttl query_type entry ~created ~now:ts with
| Ok entry' -> metrics cache `Hit; LRU.promote name cache, Ok ((entry', rank) :> [ _ entry | `Alias of int32 * [`raw] Domain_name.t ] * rank)
| Error e -> metrics cache `Drop; cache, Error e
in
match find cache name query_type with
| Some map, r ->
begin match RRMap.find_opt (K Cname) map with
| Some ((created, rank), Entry.Entry (B (Cname, (ttl, name)))) ->
let ttl = compute_updated_ttl ~created ~now:ts ttl in
if ttl < 0l then
map_result r
else begin
metrics cache `Hit;
LRU.promote name cache, Ok (`Alias (ttl, name), rank)
end
| _ -> map_result r
end
| _, e -> map_result e
let get_nsec3 cache ts name =
metrics cache `Lookup;
let zone_labels = Domain_name.count_labels name in
let nsec3_rrs =
LRU.fold (fun ename entry acc ->
if
Domain_name.is_subdomain ~domain:name ~subdomain:ename &&
Domain_name.count_labels ename - 1 = zone_labels
then
match entry with
| Rr_map rrs ->
begin
match RRMap.find_opt (K Nsec3) rrs with
| Some ((created, r), (Entry (B (Nsec3, v)) as e)) ->
begin match update_ttl Nsec3 (Entry.to_entry Nsec3 e) ~created ~now:ts with
| Ok `Entry (ttl, _) -> (ename, ttl, snd v, r) :: acc
| Ok _ -> acc
| Error _ -> acc
end
| _ -> acc
end
| _ -> acc
else
acc)
[] cache
in
match nsec3_rrs with
| [] ->
metrics cache `Miss;
cache, Error `Cache_miss
| xs ->
metrics cache `Hit;
List.fold_right LRU.promote (List.map (fun (a, _, _, _) -> a) xs) cache,
Ok xs
(* XXX: we may want to define a minimum as well (5 minutes? 30 minutes?
use SOA expiry?) MS used to use 24 hours in internet explorer
from RFC1034 on this topic:
The idea is that if cached data is known to come from a particular zone,
and if an authoritative copy of the zone's SOA is obtained, and if the
zone's SERIAL has not changed since the data was cached, then the TTL of
the cached data can be reset to the zone MINIMUM value if it is smaller.
This usage is mentioned for planning purposes only, and is not
recommended as yet.
and 2308, Sec 4:
Despite being the original defined meaning, the first of these, the
minimum TTL value of all RRs in a zone, has never in practice been
used and is hereby deprecated.
and 1035 6.2:
The MINIMUM value in the SOA should be used to set a floor on the TTL of data
distributed from a zone. This floor function should be done when the data is
copied into a response. This will allow future dynamic update protocols to
change the SOA MINIMUM field without ambiguous semantics.
*)
(* according to RFC1035, section 7.3, a TTL of a week is a good
maximum value! *)
let week = Int32.of_int Duration.(to_sec (of_day 7))
let clip_ttl_to_week query_type entry =
let ttl = get_ttl query_type entry in
if ttl < week then entry else with_ttl query_type week entry
let pp_query ppf (name, query_type) =
Fmt.pf ppf "%a (%a)" Domain_name.pp name Packet.Question.pp_qtype query_type
let set cache ts name query_type rank entry =
let entry' = clip_ttl_to_week query_type entry in
let cache' map = insert cache ?map ts name query_type rank entry' in
match find cache name query_type with
| map, Error _ ->
Log.debug (fun m -> m "set: %a nothing found, adding: %a"
pp_query (name, `K (K query_type)) (pp_entry query_type) entry');
metrics cache `Insert; cache' map
| map, Ok ((created, rank'), entry) ->
Log.debug (fun m -> m "set: %a found rank %a insert rank %a: %d"
pp_query (name, `K (K query_type)) pp_rank rank' pp_rank rank (compare_rank rank' rank));
match update_ttl query_type entry ~created ~now:ts, compare_rank rank' rank with
| Ok _, 1 -> cache
| _ -> metrics cache `Insert; cache' map
let remove cache name =
LRU.remove name cache

90
unikernel/duniverse/ocaml-dns/cache/dns_cache.mli vendored Normal file
View file

@ -0,0 +1,90 @@
(** DNS cache - a least recently used cache of DNS responses
This data structure allows to insert and retrieve entries into a least
recently used data structure. An [`Entry] weights the cardinality of the
resource record map, all other entries have a weight of 1.
The time to live is preserved, and when it is exceeded the entry is no
longer returned.
*)
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
(** The variant of the rank in the cache. *)
type rank =
| ZoneFile
| ZoneTransfer
| AuthoritativeAnswer of Rrsig.t option
| AuthoritativeAuthority of Rrsig.t option
| ZoneGlue
| NonAuthoritativeAnswer
| Additional
val pp_rank : rank Fmt.t
(** [pp_rank ppf rank] pretty-prints the [rank] on [ppf]. *)
val compare_rank : rank -> rank -> int
(** [compare_rank a b] compares the ranks [a] with [b]. *)
(** The type of a DNS cache. *)
type t
val empty : int -> t
(** [empty maximum_size] is an empty DNS cache with the maximum size as
capacity. *)
val size : t -> int
(** [size cache] is the number of bindings currently in the [cache]. *)
val capacity : t -> int
(** [capacity cache] is the used weight. *)
val pp : t Fmt.t
(** [pp ppf t] pretty prints the cache [t] on [ppf]. *)
(** The polymorphic variant of an entry: a resource record, or no data,
no domain, or a server failure. *)
type 'a entry = [
| `Entry of 'a
| `No_data of [ `raw ] Domain_name.t * Soa.t
| `No_domain of [ `raw ] Domain_name.t * Soa.t
| `Serv_fail of [ `raw ] Domain_name.t * Soa.t
]
val pp_entry : 'a Rr_map.key -> 'a entry Fmt.t
(** [pp_entry ppf entry] pretty-prints [entry] on [ppf]. *)
val get : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key ->
t * ('a entry * rank, [ `Cache_miss | `Cache_drop ]) result
(** [get cache timestamp type name] retrieves the query [type, name] from the
[cache] using [timestamp]. If the time to live is exceeded, a [`Cache_drop]
is returned. If there is no entry in the cache, a [`Cache_miss] is
returned. *)
val get_or_cname : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key ->
t * ([ 'a entry | `Alias of int32 * [`raw] Domain_name.t] * rank,
[ `Cache_miss | `Cache_drop ]) result
(** [get_or_cname cache timestamp type name] is the same as [get], but if a
[`Cache_miss] is encountered, a lookup for an alias (CNAME) is done. *)
val get_any : t -> int64 -> [ `raw ] Domain_name.t ->
t * ([ `Entries of Rr_map.t
| `No_domain of [ `raw ] Domain_name.t * Soa.t ] * rank,
[ `Cache_miss | `Cache_drop ]) result
(** [get_any cache timestamp name] retrieves all resource records for [name]
in [cache]. *)
val get_nsec3 : t -> int64 -> [ `raw ] Domain_name.t ->
t * (([`raw] Domain_name.t * int32 * Nsec3.t * rank) list, [ `Cache_miss | `Cache_drop ]) result
(** [get_nsec3 cache timestamp name] retrieves all nsec3 resource records for
the zone [name]. *)
val set : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key -> rank ->
'a entry -> t
(** [set cache timestamp type name rank value] attempts to insert
[type, name, value] into the [cache] using the [timestamp] and [rank]. If
an entry already exists with a higher [rank], the [cache] is unchanged. *)
val remove : t -> [ `raw ] Domain_name.t -> t
(** [remove cache name] removes [name] from [cache]. *)

6
unikernel/duniverse/ocaml-dns/cache/dune vendored Normal file
View file

@ -0,0 +1,6 @@
(library
(name dns_cache)
(public_name dns.cache)
(modules dns_cache)
(libraries domain-name dns duration lru metrics)
(wrapped false))

207
unikernel/duniverse/ocaml-dns/certify/dns_certify.ml Normal file
View file

@ -0,0 +1,207 @@
open Dns
let src = Logs.Src.create "dns_certify" ~doc:"DNS certify"
module Log = (val Logs.src_log src : Logs.LOG)
let tlsa_is usage sel typ t =
t.Tlsa.cert_usage = usage &&
t.Tlsa.selector = sel &&
t.Tlsa.matching_type = typ
let is_csr t =
tlsa_is Tlsa.Domain_issued_certificate Tlsa.Private Tlsa.No_hash t
let csr req =
let data = X509.Signing_request.encode_der req in
{
Tlsa.matching_type = Tlsa.No_hash ;
cert_usage = Tlsa.Domain_issued_certificate ;
selector = Tlsa.Private ;
data
}
let is_certificate t =
tlsa_is Tlsa.Domain_issued_certificate Tlsa.Full_certificate Tlsa.No_hash t
let certificate cert =
let data = X509.Certificate.encode_der cert in
{
Tlsa.matching_type = Tlsa.No_hash ;
cert_usage = Tlsa.Domain_issued_certificate ;
selector = Tlsa.Full_certificate ;
data
}
let is_ca_certificate t =
tlsa_is Tlsa.CA_constraint Tlsa.Full_certificate Tlsa.No_hash t
let ca_certificate data = {
Tlsa.matching_type = Tlsa.No_hash ;
cert_usage = Tlsa.CA_constraint ;
selector = Tlsa.Full_certificate ;
data
}
let signing_request hostname ?(more_hostnames = []) key =
let host = Domain_name.to_string hostname in
let extensions =
match more_hostnames with
| [] -> X509.Signing_request.Ext.empty
| _ ->
let ext =
let additional = List.map Domain_name.to_string more_hostnames in
let gn = X509.General_name.(singleton DNS (host :: additional)) in
X509.Extension.(singleton Subject_alt_name (false, gn))
in
X509.Signing_request.Ext.(singleton Extensions ext)
in
X509.(Signing_request.create
[Distinguished_name.(Relative_distinguished_name.singleton (CN host))]
~extensions key)
let dns_header rng =
let id = Randomconv.int16 rng in
(id, Packet.Flags.empty)
let le_label = "_letsencrypt"
and p_label = "_tcp"
let is_name name =
if Domain_name.count_labels name < 2 then
false
else
Domain_name.(equal_label le_label (get_label_exn name 0) &&
equal_label p_label (get_label_exn name 1))
let letsencrypt_name name =
match Domain_name.(prepend_label (raw name) p_label) with
| Ok name' -> Domain_name.prepend_label name' le_label
| Error e -> Error e
type u_err = [ `Tsig of Dns_tsig.e | `Bad_reply of Packet.mismatch * Packet.t | `Unexpected_reply of Packet.reply ]
let pp_u_err ppf = function
| `Tsig e -> Fmt.pf ppf "tsig error %a" Dns_tsig.pp_e e
| `Bad_reply (e, res) -> Fmt.pf ppf "bad reply %a: %a" Packet.pp_mismatch e Packet.pp res
| `Unexpected_reply r -> Fmt.pf ppf "unexpected reply %a" Packet.pp_reply r
let nsupdate rng now ~host ~keyname ~zone dnskey request =
match letsencrypt_name host with
| Error e -> Error e
| Ok host ->
let tlsa = csr request in
let zone = Packet.Question.create zone Soa
and update =
let up =
Domain_name.Map.singleton host
[
Packet.Update.Remove (K Tlsa) ;
Packet.Update.Add (B (Tlsa, (3600l, Rr_map.Tlsa_set.singleton tlsa)))
]
in
(Domain_name.Map.empty, up)
and header = dns_header rng
in
let packet = Packet.create header zone (`Update update) in
let now = now () in
match Dns_tsig.encode_and_sign ~proto:`Tcp packet now dnskey keyname with
| Error e -> Error (`Msg (Fmt.to_to_string Dns_tsig.pp_s e))
| Ok (data, mac) ->
Ok (data, (fun data ->
match Dns_tsig.decode_and_verify now dnskey keyname ~mac data with
| Error e -> Error (`Tsig e)
| Ok (res, _, _) ->
match Packet.reply_matches_request ~request:packet res with
| Ok `Update_ack -> Ok ()
| Ok r -> Error (`Unexpected_reply r)
| Error e -> Error (`Bad_reply (e, res))))
type q_err = [
| `Decode of Packet.err
| `Bad_reply of Packet.mismatch * Packet.t
| `Unexpected_reply of Packet.reply
| `No_tlsa
]
let pp_q_err ppf = function
| `Decode err -> Fmt.pf ppf "decoding failed %a" Packet.pp_err err
| `Bad_reply (e, res) -> Fmt.pf ppf "bad reply %a: %a" Packet.pp_mismatch e Packet.pp res
| `Unexpected_reply r -> Fmt.pf ppf "unexpected reply %a" Packet.pp_reply r
| `No_tlsa -> Fmt.pf ppf "No TLSA record found"
(* may be better suited in X509? *)
let cert_matches_csr ?until now csr cert =
let until = match until with None -> now | Some x -> x in
let csr_key = X509.Signing_request.((info csr).public_key)
and csr_hostnames = X509.Signing_request.hostnames csr
and cert_key = X509.Certificate.public_key cert
and cert_hostnames = X509.Certificate.hostnames cert
and (st, en) = X509.Certificate.validity cert
in
let valid = Ptime.is_later ~than:st now && Ptime.is_later ~than:until en in
if not (String.equal (X509.Public_key.fingerprint cert_key) (X509.Public_key.fingerprint csr_key)) then begin
Log.info (fun m -> m "public key of CSR and certificate %a do not match"
X509.Certificate.pp cert);
false
end else if not (X509.Host.Set.equal cert_hostnames csr_hostnames) then begin
Log.info (fun m -> m "hostnames of CSR %a and certificate %a do not match"
X509.Host.Set.pp csr_hostnames X509.Host.Set.pp cert_hostnames);
false
end else if not valid then begin
let pp_pt = Ptime.pp_rfc3339 () in
Log.info (fun m -> m "Certificate is not valid now %a (until %a), it is \
valid from %a until %a)"
pp_pt now pp_pt until pp_pt st pp_pt en);
false
end else
true
let tlsas_to_certchain host now csr tlsas =
let certificates, ca_certificates =
Rr_map.Tlsa_set.fold (fun tlsa (certs, cacerts as acc) ->
if is_certificate tlsa || is_ca_certificate tlsa then
match X509.Certificate.decode_der tlsa.Tlsa.data with
| Error (`Msg msg) ->
Log.warn (fun m -> m "couldn't decode tlsa record %a: %s (%a)"
Domain_name.pp host msg
Ohex.pp tlsa.Tlsa.data);
acc
| Ok cert ->
match is_certificate tlsa, is_ca_certificate tlsa with
| true, _ -> (cert :: certs, cacerts)
| _, true -> (certs, cert :: cacerts)
| _ -> acc
else acc)
tlsas ([], [])
in
match List.find_opt (cert_matches_csr now csr) certificates with
| None -> Error `No_tlsa
| Some server_cert ->
match List.rev (X509.Validation.build_paths server_cert ca_certificates) with
| (_server :: chain) :: _ -> Ok (server_cert, chain)
| _ -> Ok (server_cert, []) (* build_paths always returns the server_cert *)
let query rng now host csr =
match letsencrypt_name host with
| Error e -> Error e
| Ok host ->
let header = dns_header rng
and question = Packet.Question.create host Tlsa
in
let request = Packet.create header question `Query in
let out, _ = Packet.encode `Tcp request
and react data =
match Packet.decode data with
| Error e -> Error (`Decode e)
| Ok reply ->
match Packet.reply_matches_request ~request reply with
| Ok (`Answer (answer, _)) ->
begin match Name_rr_map.find host Tlsa answer with
| None -> Error `No_tlsa
| Some (_, tlsas) -> tlsas_to_certchain host now csr tlsas
end
| Ok (`Rcode_error (Rcode.NXDomain, Opcode.Query, _)) -> Error `No_tlsa
| Ok reply -> Error (`Unexpected_reply reply)
| Error e -> Error (`Bad_reply (e, reply))
in
Ok (out, react)

93
unikernel/duniverse/ocaml-dns/certify/dns_certify.mli Normal file
View file

@ -0,0 +1,93 @@
open Dns
val signing_request : [`host] Domain_name.t ->
?more_hostnames:([`raw] Domain_name.t list) ->
X509.Private_key.t -> (X509.Signing_request.t, [> `Msg of string ]) result
(** [signing_request name ~more_hostnames key] creates a X509 signing request
where [name] will be the common name in its subject, and if [more_hostnames]
is provided and non-empty, [name :: more_hostnames] will be the value of a
subjectAlternativeName extension. *)
val letsencrypt_name : 'a Domain_name.t ->
([ `raw ] Domain_name.t, [> `Msg of string ]) result
(** [letsencrypt_name host] is the service name at which we store let's encrypt
certificates for the [host]. *)
val is_csr : Dns.Tlsa.t -> bool
(** [is_csr tlsa] is true if [tlsa] is a certificate signing request (cert_usage
is Domain_issued_certificate, selector is Private, and matching_type is
No_hash). *)
val csr : X509.Signing_request.t -> Dns.Tlsa.t
(** [csr req] is the signing request [req] encoded as TLSA record. *)
val is_certificate : Dns.Tlsa.t -> bool
(** [is_certificate tlsa] is true if [tlsa] is a certificate (cert_usage is
Domain_issued_certificate, selector is Full_certificate, and matching_type
is No_hash). *)
val certificate : X509.Certificate.t -> Dns.Tlsa.t
(** [certificate crt] is the certificate [crt] encoded as TLSA record. *)
val is_ca_certificate : Dns.Tlsa.t -> bool
(** [is_ca_certificate tlsa] is true if [tlsa] is a CA certificate (cert_usage
is CA_constraint, selector is Full_certificate, and matching_type is
No_hash). *)
val ca_certificate : string -> Dns.Tlsa.t
(** [ca_certificate data] is the CA certificate [data] encoded as TLSA record. *)
val is_name : 'a Domain_name.t -> bool
(** [is_name domain_name] is true if it contains the prefix used in this
library ("_letsencrypt._tcp"). *)
type u_err = [
| `Tsig of Dns_tsig.e
| `Bad_reply of Packet.mismatch * Packet.t
| `Unexpected_reply of Packet.reply
]
(** The type of update errors. *)
val pp_u_err : u_err Fmt.t
(** [pp_u_err ppf u] pretty-prints [u] on [ppf]. *)
val nsupdate : (int -> string) -> (unit -> Ptime.t) ->
host:[ `host ] Domain_name.t -> keyname:'b Domain_name.t ->
zone:[ `host ] Domain_name.t -> Dns.Dnskey.t -> X509.Signing_request.t ->
(string * (string -> (unit, [> u_err ]) result),
[> `Msg of string ]) result
(** [nsupdate rng now ~host ~keyname ~zone dnskey csr] is a buffer with a DNS
update that removes all TLSA records from the given [host], and adds a single
TLSA record containing the certificate signing request. It also returns a
function which decodes a given answer, checks it to be a valid reply, and
returns either unit or an error. The outgoing packet is signed with the
provided [dnskey], the answer is checked to be signed by the same key. If
the sign operation fails, [nsupdate] returns an error. *)
type q_err = [
| `Decode of Packet.err
| `Bad_reply of Packet.mismatch * Packet.t
| `Unexpected_reply of Packet.reply
| `No_tlsa
]
(** The type for query errors. *)
val pp_q_err : q_err Fmt.t
(** [pp_q_err ppf q] pretty-prints [q] on [ppf]. *)
val cert_matches_csr : ?until:Ptime.t -> Ptime.t -> X509.Signing_request.t ->
X509.Certificate.t -> bool
(** [cert_matches_csr ~until now csr cert] is [true] if [cert] matches the
signing request [csr], and is valid from [now] until [until] (defaults to
[now]). The matching is [true] if the public key matches, and the set of
hostnames in [csr] and [cert] are equal. A log message on the info level
is emitted if the return value if [false]. *)
val query : (int -> string) -> Ptime.t -> [ `host ] Domain_name.t ->
X509.Signing_request.t ->
(string *
(string -> (X509.Certificate.t * X509.Certificate.t list, [> q_err ]) result),
[> `Msg of string ]) result
(** [query rng now csr] is a [buffer] with a DNS TLSA query for the name of
[csr], and a function that decodes a given answer, either returning a X.509
certificate valid [now] and matching [csr], and a CA chain, or an error. *)

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

@ -0,0 +1,5 @@
(library
(name dns_certify)
(public_name dns-certify)
(wrapped false)
(libraries dns dns-tsig x509 randomconv logs mirage-crypto-ec mirage-crypto-pk))

340
unikernel/duniverse/ocaml-dns/client/dns_client.ml Normal file
View file

@ -0,0 +1,340 @@
open Dns
let src = Logs.Src.create "dns_client" ~doc:"DNS client"
module Log = (val Logs.src_log src : Logs.LOG)
module Pure = struct
type 'key query_state =
{ protocol : Dns.proto ;
key: 'key ;
query : Packet.t ;
} constraint 'key = 'a Rr_map.key
let make_query rng protocol ?(dnssec = false) edns hostname
: 'xy ->
string * 'xy query_state =
(* SRV records: Service + Protocol are case-insensitive, see RFC2728 pg2. *)
fun record_type ->
let edns = match edns with
| `None -> None
| `Manual e -> Some e
| `Auto -> match protocol with
| `Udp -> None
| `Tcp -> Some (Edns.create ~extensions:[Edns.Tcp_keepalive (Some 1200)] ())
in
let question = Packet.Question.create hostname record_type in
let header =
let flags = Packet.Flags.singleton `Recursion_desired in
let flags =
if dnssec then Packet.Flags.add `Authentic_data flags else flags
in
Randomconv.int16 rng, flags
in
let query = Packet.create ?edns header question `Query in
Log.debug (fun m -> m "sending %a" Dns.Packet.pp query);
let cs , _ = Packet.encode protocol query in
begin match protocol with
| `Udp -> cs
| `Tcp ->
let len_field = Bytes.create 2 in
Bytes.set_uint16_be len_field 0 (String.length cs) ;
String.concat "" [Bytes.unsafe_to_string len_field ; cs]
end, { protocol ; query ; key = record_type }
(* name: the originally requested domain name. *)
(* NOTE that this function compresses answers:
foo.example CNAME 500 bar.example
bar.example A 300 1.2.3.4
is compressed to:
foo.example A 300 1.2.3.4
-> which is fine for applications (i think so)
-> which is struggling for the cache (not entirely sure about this tbh)
-> it is not clear whether it meets the DNS specifications nicely *)
let rec follow_cname name ~iterations:iterations_left ~answer ~state =
if iterations_left <= 0
then Error (`Msg "CNAME recursion too deep")
else
match Domain_name.Map.find_opt name answer with
| None -> Ok (`Need_soa name)
| Some relevant_map ->
match Rr_map.find state.key relevant_map with
| Some response -> Ok (`Data response)
| None ->
match Rr_map.(find Cname relevant_map) with
| None -> Error (`Msg "Invalid DNS response")
| Some (_ttl, redirected_host) ->
let iterations = pred iterations_left in
follow_cname redirected_host ~iterations ~answer ~state
let consume_protocol_prefix buf =
function (* consume TCP two-byte length prefix: *)
| `Udp -> Ok buf
| `Tcp ->
match String.get_uint16_be buf 0 with
| exception Invalid_argument _ -> Error () (* TODO *)
| pkt_len when pkt_len > String.length buf -2 ->
Log.debug (fun m -> m "Partial: %d >= %d-2"
pkt_len (String.length buf));
Error () (* TODO return remaining # *)
| pkt_len ->
if 2 + pkt_len < String.length buf then
Log.warn (fun m -> m "Extraneous data in DNS response");
Ok (String.sub buf 2 pkt_len)
let find_soa authority =
Domain_name.Map.fold (fun k rr_map acc ->
match Rr_map.(find Soa rr_map) with
| Some soa -> Some (Domain_name.raw k, soa)
| None -> acc)
authority None
let distinguish_answer state =
let ( let* ) = Result.bind in
function
| `Answer (answer, authority) when not (Domain_name.Map.is_empty answer) ->
begin
let q = fst state.query.question in
let* o = follow_cname q ~iterations:20 ~answer ~state in
match o with
| `Data x -> Ok (`Data x)
| `Need_soa _name ->
(* should we retain CNAMEs (and send them to the client)? *)
(* should we 'adjust' the SOA name to be _name? *)
match find_soa authority with
| Some soa -> Ok (`No_data soa)
| None -> Error (`Msg "invalid reply, couldn't find SOA")
end
| `Answer (_, authority) ->
begin match find_soa authority with
| Some soa -> Ok (`No_data soa)
| None -> Error (`Msg "invalid reply, no SOA in no data")
end
| `Rcode_error (Rcode.NXDomain, Opcode.Query, Some (_answer, authority)) ->
begin match find_soa authority with
| Some soa -> Ok (`No_domain soa)
| None -> Error (`Msg "invalid reply, no SOA in nodomain")
end
| r ->
Error (`Msg (Fmt.str "Ok %a, expected answer" Packet.pp_reply r))
let consume_rest_of_buffer state buf =
let to_msg t =
Result.map_error (fun e ->
`Msg
(Fmt.str
"QUERY: @[<v>hdr:%a (id: %d = %d) (q=q: %B)@ query:%a%a \
opt:%a tsig:%B@,failed: %a@,@]"
Packet.pp_header t
(fst t.header) (fst state.query.header)
(Packet.Question.compare t.question state.query.question = 0)
Packet.Question.pp t.question
Packet.pp_data t.data
(Fmt.option Dns.Edns.pp) t.edns
(match t.tsig with None -> false | Some _ -> true)
Packet.pp_mismatch e))
in
match Packet.decode buf with
| Error `Partial as e -> e
| Error err ->
Error (`Msg (Fmt.str "Error parsing response: %a" Packet.pp_err err))
| Ok t ->
Log.debug (fun m -> m "received %a" Dns.Packet.pp t);
to_msg t (Packet.reply_matches_request ~request:state.query t)
let parse_response (type requested)
: requested Rr_map.key query_state -> string ->
(Packet.reply,
[> `Partial
| `Msg of string]) result =
fun state buf ->
match consume_protocol_prefix buf state.protocol with
| Ok buf -> consume_rest_of_buffer state buf
| Error () -> Error `Partial
let handle_response (type requested)
: requested Rr_map.key query_state -> string ->
( [ `Data of requested
| `Partial
| `No_data of [`raw] Domain_name.t * Soa.t
| `No_domain of [`raw] Domain_name.t * Soa.t ],
[`Msg of string]) result =
fun state buf ->
match parse_response state buf with
| Error `Partial -> Ok `Partial
| Error `Msg _ as e -> e
| Ok reply -> distinguish_answer state reply
end
(* Anycast address of uncensoreddns.org *)
let default_resolver_hostname = Domain_name.(host_exn (of_string_exn "anycast.uncensoreddns.org"))
let default_resolvers = [
Ipaddr.of_string_exn "2001:67c:28a4::" ;
Ipaddr.of_string_exn "91.239.100.100" ;
]
module type S = sig
type context
type +'a io
type io_addr
type stack
type t
val create : ?nameservers:(Dns.proto * io_addr list) -> timeout:int64 -> stack -> t
val nameservers : t -> Dns.proto * io_addr list
val rng : int -> string
val clock : unit -> int64
val connect : t -> (Dns.proto * context, [> `Msg of string ]) result io
val send_recv : context -> string -> (string, [> `Msg of string ]) result io
val close : context -> unit io
val bind : 'a io -> ('a -> 'b io) -> 'b io
val lift : 'a -> 'a io
end
let localhost = Domain_name.of_string_exn "localhost"
let localsoa = Soa.create (Domain_name.prepend_label_exn localhost "ns")
let invalid = Domain_name.of_string_exn "invalid"
let invalidsoa = Soa.create (Domain_name.prepend_label_exn invalid "ns")
let rfc6761_special (type req) q_name (q_typ : req Dns.Rr_map.key) : (req Dns_cache.entry, unit) result =
if Domain_name.is_subdomain ~domain:localhost ~subdomain:q_name then
let open Dns.Rr_map in
match q_typ with
| A -> Ok (`Entry (300l, Ipaddr.V4.Set.singleton Ipaddr.V4.localhost))
| Aaaa ->
Ok (`Entry (300l, Ipaddr.V6.Set.singleton Ipaddr.V6.localhost))
| _ -> Ok (`No_domain (localhost, localsoa))
else if Domain_name.is_subdomain ~domain:invalid ~subdomain:q_name then
Ok (`No_domain (invalid, invalidsoa))
else
Error ()
module Make = functor (Transport:S) ->
struct
type t = {
mutable cache : Dns_cache.t ;
transport : Transport.t ;
edns : [ `None | `Auto | `Manual of Dns.Edns.t ] ;
}
let transport { transport ; _ } = transport
(* TODO eventually use Auto, and retry without on FormErr *)
let create ?(cache_size = 32) ?(edns = `None) ?nameservers ?(timeout = Duration.of_sec 5) stack =
{ cache = Dns_cache.empty cache_size ;
transport = Transport.create ?nameservers ~timeout stack ;
edns ;
}
let nameservers { transport; _ } = Transport.nameservers transport
let (>>=) = Transport.bind
(* result-bind *)
let (>>|) a b =
a >>= function
| Ok a' -> b a'
| Error e -> Transport.lift (Error e)
(* result-bind-and-lift *)
let (>>|=) a f = a >>| fun b -> Transport.lift (f b)
let lift_ok (type req) :
(req Dns_cache.entry, 'a) result ->
(req, [> `Msg of string
| `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
| `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ]) result
= function
| Ok `Entry value -> Ok value
| Ok (`No_data _ as nodata) -> Error nodata
| Ok (`No_domain _ as nodom) -> Error nodom
| Ok (`Serv_fail _)
| Error _ -> Error (`Msg "")
let get_raw_reply t query_type name =
Transport.connect t.transport >>| fun (proto, socket) ->
Log.debug (fun m -> m "Connected to NS.");
let tx, state =
Pure.make_query Transport.rng proto ~dnssec:true t.edns name query_type
in
(Transport.send_recv socket tx >>| fun recv_buffer ->
Log.debug (fun m -> m "Read @[<v>%d bytes@]"
(String.length recv_buffer)) ;
Log.debug (fun m -> m "received: %a" (Ohex.pp_hexdump ()) recv_buffer);
Transport.lift (Pure.parse_response state recv_buffer)) >>= fun r ->
Transport.close socket >>= fun () ->
Transport.lift r
let get_resource_record (type requested) t (query_type:requested Dns.Rr_map.key) name
: (requested, [> `Msg of string
| `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
| `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ]) result Transport.io =
let domain_name = Domain_name.raw name in
match rfc6761_special domain_name query_type |> lift_ok with
| Ok _ as ok -> Transport.lift ok
| Error ((`No_data _ | `No_domain _) as nod) -> Error nod |> Transport.lift
| Error `Msg _ ->
let cache', r =
Dns_cache.get t.cache (Transport.clock ()) domain_name query_type
in
t.cache <- cache';
match lift_ok (Result.map fst r) with
| Ok _ as ok -> Transport.lift ok
| Error ((`No_data _ | `No_domain _) as nod) -> Error nod |> Transport.lift
| Error `Msg _ ->
Transport.connect t.transport >>| fun (proto, socket) ->
Log.debug (fun m -> m "Connected to NS.");
let tx, state =
Pure.make_query Transport.rng proto t.edns name query_type
in
(Transport.send_recv socket tx >>| fun recv_buffer ->
Log.debug (fun m -> m "Read @[<v>%d bytes@]"
(String.length recv_buffer)) ;
let update_cache entry =
let rank = Dns_cache.NonAuthoritativeAnswer in
let cache =
Dns_cache.set t.cache (Transport.clock ()) domain_name query_type rank entry
in
t.cache <- cache
in
Transport.lift
(match Pure.handle_response state recv_buffer with
| Ok `Data x ->
update_cache (`Entry x);
Ok x
| Ok ((`No_data _ | `No_domain _) as nodom) ->
update_cache nodom;
Error nodom
| Error `Msg xxx -> Error (`Msg xxx)
| Ok `Partial -> Error (`Msg "Truncated UDP response"))) >>= fun r ->
Transport.close socket >>= fun () ->
Transport.lift r
let lift_cache_error query_type m =
(match m with
| Ok a -> Ok a
| Error `Msg msg -> Error (`Msg msg)
| Error (#Dns_cache.entry as e) ->
Error (`Msg (Fmt.str "DNS cache error @[%a@]" (Dns_cache.pp_entry query_type) e)))
|> Transport.lift
let getaddrinfo (type requested) t (query_type:requested Dns.Rr_map.key) name
: (requested, [> `Msg of string ]) result Transport.io =
get_resource_record t query_type name >>= lift_cache_error query_type
let gethostbyname stack domain =
getaddrinfo stack Dns.Rr_map.A domain >>|= fun (_ttl, resp) ->
match Ipaddr.V4.Set.choose_opt resp with
| None -> Error (`Msg "No A record found")
| Some ip -> Ok ip
let gethostbyname6 stack domain =
getaddrinfo stack Dns.Rr_map.Aaaa domain >>|= fun (_ttl, res) ->
match Ipaddr.V6.Set.choose_opt res with
| None -> Error (`Msg "No AAAA record found")
| Some ip -> Ok ip
end

196
unikernel/duniverse/ocaml-dns/client/dns_client.mli Normal file
View file

@ -0,0 +1,196 @@
(* TODO ideally there'd be something like mirage-flow-lwt that didn't depend
on lwt and a ton of other things, and still provided [map]
and [connect] and so on. leaving this stuff here for now until a
better solution presents itself. *)
val default_resolver_hostname : [`host] Domain_name.t
val default_resolvers : Ipaddr.t list
(** [default_resolver] is a list of IPv6 and IPv4 address of the default
resolver. Currently it is the IP address of the UncensoredDNS.org
anycast service. *)
module type S = sig
type context
(** A context is a network connection initialized by {!connect} *)
type +'a io
(** [io] is the type of an effect. ['err] is a polymorphic variant. *)
type io_addr
(** An address for a given context type, usually this will consist of
IP address + a TCP/IP or UDP/IP port number, but for some context types
it can carry additional information for purposes of cryptographic
verification. *)
type stack
(** A stack with which to connect. *)
type t
(** The abstract state of a DNS client. *)
val create : ?nameservers:(Dns.proto * io_addr list) -> timeout:int64 ->
stack -> t
(** [create ~nameservers ~timeout stack] creates the state record of
the DNS client. We use [timeout] (ns) as a cumulative time budget for
connect and request timeouts. *)
val nameservers : t -> Dns.proto * io_addr list
(** The address of a nameservers that is supposed to work with
the underlying context, can be used if the user does not want to
bother with configuring their own.*)
val rng : int -> string
(** [rng t] is a random number generator. *)
val clock : unit -> int64
(** [clock t] is the monotonic clock. *)
val connect : t -> (Dns.proto * context, [> `Msg of string ]) result io
(** [connect t] is a new connection ([context]) to [t], or an error. *)
val send_recv : context -> string -> (string, [> `Msg of string ]) result io
(** [send_recv context buffer] sends [buffer] to the [context] upstream, and
then reads a buffer. *)
val close : context -> unit io
(** [close context] closes the [context], freeing up resources. *)
val bind : 'a io -> ('a -> 'b io) -> 'b io
(** a.k.a. [>>=] *)
val lift : 'a -> 'a io
end
module Make : functor (T : S) ->
sig
type t
(** The abstract type of a DNS client. *)
val transport : t -> T.t
(** [transport t] is the transport of [t]. *)
val create : ?cache_size:int ->
?edns:[ `None | `Auto | `Manual of Dns.Edns.t ] ->
?nameservers:(Dns.proto * T.io_addr list) -> ?timeout:int64 ->
T.stack -> t
(** [create ~cache_size ~edns ~nameservers ~timeout stack] creates the state
of the DNS client. We use [timeout] (ns, default 5s) as a time budget for
connect and request timeouts. To specify a timeout, use
[create ~timeout:(Duration.of_sec 3)]. Whether or not to use
{{:https://tools.ietf.org/html/rfc6891}EDNS} in queries is controlled
by [~edns] (defaults to [`None]): if [None], no EDNS will be present,
[`Auto] adds TCP Keepalive if protocol is TCP, [`Manual edns] adds the
EDNS data specified. *)
val nameservers : t -> Dns.proto * T.io_addr list
(** [nameservers state] returns the list of nameservers to be used. *)
val getaddrinfo : t -> 'response Dns.Rr_map.key ->
'a Domain_name.t ->
('response, [> `Msg of string ]) result T.io
(** [getaddrinfo state query_type name] is the
[query_type]-dependent response regarding [name], or
an [Error _] message. See {!Dns_client.query_state} for more information
about the result types. *)
val gethostbyname : t -> [ `host ] Domain_name.t ->
(Ipaddr.V4.t, [> `Msg of string ]) result T.io
(** [gethostbyname state hostname] is the IPv4 address of
[hostname] resolved via the [state] specified.
If the query fails, or if the [domain] does not have any IPv4 addresses,
an [Error _] message is returned. Any extraneous IPv4 addresses are
ignored. For an example of using this API, see [unix/ohost.ml] in the
distribution of this package. *)
val gethostbyname6 : t -> [ `host ] Domain_name.t ->
(Ipaddr.V6.t, [> `Msg of string ]) result T.io
(** [gethostbyname6 state hostname] is the IPv6 address of
[hostname] resolved via the [state] specified.
It is the IPv6 equivalent of {!gethostbyname}. *)
val get_resource_record : t -> 'response Dns.Rr_map.key -> 'a Domain_name.t ->
('response,
[> `Msg of string
| `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
| `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ]) result T.io
(** [get_resource_record state query_type name] resolves
[query_type, name] via the [state] specified. The
behaviour is equivalent to {!getaddrinfo}, apart from the error return
value - [get_resource_record] distinguishes some errors, at the moment
[No_data] if the [name] exists, but not the [query_type], and
[No_domain] if the [name] does not exist. This allows clients to treat
these error conditions explicitly. *)
val get_raw_reply : t -> 'response Dns.Rr_map.key ->
'a Domain_name.t ->
(Dns.Packet.reply, [> `Partial | `Msg of string ]) result T.io
(** [get_raw_reply state query_type name] resolves [query_type, name] via the
[state] specified. The complete DNS reply is returned. CNAME records
are not followed. This allows DNSSec to process the entire reply. *)
end
module Pure : sig
(** The pure interface to the client part of uDns.
Various helper modules to do with side effects are available from
{!Dns_client_lwt}, {!Dns_client_unix} and so forth. *)
type 'key query_state constraint 'key = 'a Dns.Rr_map.key
(** [query_state] is parameterized over the query type, so the type of the
representation of the answer depends on what the name server was asked to
provide. See {!Dns.Rr_map.k} for a list of response types. The first
element (the [int32]) in most of the tuples is the Time-To-Live (TTL)
field returned from the server, which you can use to calculate when you
should request fresh information in case you are writing a long-running
application. *)
val make_query :
(int -> string) -> Dns.proto -> ?dnssec:bool ->
[ `None | `Auto | `Manual of Dns.Edns.t ] ->
'a Domain_name.t ->
'query_type Dns.Rr_map.key ->
string * 'query_type Dns.Rr_map.key query_state
(** [make_query rng protocol name query_type] is [query, query_state]
where [query] is the serialized DNS query to send to the name server,
and [query_state] is the information required to validate the response. *)
val parse_response : 'query_type Dns.Rr_map.key query_state -> string ->
(Dns.Packet.reply, [ `Partial | `Msg of string]) result
(** [parse_response query_state response] is the information contained in
[response] parsed using [query_state] when the query was successful, or
an [`Msg message] if the [response] did not match the [query_state]
(or if the query failed).
In a TCP usage context the [`Partial] means there are more bytes to be
read in order to parse correctly. This can happen due to short reads or if
the server (or something along the route) chunks its responses into
multiple individual packets. In that case you should concatenate
[response] and the next received data and call this function again.
In a UDP usage context the [`Partial] means information was lost, due to
an incomplete packet. *)
val handle_response : 'query_type Dns.Rr_map.key query_state -> string ->
( [ `Data of 'query_type
| `Partial
| `No_data of [`raw] Domain_name.t * Dns.Soa.t
| `No_domain of [`raw] Domain_name.t * Dns.Soa.t ],
[`Msg of string]) result
(** [handle_response query_state response] is the information contained in
[response] parsed using [query_state] when the query was successful, or
an [`Msg message] if the [response] did not match the [query_state]
(or if the query failed).
In a TCP usage context the [`Partial] means there are more bytes to be
read in order to parse correctly. This can happen due to short reads or if
the server (or something along the route) chunks its responses into
multiple individual packets. In that case you should concatenate
[response] and the next received data and call this function again.
In a UDP usage context the [`Partial] means information was lost, due to
an incomplete packet. *)
end

6
unikernel/duniverse/ocaml-dns/client/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name dns_client)
(public_name dns-client)
(modules dns_client)
(libraries dns.cache domain-name dns randomconv)
(wrapped false))

41
unikernel/duniverse/ocaml-dns/dns-certify.opam Normal file
View file

@ -0,0 +1,41 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Hannes Mehnert <hannes@mehnert.org>"]
homepage: "https://github.com/mirage/ocaml-dns"
doc: "https://mirage.github.io/ocaml-dns/"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
license: "BSD-2-Clause"
depends: [
"dune" {>= "2.8.0"}
"ocaml" {>= "4.13.0"}
"dns" {= version}
"dns-tsig" {= version}
"dns-mirage" {= version}
"randomconv" {>= "0.2.0"}
"duration" {>= "0.1.2"}
"x509" {>= "1.0.0"}
"lwt" {>= "4.2.1"}
"mirage-sleep" {>= "4.0.0"}
"mirage-ptime" {>= "5.0.0"}
"tcpip" {>= "8.2.0"}
"logs"
"mirage-crypto-ec"
"mirage-crypto-pk" {>= "1.0.0"}
"mirage-crypto-rng" {>= "1.0.0"}
]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "MirageOS let's encrypt certificate retrieval"
description: """
A function to retrieve a certificate when providing a hostname, TSIG key, server
IP, and an optional key seed. Best used with an letsencrypt unikernel.
"""
x-maintenance-intent: [ "(latest)" ]

56
unikernel/duniverse/ocaml-dns/dns-cli.opam Normal file
View file

@ -0,0 +1,56 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Hannes Mehnert <hannes@mehnert.org>"]
homepage: "https://github.com/mirage/ocaml-dns"
doc: "https://mirage.github.io/ocaml-dns/"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
license: "BSD-2-Clause"
depends: [
"dune" {>= "2.8.0"}
"ocaml" {>= "4.13.0"}
"dns" {= version}
"dnssec" {= version}
"dns-tsig" {= version}
"dns-client-lwt" {= version}
"dns-server" {= version}
"dns-certify" {= version}
"dns-resolver" {= version}
"bos" {>= "0.2.0"}
"cmdliner" {>= "1.1.0"}
"fpath" {>= "0.7.2"}
"x509" {>= "1.0.0"}
"mirage-crypto" {>= "1.0.0"}
"mirage-crypto-pk" {>= "1.0.0"}
"mirage-crypto-rng" {>= "2.0.0"}
"mirage-mtime" {>= "5.0.0"}
"mtime" {>= "2.1.0"}
"ptime" {>= "1.2.0"}
"tcpip" {>= "8.2.0"}
"ohex" {>= "0.2.0"}
"logs" {>= "0.6.3"}
"fmt" {>= "0.8.8"}
"ipaddr" {>= "4.0.0"}
"lwt" {>= "4.0.0"}
"randomconv" {>= "0.2.0"}
"metrics" {>= "0.5.0"}
"alcotest" {with-test}
]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "Unix command line utilities using uDNS"
description: """
'oupdate' sends a DNS update frome to a DNS server that sets 'hostname A ip'.
For authentication via TSIG, a hmac secret needs to be provided.
'ocertify' updates DNS with a certificate signing request, and polls a matching
certificate. Best used with an letsencrypt unikernel.
"""
x-maintenance-intent: [ "(latest)" ]

34
unikernel/duniverse/ocaml-dns/dns-client-lwt.opam Normal file
View file

@ -0,0 +1,34 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Joe Hill"]
homepage: "https://github.com/mirage/ocaml-dns"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
license: "BSD-2-Clause"
build: [
[ "dune" "subst"] {dev}
[ "dune" "build" "-p" name "-j" jobs ]
[ "dune" "runtest" "-p" name "-j" jobs ] {with-test}
]
depends: [
"dune" {>="2.8.0"}
"ocaml" {>= "4.13.0"}
"dns-client" {= version}
"dns" {= version}
"ipaddr" {>= "5.3.0"}
"lwt" {>= "4.2.1"}
"mtime" {>= "1.2.0"}
"mirage-crypto-rng" {>= "1.2.0"}
"happy-eyeballs-lwt" {>= "2.0.0"}
"happy-eyeballs" {>= "2.0.0"}
"tls-lwt" {>= "2.0.0"}
"ca-certs" {>= "1.0.0"}
]
synopsis: "DNS client API using lwt"
description: """
A client implementation using uDNS and lwt for side effects.
"""
x-maintenance-intent: [ "(latest)" ]

31
unikernel/duniverse/ocaml-dns/dns-client-miou-unix.opam Normal file
View file

@ -0,0 +1,31 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Robur <team@robur.coop>"]
homepage: "https://github.com/mirage/ocaml-dns"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
license: "BSD-2-Clause"
build: [
[ "dune" "subst"] {dev}
[ "dune" "build" "-p" name "-j" jobs ]
[ "dune" "runtest" "-p" name "-j" jobs ] {with-test}
]
depends: [
"dune" {>="2.8.0"}
"ocaml" {>= "5.0.0"}
"dns-client" {= version}
"domain-name" {>= "0.4.0"}
"ipaddr" {>= "5.3.0"}
"miou" {>= "0.1.0"}
"tls-miou-unix" {>= "2.0.0"}
"happy-eyeballs" {>= "2.0.0"}
"happy-eyeballs-miou-unix" {>= "2.0.0"}
]
synopsis: "DNS client API for Miou"
description: """
A client implementation using uDNS using Miou.
"""
x-maintenance-intent: [ "(latest)" ]

38
unikernel/duniverse/ocaml-dns/dns-client-mirage.opam Normal file
View file

@ -0,0 +1,38 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Joe Hill"]
homepage: "https://github.com/mirage/ocaml-dns"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
license: "BSD-2-Clause"
build: [
[ "dune" "subst"] {dev}
[ "dune" "build" "-p" name "-j" jobs ]
[ "dune" "runtest" "-p" name "-j" jobs ] {with-test}
]
depends: [
"dune" {>="2.8.0"}
"ocaml" {>= "4.13.0"}
"dns-client" {= version}
"domain-name" {>= "0.4.0"}
"ipaddr" {>= "5.3.0"}
"lwt" {>= "4.2.1"}
"tcpip" {>= "8.2.0"}
"mirage-sleep" {>= "4.0.0"}
"mirage-mtime" {>= "5.0.0"}
"mirage-ptime" {>= "5.0.0"}
"happy-eyeballs-mirage" {>= "2.0.0"}
"happy-eyeballs" {>= "2.0.0"}
"tls-mirage" {>= "2.0.0"}
"x509" {>= "1.0.0"}
"ca-certs-nss" {>= "3.108-1"}
"mirage-crypto-rng" {>= "1.0.0"}
]
synopsis: "DNS client API for MirageOS"
description: """
A client implementation using uDNS using MirageOS.
"""
x-maintenance-intent: [ "(latest)" ]

32
unikernel/duniverse/ocaml-dns/dns-client.opam Normal file
View file

@ -0,0 +1,32 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Joe Hill"]
homepage: "https://github.com/mirage/ocaml-dns"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
license: "BSD-2-Clause"
build: [
[ "dune" "subst"] {dev}
[ "dune" "build" "-p" name "-j" jobs ]
[ "dune" "runtest" "-p" name "-j" jobs ] {with-test}
]
depends: [
"dune" {>="2.8.0"}
"ocaml" {>= "4.13.0"}
"dns" {= version}
"randomconv" {>= "0.2.0"}
"domain-name" {>= "0.4.0"}
"mtime" {>= "1.2.0"}
"mirage-crypto-rng" {>= "1.2.0"}
"fmt" {>= "0.9.0"}
"ipaddr" {>= "5.5.0"}
"alcotest" {with-test}
]
synopsis: "DNS client API"
description: """
A client implementation using uDNS.
"""
x-maintenance-intent: [ "(latest)" ]

42
unikernel/duniverse/ocaml-dns/dns-mirage.opam Normal file
View file

@ -0,0 +1,42 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Hannes Mehnert <hannes@mehnert.org>"]
homepage: "https://github.com/mirage/ocaml-dns"
doc: "https://mirage.github.io/ocaml-dns/"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
license: "BSD-2-Clause"
depends: [
"dune" {>= "2.8.0"}
"ocaml" {>= "4.13.0"}
"cstruct" {>= "6.0.0"}
"dns" {= version}
"ipaddr" {>= "5.2.0"}
"lwt" {>= "4.2.1"}
"tcpip" {>= "8.2.0"}
]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "An opinionated Domain Name System (DNS) library"
description: """
µDNS supports most of the domain name system used in the wild. It adheres to
strict conventions. Failing early and hard. It is mostly implemented in the
pure fragment of OCaml (no mutation, isolated IO, no exceptions).
Legacy resource record types are not dealt with, and there is no plan to support
`ISDN`, `MAILA`, `MAILB`, `WKS`, `MB`, `NULL`, `HINFO`, ... . `AXFR` is only
handled via TCP connections. The only resource class supported is `IN` (the
Internet). Truncated hmac in `TSIG` are not supported (always the full length
of the hash algorithm is used).
Please read [the blog article](https://hannes.robur.coop/Posts/DNS) for a more
detailed overview.
"""
x-maintenance-intent: [ "(latest)" ]

47
unikernel/duniverse/ocaml-dns/dns-resolver.opam Normal file
View file

@ -0,0 +1,47 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Hannes Mehnert <hannes@mehnert.org>"]
homepage: "https://github.com/mirage/ocaml-dns"
doc: "https://mirage.github.io/ocaml-dns/"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
license: "BSD-2-Clause"
depends: [
"dune" {>= "2.8.0"}
"ocaml" {>= "4.13.0"}
"dns" {= version}
"dns-server" {= version}
"dns-mirage" {= version}
"dnssec" {= version}
"lru" {>= "0.3.0"}
"duration" {>= "0.1.2"}
"randomconv" {>= "0.2.0"}
"lwt" {>= "4.2.1"}
"mirage-sleep" {>= "4.0.0"}
"mirage-mtime" {>= "5.0.0"}
"mirage-ptime" {>= "5.0.0"}
"tcpip" {>= "8.2.0"}
"alcotest" {with-test}
"logs"
"tls" {>= "1.0.0"}
"tls-mirage" {>= "1.0.0"}
"mirage-crypto-rng" {>= "1.0.0"}
"ca-certs-nss" {>= "3.113.1"}
"ipaddr" {>= "5.6.1"}
"metrics" {>= "0.5.0"}
]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "DNS resolver business logic"
description: """
Forwarding and recursive resolvers as value-passing functions. To be used with
an effectful layer.
"""
x-maintenance-intent: [ "(latest)" ]

43
unikernel/duniverse/ocaml-dns/dns-server.opam Normal file
View file

@ -0,0 +1,43 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Hannes Mehnert <hannes@mehnert.org>"]
homepage: "https://github.com/mirage/ocaml-dns"
doc: "https://mirage.github.io/ocaml-dns/"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
license: "BSD-2-Clause"
depends: [
"dune" {>= "2.8.0"}
"ocaml" {>= "4.13.0"}
"cstruct" {>= "6.0.0"}
"dns" {= version}
"dns-mirage" {= version}
"randomconv" {>= "0.2.0"}
"duration" {>= "0.1.2"}
"lwt" {>= "4.2.1"}
"mirage-sleep" {>= "4.0.0"}
"mirage-mtime" {>= "5.0.0"}
"mirage-ptime" {>= "5.0.0"}
"tcpip" {>= "8.2.0"}
"mirage-crypto-rng" {with-test & >= "1.2.0"}
"alcotest" {with-test}
"dns-tsig" {with-test}
"base64" {with-test & >= "3.0.0"}
"metrics"
"logs" {>= "0.7.0"}
]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "DNS server, primary and secondary"
description: """
Primary and secondary DNS server implemented in value-passing style. Needs an
effectful layer to be useful.
"""
x-maintenance-intent: [ "(latest)" ]

42
unikernel/duniverse/ocaml-dns/dns-stub.opam Normal file
View file

@ -0,0 +1,42 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Hannes Mehnert <hannes@mehnert.org>"]
homepage: "https://github.com/mirage/ocaml-dns"
doc: "https://mirage.github.io/ocaml-dns/"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
license: "BSD-2-Clause"
depends: [
"dune" {>= "2.8.0"}
"ocaml" {>= "4.13.0"}
"cstruct" {>= "6.0.0"}
"dns" {= version}
"dns-client-mirage" {= version}
"dns-mirage" {= version}
"dns-resolver" {= version}
"dns-tsig" {= version}
"dns-server" {= version}
"duration" {>= "0.1.2"}
"randomconv" {>= "0.2.0"}
"lwt" {>= "4.2.1"}
"mirage-ptime" {>= "5.0.0"}
"tcpip" {>= "8.2.0"}
"metrics"
"mirage-crypto-rng" {>= "1.0.0"}
"tls-mirage" {>= "2.0.2"}
]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "DNS stub resolver"
description: """
Forwarding and recursive resolvers as value-passing functions. To be used with
an effectful layer.
"""
x-maintenance-intent: [ "(latest)" ]

30
unikernel/duniverse/ocaml-dns/dns-tsig.opam Normal file
View file

@ -0,0 +1,30 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Hannes Mehnert <hannes@mehnert.org>"]
homepage: "https://github.com/mirage/ocaml-dns"
doc: "https://mirage.github.io/ocaml-dns/"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
license: "BSD-2-Clause"
depends: [
"dune" {>= "2.8.0"}
"ocaml" {>= "4.13.0"}
"dns" {= version}
"digestif" {>= "1.2.0"}
"base64" {>= "3.0.0"}
"alcotest" {with-test}
]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "TSIG support for DNS"
description: """
TSIG is used to authenticate nsupdate frames using a HMAC.
"""
x-maintenance-intent: [ "(latest)" ]

48
unikernel/duniverse/ocaml-dns/dns.opam Normal file
View file

@ -0,0 +1,48 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Hannes Mehnert <hannes@mehnert.org>" "Reynir Björnsson <reynir@reynir.dk>"]
homepage: "https://github.com/mirage/ocaml-dns"
doc: "https://mirage.github.io/ocaml-dns/"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
license: "BSD-2-Clause"
depends: [
"dune" {>= "2.8.0"}
"ocaml" {>= "4.13.0"}
"logs" "ptime"
"fmt" {>= "0.8.8"}
"domain-name" {>= "0.4.0"}
"gmap" {>= "0.3.0"}
"ipaddr" {>= "5.2.0"}
"alcotest" {with-test}
"lru" {>= "0.3.0"}
"duration" {>= "0.1.2"}
"metrics"
"ohex" {>= "0.2.0"}
"base64" {>= "3.3.0"}
]
conflicts: [ "result" {< "1.5"} ]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "An opinionated Domain Name System (DNS) library"
description: """
µDNS supports most of the domain name system used in the wild. It adheres to
strict conventions. Failing early and hard. It is mostly implemented in the
pure fragment of OCaml (no mutation, isolated IO, no exceptions).
Legacy resource record types are not dealt with, and there is no plan to support
`ISDN`, `MAILA`, `MAILB`, `WKS`, `MB`, `NULL`, `HINFO`, ... . `AXFR` is only
handled via TCP connections. The only resource class supported is `IN` (the
Internet). Truncated hmac in `TSIG` are not supported (always the full length
of the hash algorithm is used).
Please read [the blog article](https://hannes.robur.coop/Posts/DNS) for a more
detailed overview.
"""
x-maintenance-intent: [ "(latest)" ]

34
unikernel/duniverse/ocaml-dns/dnssec.opam Normal file
View file

@ -0,0 +1,34 @@
version: "10.2.2"
opam-version: "2.0"
maintainer: "team AT robur dot coop"
authors: ["Hannes Mehnert <hannes@mehnert.org>" "Reynir Björnsson <reynir@reynir.dk>"]
homepage: "https://github.com/mirage/ocaml-dns"
doc: "https://mirage.github.io/ocaml-dns/"
dev-repo: "git+https://github.com/mirage/ocaml-dns.git"
bug-reports: "https://github.com/mirage/ocaml-dns/issues"
license: "BSD-2-Clause"
depends: [
"dune" {>= "2.8.0"}
"ocaml" {>= "4.13.0"}
"dns" {= version}
"alcotest" {with-test}
"mirage-crypto" {>= "1.0.0"}
"mirage-crypto-pk" {>= "1.0.0"}
"mirage-crypto-ec" {>= "1.0.0"}
"domain-name" {>= "0.4.0"}
"base64" {with-test & >= "3.0.0"}
"logs" {>= "0.7.0"}
]
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
synopsis: "DNSSec support for OCaml-DNS"
description: """
DNSSec (DNS security extensions) for OCaml-DNS, including
signing and verifying of RRSIG records.
"""
x-maintenance-intent: [ "(latest)" ]

236
unikernel/duniverse/ocaml-dns/dnssec/base32.ml Normal file
View file

@ -0,0 +1,236 @@
(* RFC 4648, Section 7 - Base 32 with extended hex alphabet *)
let make_alphabet alphabet =
if String.length alphabet <> 32
then invalid_arg "Length of alphabet must be 32" ;
if String.contains alphabet '='
then invalid_arg "Alphabet can not contain padding character" ;
let emap =
Array.init (String.length alphabet) (fun i -> Char.code alphabet.[i]) in
let dmap = Array.make 256 (-1) in
String.iteri (fun idx chr -> dmap.(Char.code chr) <- idx) alphabet ;
(emap, dmap)
let alphabet = make_alphabet "0123456789ABCDEFGHIJKLMNOPQRSTUV"
let pad_char = '='
let pad_int = int_of_char pad_char
let encode ?(pad = true) str =
let len = String.length str in
(* since String.get_uint8 is OCaml >= 4.13 only *)
let str = Bytes.unsafe_of_string str in
let out_len = (len + 4) / 5 * 8 in
let out = Bytes.make out_len pad_char in
let o1 b1 = b1 lsr 3
and o2 b1 b2 = (b1 land 0x07) lsl 2 + b2 lsr 6
and o3 b2 = (b2 land 0x3E) lsr 1
and o4 b2 b3 = ((b2 land 0x01) lsl 4) + b3 lsr 4
and o5 b3 b4 = (b3 land 0x0F) lsl 1 + b4 lsr 7
and o6 b4 = (b4 land 0x7c) lsr 2
and o7 b4 b5 = (b4 land 0x03) lsl 3 + b5 lsr 5
and o8 b5 = b5 land 0x1F
in
let emit b1 b2 b3 b4 b5 off =
List.iteri (fun idx v -> Bytes.set_uint8 out (off + idx) ((fst alphabet).(v)))
[ o1 b1; o2 b1 b2; o3 b2; o4 b2 b3; o5 b3 b4; o6 b4; o7 b4 b5; o8 b5 ]
in
let rec enc s_off d_off =
if s_off = len then
(* case 1 *) 0
else if s_off = len - 1 then
(* case 2 - 6 padding = *)
let b1 = Bytes.get_uint8 str s_off in
let p1 = o1 b1 and p2 = o2 b1 0 in
Bytes.set_uint8 out d_off ((fst alphabet).(p1));
Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2));
6
else if s_off = len - 2 then
(* case 3 - 4 padding = *)
let b1 = Bytes.get_uint8 str s_off
and b2 = Bytes.get_uint8 str (s_off + 1)
in
let p1 = o1 b1 and p2 = o2 b1 b2 and p3 = o3 b2 and p4 = o4 b2 0 in
Bytes.set_uint8 out d_off ((fst alphabet).(p1));
Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2));
Bytes.set_uint8 out (d_off + 2) ((fst alphabet).(p3));
Bytes.set_uint8 out (d_off + 3) ((fst alphabet).(p4));
4
else if s_off = len - 3 then
(* case 4 - 3 padding = *)
let b1 = Bytes.get_uint8 str s_off
and b2 = Bytes.get_uint8 str (s_off + 1)
and b3 = Bytes.get_uint8 str (s_off + 2)
in
let p1 = o1 b1 and p2 = o2 b1 b2 and p3 = o3 b2 and p4 = o4 b2 b3 and p5 = o5 b3 0 in
Bytes.set_uint8 out d_off ((fst alphabet).(p1));
Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2));
Bytes.set_uint8 out (d_off + 2) ((fst alphabet).(p3));
Bytes.set_uint8 out (d_off + 3) ((fst alphabet).(p4));
Bytes.set_uint8 out (d_off + 4) ((fst alphabet).(p5));
3
else if s_off = len - 4 then
(* case 5 - 1 padding = *)
let b1 = Bytes.get_uint8 str s_off
and b2 = Bytes.get_uint8 str (s_off + 1)
and b3 = Bytes.get_uint8 str (s_off + 2)
and b4 = Bytes.get_uint8 str (s_off + 3)
in
let p1 = o1 b1 and p2 = o2 b1 b2 and p3 = o3 b2 and p4 = o4 b2 b3 and p5 = o5 b3 b4 and p6 = o6 b4 and p7 = o7 b4 0 in
Bytes.set_uint8 out d_off ((fst alphabet).(p1));
Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2));
Bytes.set_uint8 out (d_off + 2) ((fst alphabet).(p3));
Bytes.set_uint8 out (d_off + 3) ((fst alphabet).(p4));
Bytes.set_uint8 out (d_off + 4) ((fst alphabet).(p5));
Bytes.set_uint8 out (d_off + 5) ((fst alphabet).(p6));
Bytes.set_uint8 out (d_off + 6) ((fst alphabet).(p7));
1
else
let b1 = Bytes.get_uint8 str s_off in
let b2 = Bytes.get_uint8 str (s_off + 1) in
let b3 = Bytes.get_uint8 str (s_off + 2) in
let b4 = Bytes.get_uint8 str (s_off + 3) in
let b5 = Bytes.get_uint8 str (s_off + 4) in
emit b1 b2 b3 b4 b5 d_off;
enc (s_off + 5) (d_off + 8)
in
let padding_bytes = enc 0 0 in
let out_s = Bytes.unsafe_to_string out in
if pad then out_s else String.sub out_s 0 (out_len - padding_bytes)
(* RFC 4648 section 10
BASE32-HEX("") = ""
BASE32-HEX("f") = "CO======"
BASE32-HEX("fo") = "CPNG===="
BASE32-HEX("foo") = "CPNMU==="
BASE32-HEX("foob") = "CPNMUOG="
BASE32-HEX("fooba") = "CPNMUOJ1"
BASE32-HEX("foobar") = "CPNMUOJ1E8======"
*)
let decode ?(unpadded = false) str =
let ( let* ) = Result.bind in
let* str =
let lmod8 = String.length str mod 8 in
if lmod8 > 0 then
if unpadded then
Ok (str ^ String.make (8 - lmod8) pad_char)
else
Error (`Msg "invalid input length (not divisible by 8)")
else
Ok str
in
let len = String.length str in
let str = Bytes.unsafe_of_string str in
let out_len = len / 8 * 5 in (* max length *)
let out = Bytes.create out_len in
let o1 b1 b2 = b1 lsl 3 + b2 lsr 2
and o2 b2 b3 b4 = (b2 land 0x03) lsl 6 + b3 lsl 1 + b4 lsr 4
and o3 b4 b5 = (b4 land 0x0F) lsl 4 + b5 lsr 1
and o4 b5 b6 b7 = (b5 land 0x01) lsl 7 + b6 lsl 2 + b7 lsr 3
and o5 b7 b8 = (b7 land 0x07) lsl 5 + b8
in
let c ~off idx =
let r = (snd alphabet).(idx) in
if r = -1 then
Error (`Msg ("bad encoding at " ^ string_of_int off))
else
Ok r
in
let emit s_off v1 v2 v3 v4 v5 v6 v7 v8 off =
let* b1 = c ~off:s_off v1 in
let* b2 = c ~off:(s_off + 1) v2 in
let* b3 = c ~off:(s_off + 2) v3 in
let* b4 = c ~off:(s_off + 3) v4 in
let* b5 = c ~off:(s_off + 4) v5 in
let* b6 = c ~off:(s_off + 5) v6 in
let* b7 = c ~off:(s_off + 6) v7 in
let* b8 = c ~off:(s_off + 7) v8 in
Bytes.set_uint8 out off (o1 b1 b2);
Bytes.set_uint8 out (off + 1) (o2 b2 b3 b4);
Bytes.set_uint8 out (off + 2) (o3 b4 b5);
Bytes.set_uint8 out (off + 3) (o4 b5 b6 b7);
Bytes.set_uint8 out (off + 4) (o5 b7 b8);
Ok ()
in
let rec dec s_off d_off =
if s_off = len then
Ok (0, 0)
else
let v1 = Bytes.get_uint8 str s_off
and v2 = Bytes.get_uint8 str (s_off + 1)
and v3 = Bytes.get_uint8 str (s_off + 2)
and v4 = Bytes.get_uint8 str (s_off + 3)
and v5 = Bytes.get_uint8 str (s_off + 4)
and v6 = Bytes.get_uint8 str (s_off + 5)
and v7 = Bytes.get_uint8 str (s_off + 6)
and v8 = Bytes.get_uint8 str (s_off + 7)
in
if v3 = pad_int then
let* b1 = c ~off:s_off v1 in
let* b2 = c ~off:(s_off + 1) v2 in
let p1 = o1 b1 b2 in
Bytes.set_uint8 out d_off p1;
Ok (6, 4)
else if v5 = pad_int then
let* b1 = c ~off:s_off v1 in
let* b2 = c ~off:(s_off + 1) v2 in
let* b3 = c ~off:(s_off + 2) v3 in
let* b4 = c ~off:(s_off + 3) v4 in
let p1 = o1 b1 b2
and p2 = o2 b2 b3 b4
in
Bytes.set_uint8 out d_off p1;
Bytes.set_uint8 out (d_off + 1) p2;
Ok (4, 3)
else if v6 = pad_int then
let* b1 = c ~off:s_off v1 in
let* b2 = c ~off:(s_off + 1) v2 in
let* b3 = c ~off:(s_off + 2) v3 in
let* b4 = c ~off:(s_off + 3) v4 in
let* b5 = c ~off:(s_off + 4) v5 in
let p1 = o1 b1 b2
and p2 = o2 b2 b3 b4
and p3 = o3 b4 b5
in
Bytes.set_uint8 out d_off p1;
Bytes.set_uint8 out (d_off + 1) p2;
Bytes.set_uint8 out (d_off + 2) p3;
Ok (3, 2)
else if v8 = pad_int then
let* b1 = c ~off:s_off v1 in
let* b2 = c ~off:(s_off + 1) v2 in
let* b3 = c ~off:(s_off + 2) v3 in
let* b4 = c ~off:(s_off + 3) v4 in
let* b5 = c ~off:(s_off + 4) v5 in
let* b6 = c ~off:(s_off + 5) v6 in
let* b7 = c ~off:(s_off + 6) v7 in
let p1 = o1 b1 b2
and p2 = o2 b2 b3 b4
and p3 = o3 b4 b5
and p4 = o4 b5 b6 b7
in
Bytes.set_uint8 out d_off p1;
Bytes.set_uint8 out (d_off + 1) p2;
Bytes.set_uint8 out (d_off + 2) p3;
Bytes.set_uint8 out (d_off + 3) p4;
Ok (1, 1)
else
let* () = emit s_off v1 v2 v3 v4 v5 v6 v7 v8 d_off in
dec (s_off + 8) (d_off + 5)
in
let* (pad_bytes, to_remove) = dec 0 0 in
let rec check_pad = function
| 0 -> Ok ()
| n ->
if Bytes.get_uint8 str (len - n) = pad_int then
check_pad (n - 1)
else
Error (`Msg ("expected pad character at " ^ (string_of_int (len - n))))
in
let* () = check_pad pad_bytes in
let out_str = Bytes.unsafe_to_string out in
if to_remove > 0 then
Ok (String.sub out_str 0 (out_len - to_remove))
else
Ok out_str

952
unikernel/duniverse/ocaml-dns/dnssec/dnssec.ml Normal file
View file

@ -0,0 +1,952 @@
open Dns
let src = Logs.Src.create "dnssec" ~doc:"DNS Security"
module Log = (val Logs.src_log src : Logs.LOG)
let ( let* ) = Result.bind
module KM = Map.Make(struct type t = Rr_map.k let compare = Rr_map.comparek end)
let pp_km_name_rr_map ppf rrs =
List.iter (fun (name, (rr_map, _)) ->
Fmt.(list ~sep:(any "@.") string) ppf
(List.map (Rr_map.text_b name) (Rr_map.bindings rr_map)))
(Domain_name.Map.bindings rrs)
let guard a e = if a then Ok () else Error e
let root_ds =
(* <KeyDigest id="Klajeyz" validFrom="2017-02-02T00:00:00+00:00">
<KeyTag>20326</KeyTag>
<Algorithm>8</Algorithm>
<DigestType>2</DigestType>
<Digest>
E06D44B80B8F1D39A95C0B0D7C65D08458E880409BBC683457104237C7F8EC8D
</Digest>
<PublicKey>
AwEAAaz/tAm8yTn4Mfeh5eyI96WSVexTBAvkMgJzkKTOiW1vkIbzxeF3+/4RgWOq7HrxRixHlFlExOLAJr5emLvN7SWXgnLh4+B5xQlNVz8Og8kvArMtNROxVQuCaSnIDdD5LKyWbRd2n9WGe2R8PzgCmr3EgVLrjyBxWezF0jLHwVN8efS3rCj/EWgvIWgb9tarpVUDK/b58Da+sqqls3eNbuv7pr+eoZG+SrDK6nWeL3c6H5Apxz7LjVc1uTIdsIXxuOLYA4/ilBmSVIzuDWfdRUfhHdY6+cn8HFRm+2hM8AnXGXws9555KrUB5qihylGa8subX2Nn6UwNR1AkUTV74bU=
</PublicKey>
<Flags>257</Flags>
</KeyDigest>
<KeyDigest id="Kmyv6jo" validFrom="2024-07-18T00:00:00+00:00">
<KeyTag>38696</KeyTag>
<Algorithm>8</Algorithm>
<DigestType>2</DigestType>
<Digest>
683D2D0ACB8C9B712A1948B27F741219298D0A450D612C483AF444A4C0FB2B16
</Digest>
<PublicKey>
AwEAAa96jeuknZlaeSrvyAJj6ZHv28hhOKkx3rLGXVaC6rXTsDc449/cidltpkyGwCJNnOAlFNKF2jBosZBU5eeHspaQWOmOElZsjICMQMC3aeHbGiShvZsx4wMYSjH8e7Vrhbu6irwCzVBApESjbUdpWWmEnhathWu1jo+siFUiRAAxm9qyJNg/wOZqqzL/dL/q8PkcRU5oUKEpUge71M3ej2/7CPqpdVwuMoTvoB+ZOT4YeGyxMvHmbrxlFzGOHOijtzN+u1TQNatX2XBuzZNQ1K+s2CXkPIZo7s6JgZyvaBevYtxPvYLw4z9mR7K2vaF18UYH9Z9GNUUeayffKC73PYc=
</PublicKey>
<Flags>257</Flags>
</KeyDigest>
*)
let ds2017 = {
Ds.key_tag = 20326 ;
algorithm = Dnskey.RSA_SHA256 ;
digest_type = SHA256 ;
digest = Ohex.decode "E06D44B80B8F1D39A95C0B0D7C65D08458E880409BBC683457104237C7F8EC8D" ;
}
and ds2024 = {
Ds.key_tag = 38696 ;
algorithm = Dnskey.RSA_SHA256 ;
digest_type = SHA256 ;
digest = Ohex.decode "683D2D0ACB8C9B712A1948B27F741219298D0A450D612C483AF444A4C0FB2B16" ;
}
in
Rr_map.Ds_set.(add ds2024 (singleton ds2017))
type pub = [
| `P256 of Mirage_crypto_ec.P256.Dsa.pub
| `P384 of Mirage_crypto_ec.P384.Dsa.pub
| `ED25519 of Mirage_crypto_ec.Ed25519.pub
| `RSA of Mirage_crypto_pk.Rsa.pub
]
let pp_pub ppf = function
| `P256 _ -> Fmt.string ppf "P256"
| `P384 _ -> Fmt.string ppf "P384"
| `ED25519 _ -> Fmt.string ppf "ED25519"
| `RSA k -> Fmt.pf ppf "RSA %d bits" (Mirage_crypto_pk.Rsa.pub_bits k)
(* used by DS, RFC 4034 section 5.1.4 *)
let digest algorithm owner dnskey =
let digest : type a. a Digestif.hash -> (string, _) result = fun h ->
let res = Digestif.digest_string h (Dnskey.digest_prep owner dnskey) in
Ok (Digestif.to_raw_string h res) in
match algorithm with
| Ds.SHA1 -> digest Digestif.SHA1
| Ds.SHA256 -> digest Digestif.SHA256
| Ds.SHA384 -> digest Digestif.SHA384
| dt ->
Error (`Extended (`Unsupported_Ds_digest,
Some (Fmt.str "DS %a: unkown digest type: %a"
Domain_name.pp owner Ds.pp_digest_type dt)))
let dnskey_to_pk req_dom { Dnskey.algorithm ; key ; _ } =
let map_ec_err r =
Result.map_error (fun e -> `Msg (Fmt.to_to_string Mirage_crypto_ec.pp_error e)) r
in
match algorithm with
| Dnskey.RSA_SHA1 | Dnskey.RSASHA1_NSEC3_SHA1 | Dnskey.RSA_SHA256 | Dnskey.RSA_SHA512 ->
(* described in RFC 3110 *)
let* () = if String.length key > 0 then Ok () else Error (`Msg "key data too short") in
let e_len = String.get_int8 key 0 in
let data = String.sub key 1 (String.length key - 1) in
let* () = if String.length key > (e_len + 1) then Ok () else Error (`Msg "key data too short") in
let e = String.sub data 0 e_len
and n = String.sub data e_len (String.length data - e_len) in
let e = Mirage_crypto_pk.Z_extra.of_octets_be e
and n = Mirage_crypto_pk.Z_extra.of_octets_be n
in
let* pub = Mirage_crypto_pk.Rsa.pub ~e ~n in
Ok (`RSA pub)
| Dnskey.P256_SHA256 ->
let four = String.make 1 '\004' in
let* pub = map_ec_err (Mirage_crypto_ec.P256.Dsa.pub_of_octets (four ^ key)) in
Ok (`P256 pub)
| Dnskey.P384_SHA384 ->
let four = String.make 1 '\004' in
let* pub = map_ec_err (Mirage_crypto_ec.P384.Dsa.pub_of_octets (four ^ key)) in
Ok (`P384 pub)
| Dnskey.ED25519 ->
let* pub = map_ec_err (Mirage_crypto_ec.Ed25519.pub_of_octets key) in
Ok (`ED25519 pub)
| MD5 | SHA1 | SHA224 | SHA256 | SHA384 | SHA512 | Unknown _ ->
Error (`Extended (`Unsupported_Dnskey_algorithm,
Some (Fmt.str "%a DNSKEY unsupported algorithm: %a"
Domain_name.pp req_dom Dnskey.pp_algorithm algorithm)))
let verify : type a . Ptime.t -> pub -> [`raw] Domain_name.t -> Rrsig.t ->
a Rr_map.key -> a ->
([`raw] Domain_name.t * [`raw] Domain_name.t, [> `Msg of string | `Extended of Extended_error.t ]) result =
fun now key name rrsig t v ->
(* from RFC 4034 section 3.1.8.1 *)
Log.debug (fun m -> m "verifying for %a (with %a / %a)" Domain_name.pp name
pp_pub key
Dnskey.pp_algorithm rrsig.Rrsig.algorithm);
let* algorithm =
match rrsig.Rrsig.algorithm with
| Dnskey.RSA_SHA1 -> Ok `SHA1
| Dnskey.RSASHA1_NSEC3_SHA1 -> Ok `SHA1
| Dnskey.RSA_SHA256 -> Ok `SHA256
| Dnskey.RSA_SHA512 -> Ok `SHA512
| Dnskey.P256_SHA256 -> Ok `SHA256
| Dnskey.P384_SHA384 -> Ok `SHA384
| Dnskey.ED25519 -> Ok `SHA512
| a ->
let msg =
Fmt.str "unsupported signature algorithm %a" Dnskey.pp_algorithm a
in
Error (`Extended (`Other, Some msg))
in
let digest data =
match rrsig.Rrsig.algorithm with
| Dnskey.RSA_SHA1 -> Digestif.SHA1.(digest_string data |> to_raw_string)
| Dnskey.RSASHA1_NSEC3_SHA1 -> Digestif.SHA1.(digest_string data |> to_raw_string)
| Dnskey.RSA_SHA256 -> Digestif.SHA256.(digest_string data |> to_raw_string)
| Dnskey.RSA_SHA512 -> Digestif.SHA512.(digest_string data |> to_raw_string)
| Dnskey.P256_SHA256 -> Digestif.SHA256.(digest_string data |> to_raw_string)
| Dnskey.P384_SHA384 -> Digestif.SHA384.(digest_string data |> to_raw_string)
| Dnskey.ED25519 -> Digestif.SHA512.(digest_string data |> to_raw_string)
| _ -> assert false (* NOTE(dinosaure): prevent by [algorithm] and [let*]. *)
in
let* () =
guard (Ptime.is_later ~than:now rrsig.Rrsig.signature_expiration)
(`Extended (`Signature_expired, None))
in
let* () =
guard (Ptime.is_later ~than:rrsig.Rrsig.signature_inception now)
(`Extended (`Signature_not_yet_valid, None))
in
let* (used_name, data) = Rr_map.prep_for_sig name rrsig t v in
let hashed () = digest data in
let ok_if_true p =
if p then
Ok (used_name, rrsig.Rrsig.signer_name)
else
Error (`Msg "signature verification failed")
in
match key with
| `P256 key ->
let signature =
String.sub rrsig.Rrsig.signature 0 32,
String.sub rrsig.Rrsig.signature 32 (String.length rrsig.Rrsig.signature - 32) in
ok_if_true (Mirage_crypto_ec.P256.Dsa.verify ~key signature (hashed ()))
| `P384 key ->
let signature =
String.sub rrsig.Rrsig.signature 0 48,
String.sub rrsig.Rrsig.signature 48 (String.length rrsig.Rrsig.signature - 48) in
ok_if_true (Mirage_crypto_ec.P384.Dsa.verify ~key signature (hashed ()))
| `ED25519 key ->
let msg = data in
ok_if_true (Mirage_crypto_ec.Ed25519.verify ~key rrsig.Rrsig.signature ~msg)
| `RSA key ->
let hashp = ( = ) algorithm
and msg = `Message data
and signature = rrsig.Rrsig.signature
in
ok_if_true (Mirage_crypto_pk.Rsa.PKCS1.verify ~hashp ~key ~signature msg)
let filter_ds_if_sha2_present ds_set =
(* RFC 4509 - drop SHA1 DS if SHA2 DS are present *)
if Rr_map.Ds_set.exists (fun ds ->
match ds.Ds.digest_type with
| Ds.SHA256 | Ds.SHA384 -> true | _ -> false)
ds_set
then
Rr_map.Ds_set.filter
(fun ds -> not (ds.Ds.digest_type = SHA1))
ds_set
else
ds_set
let validate_ds zone dnskeys ds =
let* used_dnskey =
let key_signing_keys =
Rr_map.Dnskey_set.filter (fun dnsk ->
Dnskey.F.mem `Secure_entry_point dnsk.Dnskey.flags &&
Dnskey.key_tag dnsk = ds.Ds.key_tag)
dnskeys
in
if Rr_map.Dnskey_set.cardinal key_signing_keys = 1 then
Ok (Rr_map.Dnskey_set.choose key_signing_keys)
else
Error (`Msg (string_of_int (Rr_map.Dnskey_set.cardinal key_signing_keys) ^ " key signing keys for " ^ string_of_int ds.key_tag))
in
let* dgst = digest ds.Ds.digest_type zone used_dnskey in
if String.equal ds.Ds.digest dgst then begin
Log.debug (fun m -> m "Found DNSKEY for DS for zone %a (key tag %u)"
Domain_name.pp zone ds.Ds.key_tag);
Ok used_dnskey
end else
Error (`Msg "key signing key couldn't be validated")
let validate_rrsig_keys now dnskeys rrsigs requested_domain t v =
Log.debug (fun m -> m "validating for %a typ %a"
Domain_name.pp requested_domain
Rr_map.ppk (K t));
let keys_rrsigs =
Rr_map.Dnskey_set.fold (fun key acc ->
let key_tag = Dnskey.key_tag key in
let matching =
Rr_map.Rrsig_set.filter (fun rr -> rr.Rrsig.key_tag = key_tag) rrsigs
in
Rr_map.Rrsig_set.fold (fun rr acc -> (key, rr) :: acc) matching acc)
dnskeys []
in
Log.debug (fun m -> m "found %d key-rrsig pairs" (List.length keys_rrsigs));
let verify_signature (key, rrsig) =
let* pkey = dnskey_to_pk requested_domain key in
verify now pkey requested_domain rrsig t v
in
match List.partition Result.is_ok (List.map verify_signature keys_rrsigs) with
| r :: _, _ -> r
| [], e :: _ -> e
| [], [] -> Error (`Msg "no key-rrsig pair found")
let find_soa auth =
match
Domain_name.Map.fold (fun k (rr_map, kms) acc ->
match Rr_map.(find Soa rr_map) with
| Some soa -> Some (Domain_name.raw k, soa, KM.find (K Soa) kms)
| None -> acc)
auth None
with
| None -> Error (`Msg "no SOA in authority")
| Some (name, soa, used_name) ->
if Domain_name.equal name used_name then
Ok (name, soa)
else
Error (`Msg (Fmt.str "SOA owner %a differs from used name %a"
Domain_name.pp name Domain_name.pp used_name))
let is_name_in_chain ~soa_name ~name ~owner nsec =
(* for the last NSEC entry, next_domain is zone itself (thus = soa_name) *)
let next_owner = (snd nsec).Nsec.next_domain in
Domain_name.(compare owner name < 0 &&
(compare name next_owner < 0 ||
compare soa_name next_owner = 0))
let name_in_chain ~soa_name ~name ~owner nsec =
if is_name_in_chain ~soa_name ~name ~owner nsec then
Ok ()
else
Error (`Msg (Fmt.str "name not in chain: owner %a, name %a, next owner %a (soa %a)"
Domain_name.pp owner
Domain_name.pp name
Domain_name.pp (snd nsec).Nsec.next_domain
Domain_name.pp soa_name))
let nsec_chain ~soa_name name auth =
let matches =
Domain_name.Map.filter (fun owner rr_map ->
match Rr_map.find Nsec (fst rr_map) with
| Some nsec ->
Log.debug (fun m -> m "is domain name %a in chain %a (to %a)?"
Domain_name.pp name Domain_name.pp owner
Domain_name.pp (snd nsec).Nsec.next_domain);
is_name_in_chain ~soa_name ~name ~owner nsec
| None -> false)
auth
in
if Domain_name.Map.cardinal matches = 1 then
let owner, rrs = Domain_name.Map.choose matches in
let nsec = Rr_map.get Nsec (fst rrs) in
let used_name = KM.find (K Nsec) (snd rrs) in
if Domain_name.equal used_name owner then
Ok (owner, nsec)
else
Error (`Msg (Fmt.str "used_name %a is not owner %a in NSEC %a"
Domain_name.pp used_name Domain_name.pp owner
Nsec.pp (snd nsec)))
else
Error (`Msg (Fmt.str "couldn't find nsec chain record covering %a in %a"
Domain_name.pp name pp_km_name_rr_map auth))
let is_ent name ~owner nsec =
Domain_name.is_subdomain ~domain:name ~subdomain:(snd nsec).Nsec.next_domain &&
Domain_name.compare owner name < 0
let wildcard_non_existence ~soa_name name auth =
Log.debug (fun m -> m "wildcard non-existence %a (soa %a)"
Domain_name.pp name Domain_name.pp soa_name);
(* for non-existing wildcard NSEC: its owner must be between
<name> and <soa_name> *)
let rec proof_wildcard_absence name =
Log.debug (fun m -> m "proof_wildcards with %a" Domain_name.pp name);
if Domain_name.equal soa_name name then
Ok ()
else
match nsec_chain ~soa_name name auth with
| Ok (owner, nsec) when is_ent name ~owner nsec -> Ok ()
| _ ->
let wc_name = Domain_name.(prepend_label_exn (drop_label_exn name) "*") in
Log.debug (fun m -> m "proof_wildcard_absence %a, wc_name %a"
Domain_name.pp name
Domain_name.pp wc_name);
if Domain_name.Map.exists (fun _owner (rr_map, kms) ->
match Rr_map.find Nsec rr_map with
| Some nsec ->
let owner = KM.find (K Nsec) kms in
is_name_in_chain ~soa_name ~name:wc_name ~owner nsec
| None -> false)
auth
then
proof_wildcard_absence (Domain_name.drop_label_exn wc_name)
else
Error (`Msg (Fmt.str "no denial of existence for %a found"
Domain_name.pp wc_name))
in
proof_wildcard_absence name
let nsec3_hash salt iterations name =
let cs_name = Rr_map.canonical_encoded_name name in
let rec more = function
| 0 -> Digestif.SHA1.(digest_string (cs_name ^ salt) |> to_raw_string)
| k -> Digestif.SHA1.(digest_string ((more (k - 1)) ^ salt) |> to_raw_string)
in
more iterations
let nsec3_hashed_name salt iterations ~soa_name name =
let h = nsec3_hash salt iterations name in
Domain_name.prepend_label_exn soa_name (Base32.encode h)
let nsec3_rrs auth =
let nsec3_map =
(* filter out any non-nsec3 rrs and those where label_count doesn't match *)
Domain_name.Map.filter (fun name (rr_map, kms) ->
Rr_map.exists (function
| B (Nsec3, (_, nsec3)) ->
begin match nsec3.Nsec3.flags with
| Some `Opt_out | None -> true
| Some `Unknown _ -> false
end
| _ -> false) rr_map &&
Domain_name.equal name (KM.find (K Nsec3) kms))
auth
in
if Domain_name.Map.is_empty nsec3_map then
Error (`Msg "no NSEC3 resource record found")
else begin
Log.debug (fun m -> m "nsec3 non-existence %d" (Domain_name.Map.cardinal nsec3_map));
let Nsec3.{ iterations ; salt ; _ } =
let _, (rrs, _) = Domain_name.Map.choose nsec3_map in
snd (Rr_map.get Nsec3 rrs)
in
if iterations > 150 then
Error (`Msg "NSEC3 iterations greater than 150, ignoring")
else
Ok (nsec3_map, salt, iterations)
end
let nsec3_closest_encloser nsec3_map salt iterations ~soa_name name =
let rec find_it chop name =
let hashed_name = nsec3_hashed_name ~soa_name salt iterations name in
match Domain_name.Map.find hashed_name nsec3_map with
| Some (rrs, _) -> Ok (chop, name, Rr_map.get Nsec3 rrs)
| None ->
let* parent = Domain_name.drop_label name in
let chopped = Domain_name.get_label_exn name 0 in
find_it chopped parent
in
let* (last_chop, closest_encloser, closest_encloser_nsec) = find_it "" name in
Log.debug (fun m -> m "last chop %s closest encloser %a (hashed %a)"
last_chop Domain_name.pp closest_encloser
Domain_name.pp (nsec3_hashed_name ~soa_name salt iterations closest_encloser));
(* 8.3: DNAME bit must not be set, and NS may only be set if SOA bit is set *)
(* TODO DNAME *)
let* () =
let types = (snd closest_encloser_nsec).Nsec3.types in
if Bit_map.mem (Rr_map.to_int Ns) types then
if not (Bit_map.mem (Rr_map.to_int Soa) types) then
Error (`Msg (Fmt.str "nsec3 with NS but not SOA %a %a"
Domain_name.pp closest_encloser
Nsec3.pp (snd closest_encloser_nsec)))
else
(* RFC 5155 8.9: presence of NS implies absence of DNAME *)
Ok ()
else if Bit_map.mem (*DNAME*)39 types then
Error (`Msg (Fmt.str "nsec3 with DNAME %a %a"
Domain_name.pp closest_encloser
Nsec3.pp (snd closest_encloser_nsec)))
else
Ok ()
in
(* verify existence of nsec3 where owner < next_closer < next_owner_hashed *)
let next_closer = Domain_name.prepend_label_exn closest_encloser last_chop in
let next_closer_hashed = nsec3_hashed_name ~soa_name salt iterations next_closer in
Ok (closest_encloser, next_closer, next_closer_hashed)
let nsec3_between nsec3_map ~soa_name hashed_name =
Log.debug (fun m -> m "nsec3 between %a" Domain_name.pp hashed_name);
let m =
Domain_name.Map.filter (fun name (rrs, _) ->
if Domain_name.compare name hashed_name < 0 then begin
Log.debug (fun m -> m "(%a) yes %a" Domain_name.pp hashed_name
Domain_name.pp name);
let _, nsec3 = Rr_map.get Nsec3 rrs in
let hashed_next_owner =
Domain_name.prepend_label_exn soa_name
(Base32.encode nsec3.Nsec3.next_owner_hashed)
in
Log.debug (fun m -> m "(%a) comparing with %a: %d"
Domain_name.pp hashed_name
Domain_name.pp hashed_next_owner
(Domain_name.compare hashed_name hashed_next_owner));
Domain_name.compare hashed_name hashed_next_owner < 0
end else
false)
nsec3_map
in
if Domain_name.Map.cardinal m = 1 then
Ok (Domain_name.Map.choose m)
else begin
Log.debug (fun m -> m "nsec3 between %a no" Domain_name.pp hashed_name);
Error (`Msg (Fmt.str "no NSEC3 with owner < %a < next_owner_hashed"
Domain_name.pp hashed_name))
end
let nsec3_non_existence name ~soa_name auth =
Log.debug (fun m -> m "nsec3 non-existence %a (zone %a)"
Domain_name.pp name Domain_name.pp soa_name);
let* (nsec3_map, salt, iterations) = nsec3_rrs auth in
let* (closest_encloser, _next_closer, hashed_next_closer) =
nsec3_closest_encloser nsec3_map salt iterations ~soa_name name
in
let* (_, (rrs, _)) = nsec3_between nsec3_map ~soa_name hashed_next_closer in
let nsec_next_closer = Rr_map.get Nsec3 rrs in
let opt_out =
match (snd nsec_next_closer).Nsec3.flags with
| Some `Opt_out -> true
| Some `Unknown _ | None -> false
in
Log.debug (fun m -> m "next_closer %a proved, opt out %B"
Domain_name.pp hashed_next_closer opt_out);
(* TODO 8.5 and 8.6!? *)
if opt_out then
Ok nsec_next_closer
else
(* verify existence of nsec3 where owner < wc < next_owner_hashed *)
let wc = Domain_name.prepend_label_exn closest_encloser "*" in
let hashed_wc = nsec3_hashed_name ~soa_name salt iterations wc in
let* _ = nsec3_between nsec3_map ~soa_name hashed_wc in
Ok nsec_next_closer
let nsec3_chain ~soa_name ~wc_name ~name auth =
Log.debug (fun m -> m "nsec3 chain soa %a wc %a name %a"
Domain_name.pp soa_name Domain_name.pp wc_name
Domain_name.pp name);
let closest_encloser = Domain_name.drop_label_exn wc_name in
let next_closer =
let lbl_idx = Domain_name.count_labels closest_encloser in
let lbl = Domain_name.get_label_exn ~rev:true name lbl_idx in
Domain_name.prepend_label_exn closest_encloser lbl
in
Log.debug (fun m -> m "next_closer %a" Domain_name.pp next_closer);
let* (nsec3_map, salt, iterations) = nsec3_rrs auth in
let hashed_next_closer =
nsec3_hashed_name ~soa_name salt iterations next_closer
in
nsec3_between nsec3_map ~soa_name hashed_next_closer
let nsec_non_existence name ~soa_name auth =
let* _ = nsec_chain ~soa_name name auth in
wildcard_non_existence ~soa_name name auth
let no_domain name auth =
(* no domain:
- a SOA from a parent (zone), plus RRSIG
- an NSEC for non-existing wildcard, plus rrsig
- a NSEC <prev domain> .. <next-domain>, plus rrsig
-> ensure requested_domain is between these domains *)
let* (soa_name, soa) = find_soa auth in
let* () =
if Domain_name.is_subdomain ~subdomain:name ~domain:soa_name then
Ok ()
else
Error (`Msg (Fmt.str "question %a is not subdomain of SOA %a"
Domain_name.pp name Domain_name.pp soa_name))
in
match
nsec_non_existence name ~soa_name auth,
nsec3_non_existence name ~soa_name auth
with
| Ok (), _ | _, Ok _ -> Ok (soa_name, soa)
| Error _ as e, _ -> e
let nsec_no_data ~soa_name name k auth =
match Domain_name.Map.find name auth with
| Some (rr_map, kms) when Rr_map.mem Nsec rr_map ->
let nsec = Rr_map.get Nsec rr_map
and nsec_owner = KM.find (K Nsec) kms
in
let* () =
if Domain_name.equal nsec_owner name then
Ok ()
else
Error (`Msg (Fmt.str "nsec owner %a is not name %a"
Domain_name.pp nsec_owner
Domain_name.pp name))
in
if Bit_map.mem (Rr_map.to_int k) (snd nsec).Nsec.types then
Error (`Msg (Fmt.str "nsec claims type %a to be present" Rr_map.ppk (K k)))
else if Bit_map.mem (Rr_map.to_int Cname) (snd nsec).Nsec.types then
Error (`Msg (Fmt.str "nsec claims CNAME to be present"))
else
Ok ()
| _ ->
(* nsec in chain ++ wildcard nsec *)
let* _ = nsec_chain ~soa_name name auth in
let rec find_wc name =
if Domain_name.is_subdomain ~domain:soa_name ~subdomain:name then
let wc_name = Domain_name.prepend_label_exn name "*" in
Log.debug (fun m -> m "looking for %a" Domain_name.pp wc_name);
match Domain_name.Map.find wc_name auth with
| Some (rr_map, kms) when Rr_map.mem Nsec rr_map ->
let nsec = Rr_map.get Nsec rr_map
and nsec_owner = KM.find (K Nsec) kms
in
Ok (wc_name, nsec, nsec_owner)
| _ ->
let* name = Domain_name.drop_label name in
find_wc name
else
Error (`Msg "no wildcard nsec found")
in
match find_wc name with
| Ok (wc_name, wc_nsec, wc_nsec_owner) ->
let* () =
if Domain_name.equal wc_nsec_owner wc_name then
Ok ()
else
Error (`Msg (Fmt.str "bad wildcard nsec, wc_name %a nsec_owner %a"
Domain_name.pp wc_name Domain_name.pp wc_nsec_owner))
in
if Bit_map.mem (Rr_map.to_int k) (snd wc_nsec).Nsec.types then
Error (`Msg (Fmt.str "nsec claims type %a to be present" Rr_map.ppk (K k)))
else
Ok ()
| Error _ ->
wildcard_non_existence ~soa_name name auth
let nsec3_no_data ~soa_name name k auth =
Log.debug (fun m -> m "nsec3 no data %a (zone %a)"
Domain_name.pp name Domain_name.pp soa_name);
let* (nsec3_map, salt, iterations) = nsec3_rrs auth in
let hashed_name = nsec3_hashed_name ~soa_name salt iterations name in
match Domain_name.Map.find hashed_name nsec3_map with
| Some (rr_map, _) ->
let _, nsec3 = Rr_map.get Nsec3 rr_map in
if Bit_map.mem (Rr_map.to_int k) nsec3.Nsec3.types then
Error (`Msg (Fmt.str "nsec3 claims type %a to be present" Rr_map.ppk (K k)))
else if Bit_map.mem (Rr_map.to_int Cname) nsec3.Nsec3.types then
Error (`Msg (Fmt.str "nsec3 claims type Cname to be present"))
else
Ok ()
| None ->
let* (_closest_encloser, _next_closer, hashed_next_closer) =
nsec3_closest_encloser nsec3_map salt iterations ~soa_name name
in
let* (_, (rrs, _)) = nsec3_between nsec3_map ~soa_name hashed_next_closer in
let nsec_next_closer = Rr_map.get Nsec3 rrs in
let opt_out =
match (snd nsec_next_closer).Nsec3.flags with
| Some `Opt_out -> true
| Some `Unknown _ | None -> false
in
Log.debug (fun m -> m "next_closer %a proved, opt out %B"
Domain_name.pp hashed_next_closer opt_out);
if opt_out then
Ok ()
else
Error (`Msg "no NSEC3, and next_closer has no opt-out")
let no_data name k auth =
(* no data:
- SOA + RRSIG
- (NSEC for name (and not for type = k) OR wildcard NSEC) + RRSIG
*)
let* (soa_name, soa) = find_soa auth in
let* () =
if Domain_name.is_subdomain ~subdomain:name ~domain:soa_name then
Ok ()
else
Error (`Msg (Fmt.str "name %a is not a subdomain of soa %a"
Domain_name.pp name Domain_name.pp soa_name))
in
match
nsec_no_data ~soa_name name k auth,
nsec3_no_data ~soa_name name k auth
with
| Ok (), _ | _, Ok () -> Ok (soa_name, soa)
| Error _ as e, _ -> e
let has_delegation name_rr_map name =
let rrs =
Domain_name.Map.filter (fun owner_name rrs ->
Domain_name.is_subdomain ~domain:owner_name ~subdomain:name &&
Rr_map.mem Ns rrs) name_rr_map
in
Log.debug (fun m -> m "has_delegation with %d in %a"
(Domain_name.Map.cardinal rrs)
Name_rr_map.pp name_rr_map);
if Domain_name.Map.cardinal rrs = 1 then
Some (Domain_name.Map.choose rrs)
else
None
let validate_delegation signer_name auth (zname, rrs) =
let _, ns = Rr_map.get Ns rrs in
match Domain_name.Map.find zname auth with
| Some (rrs, kms) when Rr_map.mem Ds rrs ->
let ds = snd (Rr_map.get Ds rrs) in
let used_name = KM.find (K Ds) kms in
if not (Domain_name.equal used_name zname) then
Error (`Msg (Fmt.str "owner %a of DS %a does not match used name %a"
Domain_name.pp zname
Fmt.(list ~sep:(any ", ") Ds.pp)
(Rr_map.Ds_set.elements ds)
Domain_name.pp used_name))
else
Ok (`Signed_delegation (zname, ns, ds))
| Some (rrs, kms) when Rr_map.mem Nsec rrs ->
let nsec = snd (Rr_map.get Nsec rrs) in
let used_name = KM.find (K Nsec) kms in
if not (Domain_name.equal used_name zname) then
Error (`Msg (Fmt.str "owner %a of Nsec %a does not match used name %a"
Domain_name.pp zname
Nsec.pp nsec
Domain_name.pp used_name))
else if
(not (Bit_map.mem (Rr_map.to_int Ds) nsec.Nsec.types)) &&
Bit_map.mem (Rr_map.to_int Ns) nsec.Nsec.types
then
Ok (`Unsigned_delegation (zname, ns))
else
Error (`Msg (Fmt.str "NSEC present for %a (%a), but either has DS or no NS bits"
Domain_name.pp zname Nsec.pp nsec))
| _ ->
let soa_name = Option.value ~default:Domain_name.root signer_name in
let* nsec3 = nsec3_non_existence zname ~soa_name auth in
if (snd nsec3).Nsec3.flags = Some `Opt_out then
Ok (`Unsigned_delegation (zname, ns))
else
Error (`Msg (Fmt.str "NSEC3 for closest encloser %a present %a, but not opt-out"
Domain_name.pp zname
Nsec3.pp (snd nsec3)))
let maybe_validate_wildcard_answer signer_name auth kms name k =
let used_name = KM.find (K k) kms in
if Domain_name.equal used_name name then
Ok ()
else begin
(* RFC 4035 5.3.4 - verify in authority the wildcard-expanded
positive reply (no direct match) *)
(* RFC 5155 8.8 - there's a candidate closest encloser for qname
(the used_name without "*") - need to verify existence of a nsec3
covering next_closer name to qname *)
(match signer_name with
| None -> Log.warn (fun m -> m "no signer name provided")
| Some _ -> ());
let soa_name = Option.value ~default:Domain_name.root signer_name in
match
nsec_chain ~soa_name name auth,
nsec3_chain ~soa_name ~wc_name:used_name ~name auth
with
| Ok _, _ | _, Ok _ -> Ok ()
| Error _ as e, _ -> e
end
let validate_answer :
type a. ?signer_name:[`raw] Domain_name.t ->
[`raw] Domain_name.t -> a Rr_map.rr ->
(Rr_map.t * [`raw] Domain_name.t KM.t) Domain_name.Map.t ->
(Rr_map.t * [`raw] Domain_name.t KM.t) Domain_name.Map.t ->
Name_rr_map.t ->
(a,
[> `Cname of [`raw] Domain_name.t
| `Unsigned_delegation of [`raw] Domain_name.t * Domain_name.Host_set.t
| `Signed_delegation of [`raw] Domain_name.t * Domain_name.Host_set.t * Rr_map.Ds_set.t
| `No_data of [`raw] Domain_name.t * Soa.t
| `Msg of string ]) result =
fun ?signer_name name k answer auth raw_auth ->
Log.debug (fun m -> m "validating %a (%a)"
Domain_name.pp name Rr_map.ppk (K k));
match Domain_name.Map.find name answer with
| None ->
(* left are two options: no data OR delegation *)
Option.fold
~none:(
let* (soa_name, soa) = no_data name k auth in
Log.debug (fun m -> m "validated no data");
Error (`No_data (soa_name, soa)))
~some:(fun x ->
let* r = validate_delegation signer_name auth x in
Error r)
(has_delegation raw_auth name)
| Some (rr_map, kms) ->
match Rr_map.find k rr_map with
| Some rrs ->
let* () = maybe_validate_wildcard_answer signer_name auth kms name k in
Ok rrs
| None ->
match Rr_map.find Cname rr_map with
| None ->
let* (soa_name, soa) = no_data name k auth in
Log.debug (fun m -> m "validated no data");
Error (`No_data (soa_name, soa))
| Some rr ->
let* () = maybe_validate_wildcard_answer signer_name auth kms name Cname in
Log.info (fun m -> m "verified CNAME to %a" Domain_name.pp (snd rr));
Error (`Cname (snd rr))
type err = [
| `Cname of [ `raw ] Domain_name.t
| `Unsigned_delegation of [`raw] Domain_name.t * Domain_name.Host_set.t
| `Signed_delegation of [`raw] Domain_name.t * Domain_name.Host_set.t * Rr_map.Ds_set.t
| `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
| `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t
| `Msg of string
]
let pp_err ppf = function
| `Cname alias -> Fmt.pf ppf "cname %a" Domain_name.pp alias
| `Unsigned_delegation (owner, ns) ->
Fmt.pf ppf "unsigned delegation of %a to %a"
Domain_name.pp owner
Fmt.(list ~sep:(any ", ") Domain_name.pp)
(Domain_name.Host_set.elements ns)
| `Signed_delegation (owner, ns, ds) ->
Fmt.pf ppf "signed delegation of %a to %a (DS %a)"
Domain_name.pp owner
Fmt.(list ~sep:(any ", ") Domain_name.pp)
(Domain_name.Host_set.elements ns)
Fmt.(list ~sep:(any ", ") Ds.pp)
(Rr_map.Ds_set.elements ds)
| `No_data (name, soa) ->
Fmt.pf ppf "no data %a %a" Domain_name.pp name Soa.pp soa
| `No_domain (name, soa) ->
Fmt.pf ppf "no domain %a %a" Domain_name.pp name Soa.pp soa
| `Msg m -> Fmt.pf ppf "error %s" m
let fold_option a b =
match a, b with
| None, None -> None
| Some a, None -> Some a
| None, Some b -> Some b
| Some a, Some b ->
if not (Domain_name.equal a b) then
Log.warn (fun m -> m "different signer names %a and %a"
Domain_name.pp a Domain_name.pp b);
Some a
(* to avoid missing a signature check, and also checking the signature
multiple times, first verify all signatures in the map *)
let check_signatures now dnskeys map =
(* the result is again a map, but with an additional nesting to track the
used name (wildcard signatures) *)
Domain_name.Map.fold (fun name rr_map (signer_name, acc) ->
let rrsig_ttl, rrsigs =
Option.value ~default:(0l, Rr_map.Rrsig_set.empty)
(Rr_map.find Rrsig rr_map)
in
let signer_name, rrs = Rr_map.fold (fun b ((signer_name, (rrs, names)) as acc) ->
match b with
| B (Rr_map.Rrsig, _) -> acc
| B (k, v) ->
let int = Rr_map.to_int k in
let rrsigs =
Rr_map.Rrsig_set.filter
(fun rrsig -> rrsig.Rrsig.type_covered = int)
rrsigs
in
if Rr_map.Rrsig_set.is_empty rrsigs then
Log.warn (fun m -> m "couldn't find RRSIG for %a %a"
Domain_name.pp name Rr_map.pp_b b);
match validate_rrsig_keys now dnskeys rrsigs name k v with
| Ok (used_name, signer_name') ->
let signer = fold_option signer_name (Some signer_name') in
let rrs = Rr_map.add k v rrs in
let rrs =
Rr_map.update Rrsig (function
| None -> Some (rrsig_ttl, rrsigs)
| Some (_, s) ->
Some (rrsig_ttl, Rr_map.Rrsig_set.union s rrsigs))
rrs
in
signer, (rrs, KM.add (Rr_map.K k) used_name names)
| Error `Msg msg ->
Log.warn (fun m -> m "RRSIG verification for %a %a failed: %s"
Domain_name.pp name Rr_map.pp_b b msg);
acc
| Error `Extended e ->
Log.warn (fun m -> m "RRSIG verification for %a %a failed: %a"
Domain_name.pp name Rr_map.pp_b b
Extended_error.pp e);
acc)
rr_map (signer_name, (Rr_map.empty, KM.empty))
in
signer_name,
if Rr_map.is_empty (fst rrs) then
acc
else
Domain_name.Map.add name rrs acc)
map (None, Domain_name.Map.empty)
let verify_reply : type a. ?fuel:int -> ?follow_cname:bool ->
Ptime.t -> Rr_map.Dnskey_set.t -> [`raw] Domain_name.t -> a Rr_map.rr ->
Packet.reply ->
(a,
[> `Cname of [ `raw ] Domain_name.t
| `Unsigned_delegation of [`raw] Domain_name.t * Domain_name.Host_set.t
| `Signed_delegation of [`raw] Domain_name.t * Domain_name.Host_set.t * Rr_map.Ds_set.t
| `No_data of [ `raw ] Domain_name.t * Dns.Soa.t
| `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t
| `Msg of string ]) result =
fun ?(fuel = 20) ?(follow_cname = true) now dnskeys name k reply ->
Log.debug (fun m -> m "verifying %a (%a)"
Domain_name.pp name Rr_map.ppk (K k));
match reply with
| `Answer (answer, authority) ->
let signer_name, signed_answer = check_signatures now dnskeys answer
and signer_name2, signed_authority = check_signatures now dnskeys authority
in
let signer_name = fold_option signer_name signer_name2 in
begin
let rec more ~fuel name =
if fuel = 0 then
Error (`Msg "too many CNAME redirections")
else
match validate_answer ?signer_name name k signed_answer signed_authority authority with
| Error `Cname other when follow_cname ->
more ~fuel:(fuel - 1) other
| r -> r
in
more ~fuel name
end
| `Rcode_error (NXDomain, Query, Some (answer, authority)) ->
let signer_name, _answer = check_signatures now dnskeys answer
and signer_name2, authority = check_signatures now dnskeys authority
in
let _signer_name = fold_option signer_name signer_name2 in
let* (soa_name, soa) = no_domain name authority in
Error (`No_domain (soa_name, soa))
| r ->
Error (`Msg (Fmt.str "unexpected reply: %a" Packet.pp_reply r))
let remove_km map =
Domain_name.Map.fold
(fun name (rrs, _) acc -> Domain_name.Map.add name rrs acc)
map Domain_name.Map.empty
let verify_packet now dnskeys packet =
let qname = fst packet.Packet.question in
let* data =
match packet.Packet.data with
| `Answer (answer, authority) ->
let signer_name, signed_answer = check_signatures now dnskeys answer
and signer_name2, signed_auth = check_signatures now dnskeys authority
in
let signer_name = fold_option signer_name signer_name2 in
let ans = remove_km signed_answer and auth = remove_km signed_auth in
begin match Domain_name.Map.find qname signed_answer with
| None ->
Option.fold
~none:(
match snd packet.question with
| `K K k ->
let* _ = no_data qname k signed_auth in
Ok (`Answer (ans, auth))
| _ -> Error (`Msg "qtype is not a valid typ"))
~some:(fun (zname, rrs) ->
(* add (unsigned!) rrs back into auth *)
let* _ = validate_delegation signer_name signed_auth (zname, rrs) in
let ns_rr = Rr_map.get Ns rrs in
let auth =
Domain_name.Map.update zname
(function
| None -> Some Rr_map.(singleton Ns ns_rr)
| Some rrs -> Some Rr_map.(add Ns ns_rr rrs))
auth
in
Ok (`Answer (ans, auth))
)
(has_delegation authority qname)
| Some (rrs, kms) ->
begin match snd packet.question with
| `K K k ->
begin match Rr_map.find k rrs, Rr_map.find Cname rrs with
| None, None ->
let* _ = no_data qname k signed_auth in
Ok (`Answer (ans, auth))
| Some _, _ ->
let* _ = maybe_validate_wildcard_answer signer_name signed_auth kms qname k in
Ok (`Answer (ans, auth))
| _, Some _ ->
let* _ = maybe_validate_wildcard_answer signer_name signed_auth kms qname Cname in
Ok (`Answer (ans, auth))
end
| _ -> Error (`Msg "qtype is not a valid typ")
end
end
| `Rcode_error (Rcode.NXDomain, Query, Some (answer, authority)) ->
let signer_name, signed_answer = check_signatures now dnskeys answer
and signer_name2, signed_authority = check_signatures now dnskeys authority
in
let _signer_name = fold_option signer_name signer_name2 in
let* _ = no_domain qname signed_authority in
let answer = remove_km signed_answer and auth = remove_km signed_authority in
Ok (`Rcode_error (Rcode.NXDomain, Opcode.Query, Some (answer, auth)))
| `Rcode_error (rc, op, Some (ans, aut)) ->
let signer_name, signed_answer = check_signatures now dnskeys ans
and signer_name2, signed_authority = check_signatures now dnskeys aut
in
let _signer_name = fold_option signer_name signer_name2 in
let answer = remove_km signed_answer and auth = remove_km signed_authority in
Ok (`Rcode_error (rc, op, Some (answer, auth)))
| `Rcode_error (rc, op, None) -> Ok (`Rcode_error (rc, op, None))
| x -> Ok x
in
Ok (Packet.create ~additional:packet.additional ?edns:packet.edns
?tsig:packet.tsig packet.header packet.question data)

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

@ -0,0 +1,5 @@
(library
(name dnssec)
(public_name dnssec)
(wrapped false)
(libraries mirage-crypto mirage-crypto-pk mirage-crypto-ec dns logs domain-name))

4
unikernel/duniverse/ocaml-dns/dune-project Normal file
View file

@ -0,0 +1,4 @@
(lang dune 2.8)
(name dns)
(version v10.2.2)
(formatting disabled)

368
unikernel/duniverse/ocaml-dns/lwt/client/dns_client_lwt.ml Normal file
View file

@ -0,0 +1,368 @@
open Lwt.Infix
module IM = Map.Make(Int)
let src = Logs.Src.create "dns_client_lwt" ~doc:"effectful DNS lwt layer"
module Log = (val Logs.src_log src : Logs.LOG)
module Transport : Dns_client.S
with type io_addr = [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ]
and type +'a io = 'a Lwt.t
and type stack = Happy_eyeballs_lwt.t
= struct
type io_addr = [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ]
type +'a io = 'a Lwt.t
type stack = Happy_eyeballs_lwt.t
type nameservers =
| Static of io_addr list
| Resolv_conf of {
mutable nameservers : io_addr list;
mutable digest : Digest.t option
}
type t = {
nameservers : nameservers;
timeout_ns : int64 ;
(* TODO: avoid race, use a mvar instead of condition *)
mutable fd : [ `Plain of Lwt_unix.file_descr | `Tls of Tls_lwt.Unix.t ] option ;
mutable connected_condition : (unit, [ `Msg of string ]) result Lwt_condition.t option ;
mutable requests : (string * (string, [ `Msg of string ]) result Lwt_condition.t) IM.t ;
he : Happy_eyeballs_lwt.t ;
}
type context = t
let nameserver_ips = function
| Static nameservers -> nameservers
| Resolv_conf { nameservers; _ } -> nameservers
let read_file file =
try
let fh = open_in file in
try
let content = really_input_string fh (in_channel_length fh) in
close_in_noerr fh ;
Ok content
with _ ->
close_in_noerr fh;
Error (`Msg ("Error reading file: " ^ file))
with _ -> Error (`Msg ("Error opening file " ^ file))
let clock = Mtime_clock.elapsed_ns
let close_socket fd =
Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit)
let authenticator =
let authenticator_ref = ref None in
fun () ->
match !authenticator_ref with
| Some x -> x
| None -> match Ca_certs.authenticator () with
| Ok a -> authenticator_ref := Some a ; a
| Error `Msg m -> invalid_arg ("failed to load trust anchors: " ^ m)
let decode_resolv_conf data =
let ( let* ) = Result.bind in
let authenticator = authenticator () in
let* ns = Dns_resolvconf.parse data in
match
List.flatten
(List.map
(fun (`Nameserver ip) ->
match Tls.Config.client ~authenticator ~ip () with
| Ok tls -> [ `Tls (tls, ip, 853) ; `Plaintext (ip, 53) ]
| Error `Msg msg ->
Log.err (fun m -> m "creating TLS configuratio for %a: %s"
Ipaddr.pp ip msg);
[ `Plaintext (ip, 53) ])
ns)
with
| [] -> Error (`Msg "no nameservers in resolv.conf")
| ns -> Ok ns
let resolv_conf () =
let ( let* ) = Result.bind in
let* data = read_file "/etc/resolv.conf" in
let* ns =
Result.map_error
(function `Msg msg ->
Log.warn (fun m -> m "error %s decoding resolv.conf %S" msg data);
`Msg msg)
(decode_resolv_conf data)
in
Ok (ns, Digest.string data)
let default_resolver () =
let authenticator = authenticator () in
let peer_name = Dns_client.default_resolver_hostname in
let tls_config =
match Tls.Config.client ~authenticator ~peer_name () with
| Ok cfg -> cfg
| Error `Msg msg -> invalid_arg msg
in
List.map (fun ip -> `Tls (tls_config, ip, 853)) Dns_client.default_resolvers
let maybe_resolv_conf t =
match t.nameservers with
| Static _ -> ()
| Resolv_conf resolv_conf ->
let needs_update =
match read_file "/etc/resolv.conf", resolv_conf.digest with
| Ok data, Some dgst ->
let dgst' = Digest.string data in
if Digest.equal dgst' dgst then
`No
else
`Data (data, dgst')
| Ok data, None ->
let digest = Digest.string data in
`Data (data, digest)
| Error _, None ->
`No
| Error `Msg msg, Some _ ->
Log.warn (fun m -> m "error reading /etc/resolv.conf: %s" msg);
`Default
in
match needs_update with
| `No -> ()
| `Default ->
resolv_conf.digest <- None;
resolv_conf.nameservers <- default_resolver ()
| `Data (data, dgst) ->
match decode_resolv_conf data with
| Ok ns ->
resolv_conf.digest <- Some dgst;
resolv_conf.nameservers <- ns
| Error `Msg msg ->
Log.warn (fun m -> m "error %s decoding resolv.conf: %S" msg data);
resolv_conf.digest <- None;
resolv_conf.nameservers <- default_resolver ()
let create ?nameservers ~timeout happy_eyeballs =
let nameservers =
match nameservers with
| Some (`Udp, _) -> invalid_arg "UDP is not supported"
| Some (`Tcp, ns) -> Static ns
| None ->
match resolv_conf () with
| Error _ -> Resolv_conf { nameservers = default_resolver (); digest = None }
| Ok (ips, digest) -> Resolv_conf { nameservers = ips; digest = Some digest }
in
{
nameservers ;
timeout_ns = timeout ;
fd = None ;
connected_condition = None ;
requests = IM.empty ;
he = happy_eyeballs ;
}
let nameservers { nameservers; _ } = `Tcp, nameserver_ips nameservers
let rng = Mirage_crypto_rng.generate ?g:None
let with_timeout timeout f =
let timeout =
Lwt_unix.sleep (Duration.to_f timeout) >|= fun () ->
Error (`Msg "DNS request timeout")
in
Lwt.pick [ f ; timeout ]
let close _ = Lwt.return_unit
let send_query fd tx =
Lwt.catch (fun () ->
match fd with
| `Plain fd ->
Lwt_unix.send fd (Bytes.unsafe_of_string tx) 0
(String.length tx) [] >>= fun res ->
if res <> String.length tx then
Lwt_result.fail (`Msg ("oops" ^ (string_of_int res)))
else
Lwt_result.return ()
| `Tls fd ->
Lwt_result.ok (Tls_lwt.Unix.write fd tx))
(fun e -> Lwt.return (Error (`Msg (Printexc.to_string e))))
let send_recv (t : context) tx =
if String.length tx > 4 then
match t.fd with
| None -> Lwt.return (Error (`Msg "no connection to the nameserver established"))
| Some fd ->
let id = String.get_uint16_be tx 2 in
with_timeout t.timeout_ns
(let open Lwt_result.Infix in
send_query fd 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 DNS packet (data length <= 4)"))
let bind = Lwt.bind
let lift = Lwt.return
let rec read_loop ?(linger = "") (t : t) fd =
Lwt.catch (fun () ->
match fd with
| `Plain fd ->
let recv_buffer = Bytes.create 2048 in
Lwt_unix.recv fd recv_buffer 0 (Bytes.length recv_buffer) [] >|= fun r ->
(r, recv_buffer)
| `Tls fd ->
let recv_buffer = Bytes.create 2048 in
Tls_lwt.Unix.read fd recv_buffer >|= fun r ->
(r, recv_buffer))
(fun e ->
Log.err (fun m -> m "error %s reading from resolver" (Printexc.to_string e));
Lwt.return (0, Bytes.empty)) >>= function
| (0, _) ->
(match fd with
| `Plain fd -> close_socket fd
| `Tls fd -> Tls_lwt.Unix.close fd) >|= fun () ->
t.fd <- None;
if not (IM.is_empty t.requests) then
Log.info (fun m -> m "end of file reading from resolver")
| (read_len, cs) ->
let rec handle_data data =
let cs_len = String.length data in
if cs_len > 2 then
let len = String.get_uint16_be data 0 in
if cs_len - 2 >= len then
let packet, rest =
if cs_len - 2 = len
then data, ""
else String.sub data 0 (len + 2), String.sub data (len + 2) (String.length data - len - 2)
in
let id = String.get_uint16_be 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 fd
else
read_loop ~linger:data t fd
in
let cs = String.sub (Bytes.unsafe_to_string cs) 0 read_len in
handle_data (if String.length linger = 0 then cs else linger ^ cs)
let req_all fd t =
IM.fold (fun _id (data, _) r ->
r >>= function
| Error _ as e -> Lwt.return e
| Ok () -> send_query fd 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_to_ns_list (t : t) connected_condition nameservers =
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. *)
Happy_eyeballs_lwt.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 (nameserver_ips t.nameservers))))
in
Lwt_condition.broadcast connected_condition err;
t.connected_condition <- None;
Lwt.return err
| Ok (addr, socket) ->
let continue socket =
t.fd <- Some socket;
Lwt.async (fun () ->
read_loop t socket >>= fun () ->
if IM.is_empty t.requests then
Lwt.return_unit
else
connect_via_tcp_to_ns t >|= function
| Error (`Msg msg) ->
Log.err (fun m -> m "error while connecting to resolver: %s" msg)
| Ok () -> ());
Lwt_condition.broadcast connected_condition (Ok ());
t.connected_condition <- None;
req_all socket t
in
let config = find_ns (nameserver_ips t.nameservers) addr in
match config with
| `Plaintext _ -> continue (`Plain socket)
| `Tls (tls_cfg, _, _) ->
Lwt.catch (fun () ->
Tls_lwt.Unix.client_of_fd tls_cfg socket >>= fun f ->
continue (`Tls f))
(fun e ->
Log.warn (fun m -> m "TLS handshake with %a:%d failed: %s"
Ipaddr.pp (fst addr) (snd addr) (Printexc.to_string 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_to_ns_list t connected_condition ns')
and connect_via_tcp_to_ns (t : t) =
match t.fd, t.connected_condition with
| Some _, _ -> Lwt.return (Ok ())
| None, Some w -> Lwt_condition.wait w
| None, None ->
let connected_condition = Lwt_condition.create () in
t.connected_condition <- Some connected_condition ;
maybe_resolv_conf t;
connect_to_ns_list t connected_condition (nameserver_ips t.nameservers)
let connect t =
connect_via_tcp_to_ns t >|= function
| Ok () -> Ok (`Tcp, t)
| Error `Msg msg -> Error (`Msg msg)
end
(* Now that we have our {!Transport} implementation we can include the logic
that goes on top of it: *)
include Dns_client.Make(Transport)
let create ?cache_size ?edns ?nameservers ?timeout happy_eyeballs =
let dns = create ?cache_size ?edns ?nameservers ?timeout happy_eyeballs in
let getaddrinfo record domain_name =
let open Lwt_result.Infix in
match record with
| `A ->
getaddrinfo dns 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 dns 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
Happy_eyeballs_lwt.inject happy_eyeballs getaddrinfo;
dns
(* initialize the RNG *)
let () = Mirage_crypto_rng_unix.use_default ()

18
unikernel/duniverse/ocaml-dns/lwt/client/dns_client_lwt.mli Normal file
View file

@ -0,0 +1,18 @@
(** {!Lwt_unix} helper module for {!Dns_client}.
For more information see the {!Dns_client.Make} functor.
The {!Dns_client} is available as Dns_client_lwt after
linking to dns-client.lwt in your dune file.
It initializes the RNG (using Mirage_crypto_rng_lwt.initialize ()).
*)
(** A flow module based on non-blocking I/O on top of the
Lwt_unix socket API. *)
module Transport : Dns_client.S
with type io_addr = [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ]
and type +'a io = 'a Lwt.t
and type stack = Happy_eyeballs_lwt.t
include module type of Dns_client.Make(Transport)

6
unikernel/duniverse/ocaml-dns/lwt/client/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name dns_client_lwt)
(modules dns_client_lwt)
(public_name dns-client-lwt)
(libraries lwt lwt.unix dns dns-client dns-client.resolvconf mtime.clock.os mirage-crypto-rng.unix ipaddr.unix happy-eyeballs happy-eyeballs-lwt tls-lwt ca-certs)
(wrapped false))

189
unikernel/duniverse/ocaml-dns/miou/client/dns_client_miou_unix.ml Normal file
View file

@ -0,0 +1,189 @@
let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
let src = Logs.Src.create "dns-client-miou-unix"
module Log = (val Logs.src_log src : Logs.LOG)
module Transport = struct
open Happy_eyeballs_miou_unix
type +'a io = 'a
type io_addr =
[ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ]
type t = {
nameservers: io_addr list
; proto: Dns.proto
; timeout: float
; happy: stack
}
and stack = Happy_eyeballs_miou_unix.t
type context =
{ fd : [ `Udp of Miou_unix.file_descr
| `Tcp of Miou_unix.file_descr
| `Tls of Tls_miou_unix.t ]
; timeout : float }
let clock = Mtime_clock.elapsed_ns
let same_address ipaddr' port' = function
| `Plaintext (ipaddr, port) -> Ipaddr.compare ipaddr ipaddr' = 0 && port = port'
| `Tls (_, ipaddr, port) -> Ipaddr.compare ipaddr ipaddr' = 0 && port = port'
exception Timeout
let with_timeout ~timeout:ts fn =
let timeout () = Miou_unix.sleep ts; raise Timeout in
let prm1 = Miou.async timeout in
let prm0 = Miou.async fn in
Miou.await_first [ prm0; prm1 ]
let connect_to_nameservers t =
let ( let* ) = Result.bind in
match t.proto with
| `Tcp ->
let ip_of_nameserver = function
| `Plaintext (ipaddr, port) -> (ipaddr, port)
| `Tls (_, ipaddr, port) -> (ipaddr, port) in
let ips = List.map ip_of_nameserver t.nameservers in
let* ((ipaddr, port) as addr), fd = connect_ip t.happy ips in
begin match List.find (same_address ipaddr port) t.nameservers with
| `Plaintext _ -> Ok (addr, `Tcp fd)
| `Tls (config, _, _) ->
try let fd = Tls_miou_unix.client_of_fd config fd in
Ok (addr, `Tls fd)
with End_of_file ->
Miou_unix.close fd;
error_msgf "Connection to nameservers (via TLS) impossible" end
| `Udp ->
let is_plaintext = function `Plaintext v -> Either.Left v | _ -> Either.Right () in
let[@warning "-8"] (ipaddr, port) :: _, _ = List.partition_map is_plaintext t.nameservers in
let proto_number, socket_type = Unix.((getprotobyname "udp").p_proto, SOCK_DGRAM) in
let domain = match ipaddr with
| Ipaddr.V4 _ -> Unix.PF_INET
| Ipaddr.V6 _ -> Unix.PF_INET6 in
let fd = Unix.socket domain socket_type proto_number in
let addr = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ipaddr, port) in
let connect () =
Unix.connect fd addr;
((ipaddr, port), `Udp (Miou_unix.of_file_descr fd)) in
match with_timeout ~timeout:t.timeout connect with
| Ok value -> Ok value
| Error Timeout ->
Unix.close fd;
error_msgf "Connection to nameservers (via UDP) timeout"
| Error exn ->
Unix.close fd;
error_msgf "Unexpected error: %S" (Printexc.to_string exn)
let nameservers { nameservers; proto; _ } = (proto, nameservers)
let bind x f = f x
let lift = Fun.id
let rng = Mirage_crypto_rng.generate ?g:None
let connect t =
let ( let* ) = Result.bind in
let* ((addr, port), fd) = connect_to_nameservers t in
Log.debug (fun m -> m "Connected to a nameserver %a:%d" Ipaddr.pp addr port);
match fd with
| `Tcp _ | `Tls _ -> Ok (`Tcp, { fd; timeout= t.timeout })
| `Udp _ -> Ok (`Udp, { fd; timeout= t.timeout })
let send_recv_tls ~timeout ~id fd str =
let send () = Tls_miou_unix.write fd str in
let recv () =
let rec go buf rx_len =
let expected_len =
if rx_len >= 2 then Some (Bytes.get_uint16_be buf 0) else None in
match expected_len with
| None ->
let len = Tls_miou_unix.read fd buf ~off:rx_len in
if rx_len + len >= 2 && len > 0 then go buf (rx_len + len)
else failwith "TLS connection closed by nameserver"
| Some expected_len when rx_len >= expected_len + 2 ->
let id' = Bytes.get_uint16_be buf 2 in
if id = id'
then Bytes.sub_string buf 0 (expected_len + 2)
else
let buf' = Bytes.make 2048 '\000' in
let rx_len' = rx_len - (expected_len + 2) in
Bytes.blit buf (expected_len + 2) buf' 0 rx_len';
go buf' rx_len'
| Some expected_len when Bytes.length buf >= expected_len + 2 ->
let len = (expected_len + 2) - rx_len in
Tls_miou_unix.really_read fd buf ~off:rx_len ~len;
go buf (rx_len + len)
| Some expected_len ->
(* NOTE(dinosaure): in this branch, [buf] is not large enough to store
the DNS packet. We allocate a new buffer which can store the actual
DNS packet and use it for the next [go] iteration. *)
let buf' = Bytes.make (expected_len + 2) '\000' in
Bytes.blit buf 0 buf' 0 rx_len;
go buf' rx_len in
go (Bytes.make 2048 '\000') 0 in
let ( >>= ) = Result.bind in
match with_timeout ~timeout send >>= fun () ->
with_timeout ~timeout recv with
| Ok _ as rx -> rx
| Error Timeout -> error_msgf "DNS request timeout"
| Error (Failure msg) -> Error (`Msg msg)
| Error (End_of_file | Tls_miou_unix.Closed_by_peer) ->
error_msgf "End of file reading from nameserver"
| Error exn ->
error_msgf "Got an unexpected exception: %s"
(Printexc.to_string exn)
let send_recv { fd; timeout } str =
if String.length str > 4 then begin
match fd with
| `Tls fd ->
let id = String.get_uint16_be str 2 in
send_recv_tls ~timeout ~id fd str
| `Udp fd | `Tcp fd ->
let fd = Miou_unix.to_file_descr fd in
Unix.clear_nonblock fd;
let send () =
Log.debug (fun m -> m "sending a dns packet to resolver");
Unix.setsockopt_float fd Unix.SO_SNDTIMEO timeout;
let len = Unix.send_substring fd str 0 (String.length str) [] in
if len <> String.length str
then failwith "Broken write to upstream nameserver" in
let recv () =
let buffer = Bytes.make 2048 '\000' in
Unix.setsockopt_float fd Unix.SO_RCVTIMEO timeout;
let len = Unix.recv fd buffer 0 (Bytes.length buffer) [] in
(* TODO(dinosaure): should we check rx_len and continue until we got
the full packet (only for tcp/ip)? *)
if len > 0 && len <= Bytes.length buffer
then Bytes.sub_string buffer 0 len
else failwith "Reading from nameserver socket failed" in
let ( >>= ) = Result.bind in
match with_timeout ~timeout send >>= fun () ->
with_timeout ~timeout recv with
| Ok _ as rx -> rx
| Error Timeout -> error_msgf "DNS request timeout"
| Error (Failure msg) -> Error (`Msg msg)
| Error exn ->
error_msgf "Got an unexpected exception: %s"
(Printexc.to_string exn)
end
else error_msgf "Invalid context (data length <= 4)"
let close { fd; _ } = match fd with
| `Tcp fd | `Udp fd -> Miou_unix.close fd
| `Tls fd -> Tls_miou_unix.close fd
let of_ns ns = Int64.to_float ns /. 1_000_000_000.
let create ?nameservers ~timeout happy =
let proto, nameservers =
match nameservers with
| None -> (`Udp, [ `Plaintext (Ipaddr.of_string_exn "8.8.8.8", 53) ])
| Some (a, nss) -> (a, nss)
in
{ nameservers; proto; timeout= of_ns timeout; happy }
end
include Dns_client.Make (Transport)

6
unikernel/duniverse/ocaml-dns/miou/client/dns_client_miou_unix.mli Normal file
View file

@ -0,0 +1,6 @@
module Transport : Dns_client.S
with type io_addr = [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ]
and type +'a io = 'a
and type stack = Happy_eyeballs_miou_unix.t
include module type of Dns_client.Make (Transport)

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

@ -0,0 +1,5 @@
(library
(name dns_client_miou_unix)
(modules dns_client_miou_unix)
(public_name dns-client-miou-unix)
(libraries dns-client tls-miou-unix happy-eyeballs-miou-unix))

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))

14
unikernel/duniverse/ocaml-dns/resolvconf/dns_resolvconf.ml Normal file
View file

@ -0,0 +1,14 @@
let parse buf =
try
Resolvconf_state.reset ();
let buf =
if String.(get buf (pred (length buf))) = '\n' then buf else buf ^ "\n"
in
let lexbuf = Lexing.from_string buf in
Ok (Resolvconf_parser.resolvconf Resolvconf_lexer.lex lexbuf)
with
| Parsing.Parse_error ->
Error (`Msg (Fmt.str "parse error at line %d" Resolvconf_state.(state.lineno)))
| exn ->
Error (`Msg (Fmt.str "error at line %d: %s" Resolvconf_state.(state.lineno)
(Printexc.to_string exn)))

1
unikernel/duniverse/ocaml-dns/resolvconf/dns_resolvconf.mli Normal file
View file

@ -0,0 +1 @@
val parse : string -> ([ `Nameserver of Ipaddr.t ] list, [> `Msg of string ]) result

9
unikernel/duniverse/ocaml-dns/resolvconf/dune Normal file
View file

@ -0,0 +1,9 @@
(library
(name dns_resolvconv)
(public_name dns-client.resolvconf)
(private_modules resolvconf_lexer resolvconf_parser resolvconf_state)
(libraries ipaddr fmt)
(wrapped false))
(ocamlyacc resolvconf_parser)
(ocamllex resolvconf_lexer)

30
unikernel/duniverse/ocaml-dns/resolvconf/resolvconf_lexer.mll Normal file
View file

@ -0,0 +1,30 @@
{
open Resolvconf_state
open Resolvconf_parser
}
let ipv4 = (['0'-'9']+ '.' ['0'-'9']+ '.' ['0'-'9']+ '.' ['0'-'9']+) as contents
let ipv6 = (['0'-'9' 'a'-'f' 'A'-'F' ':']+) as contents
let zone_id = (['0'-'9' 'a'-'z' 'A'-'Z' '.' ]+) as contents
(* inspired by https://github.com/tailhook/resolv-conf/blob/master/src/grammar.rs *)
rule lex = parse
| "nameserver" { SNAMESERVER }
| "options" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL }
| "search" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL }
| "domain" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL }
| "sortlist" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL }
| "lookup" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL }
| "family" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL }
| [' ' '\t']+ { SPACE }
| ipv4 { IPV4 contents }
| ipv6 { IPV6 contents }
| '.' { DOT }
| ':' { COLON }
| '%' { PERCENT }
| [' ' '\t']* ('#' [^'\n']*)? '\n' { state.lineno <- state.lineno + 1 ; EOL }
| [' ' '\t']* (';' [^'\n']*)? '\n' { state.lineno <- state.lineno + 1 ; EOL }
| zone_id { ZONE_ID contents }
| eof { EOF }

37
unikernel/duniverse/ocaml-dns/resolvconf/resolvconf_parser.mly Normal file
View file

@ -0,0 +1,37 @@
%{
%}
%token EOF
%token EOL
%token SPACE
%token SNAMESERVER
%token DOT
%token COLON
%token PERCENT
%token <string> IPV4
%token <string> IPV6
%token <string> ZONE_ID
%start resolvconf
%type <[ `Nameserver of Ipaddr.t ] list> resolvconf
%%
resolvconf: lines EOF { List.rev $1 }
lines:
/* nothing */ { [] }
| lines EOL { $1 }
| lines nameserver EOL { $2 :: $1 }
s: SPACE {} | s SPACE {}
ipv4: IPV4 { Ipaddr.V4.of_string_exn $1 }
ipv6:
IPV6 { Ipaddr.V6.of_string_exn $1 }
| IPV6 PERCENT ZONE_ID { Ipaddr.V6.of_string_exn $1 }
nameserver:
SNAMESERVER s ipv4 { `Nameserver (Ipaddr.V4 $3) }
| SNAMESERVER s ipv6 { `Nameserver (Ipaddr.V6 $3) }

11
unikernel/duniverse/ocaml-dns/resolvconf/resolvconf_state.ml Normal file
View file

@ -0,0 +1,11 @@
(* State variables for the parser & lexer *)
type parserstate = {
mutable lineno : int ;
}
let state = {
lineno = 1 ;
}
let reset () =
state.lineno <- 1

100
unikernel/duniverse/ocaml-dns/resolver/dns_block.ml Normal file
View file

@ -0,0 +1,100 @@
open Dns
let src = Logs.Src.create "dns_block" ~doc:"DNS block"
module Log = (val Logs.src_log src : Logs.LOG)
let nameserver =
let lh = Domain_name.of_string_exn "localhost"
and bl = Domain_name.of_string_exn "blocked"
in
fun ns -> Domain_name.equal ns lh || Domain_name.equal ns bl
let ipv4 =
let lh = Ipaddr.V4.(Set.singleton localhost)
and any = Ipaddr.V4.(Set.singleton any)
in
fun ipv4s -> Ipaddr.V4.Set.equal ipv4s lh || Ipaddr.V4.Set.equal ipv4s any
let ipv6 =
let lh = Ipaddr.V6.(Set.singleton localhost)
and un = Ipaddr.V6.(Set.singleton unspecified)
in
fun ipv6s -> Ipaddr.V6.Set.equal ipv6s lh || Ipaddr.V6.Set.equal ipv6s un
let likely reply =
(* HACK! We assume blocked domains have a certain shape. *)
let blocked_soa auth =
Domain_name.Map.cardinal auth > 0 &&
Domain_name.Map.for_all (fun _domain rr ->
match Rr_map.find Rr_map.Soa rr with
| None -> false
| Some soa -> nameserver soa.nameserver)
auth
in
match reply.Packet.data with
| `Answer (answ, _auth) ->
Domain_name.Map.for_all
(fun _domain rr ->
Rr_map.for_all
(function
| Rr_map.B (Rr_map.A, (_, ips)) -> ipv4 ips
| Rr_map.B (Rr_map.Aaaa, (_, ips)) -> ipv6 ips
| _ -> false)
rr)
answ
| `Rcode_error (Rcode.NXDomain, _, Some (_answ, auth)) -> blocked_soa auth
| _ -> false
let reason reply =
let find_soa_hostmaster rr =
match Rr_map.find Rr_map.Soa rr with
| None -> None
| Some soa ->
if nameserver soa.Soa.nameserver then
Some (Domain_name.to_string soa.Soa.hostmaster)
else
None
in
let find_soa_hostmaster_in_domain_map map =
Domain_name.Map.fold (fun _domain rr acc ->
match acc, find_soa_hostmaster rr with
| None, x -> x
| Some x, None -> Some x
| Some x, Some y ->
if not (String.equal x y) then
Log.info (fun m -> m "finding blocklist resulted in %S and %S, using the first" x y);
Some x) map None
in
let find_soa_hostmaster_in_reply answer authority =
match find_soa_hostmaster_in_domain_map answer, find_soa_hostmaster_in_domain_map authority with
| None, x -> x
| Some x, None -> Some x
| Some x, Some y ->
if not (String.equal x y) then
Log.info (fun m -> m "finding blocklist resulted in %S (answer) and %S (authority), using the first" x y);
Some x
in
let r =
match reply.Packet.data with
| `Answer (answ, auth) -> find_soa_hostmaster_in_reply answ auth
| `Rcode_error (Rcode.NXDomain, _, Some (answ, auth)) ->
find_soa_hostmaster_in_reply answ auth
| _ -> None
in
Option.map (fun reason -> "appears in blocklist " ^ reason) r
let edns reply =
if likely reply then
(* After guessing that a domain is blocked we add [`Filtered] extended error
code and emit a [`Blocked] metrics event. *)
let reason = reason reply in
match reply.edns with
| None ->
Some (Edns.create ~extended_error:(`Blocked, reason) ())
| Some ({ Edns.extensions = []; extended_rcode; version; dnssec_ok; payload_size }) ->
Some (Edns.create ~extended_error:(`Blocked, reason) ~extended_rcode ~version ~dnssec_ok ~payload_size ())
| Some edns ->
Log.warn (fun m -> m "don't know how to extend edns to add extended error; not doing anything:@ %a" Edns.pp edns);
Some edns
else
None

667
unikernel/duniverse/ocaml-dns/resolver/dns_resolver.ml Normal file
View file

@ -0,0 +1,667 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
type key = [ `raw ] Domain_name.t * Packet.Question.qtype
let pp_key = Dns_resolver_cache.pp_question
let src = Logs.Src.create "dns_resolver" ~doc:"DNS resolver"
module Log = (val Logs.src_log src : Logs.LOG)
(* The cache (a Map!?) for answers: once a specific type/name comes in, we know
which questions can progress now *)
module QM = Map.Make(struct
type t = key
let compare (n, t) (n', t') =
match Domain_name.compare n n' with
| 0 -> Packet.Question.compare_qtype t t'
| x -> x
end)
type awaiting = {
ts : int64;
retry : int;
proto : proto;
zone : [ `raw ] Domain_name.t;
edns : Edns.t option;
ip : Ipaddr.t;
port : int;
question : key;
id : int;
checking_disabled : bool;
dnssec_ok : bool;
}
let awaiting_eq a b =
Ipaddr.compare a.ip b.ip = 0 &&
Int.equal a.port b.port &&
Domain_name.equal (fst a.question) (fst b.question) &&
Packet.Question.compare_qtype (snd a.question) (snd b.question) = 0 &&
Int.equal a.id b.id
module TM = Map.Make(struct
type t = key * Ipaddr.t * int * int
let compare ((n, t), ip, port, id) ((n', t'), ip', port', id') =
let andThen v f = match v with 0 -> f () | x -> x in
andThen (Domain_name.compare n n')
(fun () -> andThen (Packet.Question.compare_qtype t t')
(fun () -> andThen (Ipaddr.compare ip ip')
(fun () -> andThen (Int.compare port port')
(fun () -> Int.compare id id'))))
end)
let retry_interval = Duration.of_ms 500
type feature =
[ `Dnssec | `Qname_minimisation | `Opportunistic_tls_authoritative ]
module FS = Set.Make(struct
type t = feature
let compare a b = match a, b with
| `Dnssec, `Dnssec -> 0 | `Dnssec, _ -> 1 | _, `Dnssec -> -1
| `Qname_minimisation, `Qname_minimisation -> 0
| `Qname_minimisation, _ -> 1
| _, `Qname_minimisation -> -1
| `Opportunistic_tls_authoritative, `Opportunistic_tls_authoritative -> 0
(* | `Opportunistic_tls_authoritative, _ -> 1
| _, `Opportunistic_tls_authoritative -> -1 *)
end)
type t = {
ip_protocol : [ `Both | `Ipv4_only | `Ipv6_only ];
features : FS.t ;
rng : int -> string ;
primary : Dns_server.Primary.s ;
cache : Dns_cache.t ;
transit : awaiting TM.t ;
queried : awaiting list QM.t ;
mutable clients : Ipaddr.Set.t ;
record_clients : bool ;
}
let create ?(record_clients = true) ?(cache_size = 10000) ?(ip_protocol = `Both) features now rng primary =
let cache = Dns_cache.empty cache_size in
let cache =
List.fold_left (fun cache (name, b) ->
Dns_cache.set cache now
name A Dns_cache.Additional
(`Entry b))
cache Dns_resolver_root.a_records
in
let cache =
List.fold_left (fun cache (name, b) ->
Dns_cache.set cache now
name Aaaa Dns_cache.Additional
(`Entry b))
cache Dns_resolver_root.aaaa_records
in
let cache =
Dns_cache.set cache now
Domain_name.root Ns Dns_cache.Additional
(`Entry Dns_resolver_root.ns_records)
in
let cache =
Dns_cache.set cache now
Domain_name.root Ds Dns_cache.Additional
(`Entry (Int32.max_int, Dnssec.root_ds))
in
let features = FS.of_list features in
{ ip_protocol ; features ; rng ; cache ; primary ; transit = TM.empty ; queried = QM.empty ;
clients = Ipaddr.Set.empty ; record_clients }
let features t = FS.elements t.features
let pick rng = function
| [] -> None
| [ x ] -> Some x
| xs -> Some (List.nth xs (Randomconv.int ~bound:(List.length xs) rng))
let build_query ?id ?(recursion_desired = false) ?(checking_disabled = false) ?(dnssec_ok = true) t ts proto question retry zone edns ip =
let id = match id with Some id -> id | None -> Randomconv.int16 t.rng in
let header =
let flags =
(* tell the NS we will do the checking.
See: https://www.rfc-editor.org/rfc/rfc4035#section-4.6 *)
let flags =
if FS.mem `Dnssec t.features then
Packet.Flags.singleton `Checking_disabled
else Packet.Flags.empty
in
if recursion_desired then
Packet.Flags.add `Recursion_desired flags
else
flags
in
id, flags
in
let el = { ts; retry; proto; zone; edns; ip; port = 53; question; id; checking_disabled; dnssec_ok } in
let key = question, ip, el.port, id in
let transit =
if TM.mem key t.transit then
Log.warn (fun m -> m "overwriting transit of %a" pp_key question) ;
TM.add key el t.transit
in
let packet = Packet.create ?edns header (question :> Packet.Question.t) `Query in
let cs, _ = Packet.encode proto packet in
{ t with transit }, cs
let query ?recursion_desired t ts await retry ip name typ =
let k = (name, typ) in
let await = { await with retry = succ await.retry } in
(* TODO here we may want to use the _default protocol_ (and edns settings) instead of `Udp *)
let payload_size = if FS.mem `Dnssec t.features then Some 1220 (* from RFC 4035 4.1 *) else None in
let edns = Some (Edns.create ~dnssec_ok:(FS.mem `Dnssec t.features) ?payload_size ()) in
let t, packet = build_query ?recursion_desired ~checking_disabled:await.checking_disabled ~dnssec_ok:await.dnssec_ok t ts `Udp k retry await.zone edns ip in
let queried =
let q = Option.value ~default:[] (QM.find_opt k t.queried) in
if List.exists (awaiting_eq await) q then q else await :: q
in
let t = { t with queried = QM.add k queried t.queried } in
Log.debug (fun m -> m "query: query %a %a" Ipaddr.pp ip pp_key k) ;
(packet, ip), t
let was_in_transit t key id sender sport =
let tm_key = key, sender, sport, id in
match TM.find tm_key t with
| exception Not_found ->
Log.warn (fun m -> m "key %a not present in set (likely retransmitted)"
pp_key key);
None, t
| awaiting ->
if Ipaddr.compare sender awaiting.ip = 0 && id = awaiting.id then
Some (awaiting.zone, awaiting.edns), TM.remove tm_key t
else
(Log.warn (fun m -> m "unsolicited reply for %a (id %04X vs o_id %04X, sender %a vs o_sender %a)"
pp_key key id awaiting.id Ipaddr.pp sender Ipaddr.pp awaiting.ip);
None, t)
let find_queries t k =
match QM.find k t with
| exception Not_found ->
Log.warn (fun m -> m "couldn't find entry %a in map" pp_key k) ;
t, []
| vals ->
QM.remove k t, vals
let handle_query ?(retry = 0) t ts awaiting =
if Int64.sub ts awaiting.ts > Int64.shift_left retry_interval 2 then begin
Log.warn (fun m -> m "dropping q %a from %a:%d (timed out)"
pp_key awaiting.question Ipaddr.pp awaiting.ip awaiting.port);
`Nothing, t
end else
let dnssec = FS.mem `Dnssec t.features && not awaiting.checking_disabled in
let qname_minimisation = FS.mem `Qname_minimisation t.features in
let r, cache = Dns_resolver_cache.handle_query t.cache ~qname_minimisation ~dnssec ~dnssec_ok:awaiting.dnssec_ok ~rng:t.rng t.ip_protocol ts awaiting.question in
let t = { t with cache } in
match r with
| `Queries _ when awaiting.retry >= 10 ->
Log.warn (fun m -> m "dropping q %a from %a:%d (already sent 10 packets)"
pp_key awaiting.question Ipaddr.pp awaiting.ip awaiting.port);
(* TODO reply with error! *)
`Nothing, t
| `Queries [] ->
Log.warn (fun m -> m "dropping q %a from %a:%d (queries is empty)"
pp_key awaiting.question Ipaddr.pp awaiting.ip awaiting.port);
`Nothing, t
| `Queries qs ->
let query_one (acc, t) (zone, (nam, types), ip) =
Log.debug (fun m -> m "have to query (zone %a) %a using ip %a"
Domain_name.pp zone
Fmt.(list ~sep:(any ", ") pp_key)
(List.map (fun t -> (nam, t)) types)
Ipaddr.pp ip);
let await = { awaiting with zone } in
List.fold_left (fun (acc, t) typ ->
let r, t = query t ts await retry ip nam typ in
r :: acc, t)
(acc, t) types
in
let r, t = List.fold_left query_one ([], t) qs in
`Query r, t
| `Reply (flags, answer, additional) ->
let time = Int64.sub ts awaiting.ts in
let max_size, edns = Edns.reply awaiting.edns in
let packet = Packet.create ?edns ?additional (awaiting.id, flags) (awaiting.question :> Packet.Question.t) (answer :> Packet.data) in
Log.debug (fun m -> m "answering %a after %a %d out packets: %a"
pp_key awaiting.question Duration.pp time awaiting.retry
Packet.pp packet) ;
Dns_resolver_metrics.response_metric time;
let cs, _ = Packet.encode ?max_size awaiting.proto packet in
let ttl = Packet.minimum_ttl (answer :> Packet.data) in
`Answer (ttl, cs), t
let scrub_it t proto zone edns ts ~signed qtype p =
match Dns_resolver_utils.scrub zone ~signed qtype p, edns with
| Ok xs, _ ->
let cache =
List.fold_left
(fun t (n, Dns_resolver_utils.E (ty, e), r) ->
(*Log.debug (fun m -> m "Dns_cache.set %a %a %a"
Rr_map.ppk (K ty) Domain_name.pp n (Dns_cache.pp_entry ty) e) ;*)
Dns_cache.set t ts n ty r e)
t xs
in
if Packet.Flags.mem `Truncation (snd p.header) && proto = `Udp then
(Log.warn (fun m -> m "NS truncated reply, using TCP now") ;
`Upgrade_to_tcp cache)
else
`Cache cache
| Error Rcode.FormErr, Some _ ->
Log.warn (fun m -> m "NS sent FormErr, retrying without edns!") ;
`Query_without_edns
| Error e, _ ->
Log.warn (fun m -> m "NS didn't like us %a" Rcode.pp e) ;
`Try_another_ns
let handle_primary t now ts proto sender sport packet _request buf =
(* makes only sense to ask primary for query=true since we'll never issue questions from primary *)
let handle_inner name =
let t, answer, _, _ = Dns_server.Primary.handle_packet t now ts proto sender sport packet name in
match answer with
| None -> `None (* TODO incoming ??? are never replied to - should be revised!? *)
| Some reply ->
(* delegation if authoritative is not set! *)
if Packet.Flags.mem `Authoritative (snd reply.header) then begin
Log.debug (fun m -> m "authoritative reply %a" Packet.pp reply) ;
let reply =
match Dns_block.edns reply with
| None -> reply
| Some edns ->
Dns_resolver_metrics.resolver_stats `Blocked;
Dns.Packet.with_edns reply (Some edns)
in
let r = Packet.encode proto reply in
let ttl = Packet.minimum_ttl reply.data in
`Reply (t, (reply, ttl, r))
end else match reply.data with
| `Answer data -> `Delegation (data, reply.additional)
| _ -> `None (* not authoritative, error!! *)
in
match Dns_server.(handle_tsig (Primary.server t) now packet buf) with
| Error (e, data) ->
Log.err (fun m -> m "tsig failed %a" Tsig_op.pp_e e);
begin match data with
| Some data -> `Reply (t, 0l, data)
| None -> `None
end
| Ok None ->
begin match handle_inner None with
| `Reply (t, (_, ttl, (out, _))) -> `Reply (t, ttl, out)
| `None -> `None
| `Delegation d -> `Delegation d
end
| Ok (Some (name, tsig, mac, key)) ->
match handle_inner (Some name) with
| `Reply (t, (reply, ttl, (buf, max_size))) ->
begin match Dns_server.((Primary.server t).tsig_sign) ~max_size ~mac name tsig ~key reply buf with
| None ->
Log.warn (fun m -> m "couldn't use %a to tsig sign, using unsigned reply" Domain_name.pp name) ;
`Reply (t, ttl, buf)
| Some (buf, _) -> `Reply (t, 0l, buf)
end
| `None -> `None
| `Delegation x -> `Delegation x
let handle_awaiting_queries ?retry t ts (name, typ) =
let queried, values = find_queries t.queried (name, typ) in
let t = { t with queried } in
List.fold_left (fun (t, out_a, out_q) awaiting ->
Log.debug (fun m -> m "now querying %a" pp_key awaiting.question) ;
match handle_query ?retry t ts awaiting with
| `Nothing, t -> t, out_a, out_q
| `Query pkts, t -> t, out_a, (List.map (fun (pkt, dst) -> (`Udp, dst, pkt)) pkts) @ out_q
| `Answer (ttl, pkt), t -> t, (awaiting.proto, awaiting.ip, awaiting.port, ttl, pkt) :: out_a, out_q)
(t, [], []) values
let resolve t ts proto sender sport req =
match req.Packet.data, Packet.Question.qtype req.Packet.question with
| `Query, Some q_type ->
Log.debug (fun m -> m "resolving %a" Packet.Question.pp req.question) ;
if not (Packet.Flags.mem `Recursion_desired (snd req.Packet.header)) then
Log.warn (fun m -> m "recursion not desired") ;
(* ask the cache *)
let checking_disabled = Packet.Flags.mem `Checking_disabled (snd req.header)
and dnssec_ok = match req.edns with None -> false | Some edns -> edns.Edns.dnssec_ok in
let awaiting = { ts; retry = 0; proto; zone = Domain_name.root ; edns = req.edns; ip = sender; port = sport; question = (fst req.question, q_type); id = fst req.header; checking_disabled; dnssec_ok } in
begin match handle_query t ts awaiting with
| `Answer (ttl, pkt), t ->
Log.debug (fun m -> m "answer %a" Packet.Question.pp req.question) ;
t, [ (proto, sender, sport, ttl, pkt) ], []
| `Nothing, t ->
Log.debug (fun m -> m "nothing %a" Packet.Question.pp req.question) ;
t, [], [] (* TODO: send a reply!? *)
| `Query pkts, t ->
Log.debug (fun m -> m "query %d %a" (List.length pkts) Packet.Question.pp req.question) ;
t, [], List.map (fun (packet, dst) -> `Udp, dst, packet) pkts
end
| _ ->
Log.err (fun m -> m "ignoring %a" Packet.pp req);
let pkt = Packet.create
(fst req.header, Packet.Flags.empty) req.question
(`Rcode_error (Rcode.NotImp, Packet.opcode_data req.data, None))
in
let buf, _ = Packet.encode proto pkt in
t, [ proto, sender, sport, 0l, buf ], []
let handle_reply t now ts proto sender sport packet reply =
match reply, Packet.Question.qtype packet.Packet.question with
| `Answer _, Some qtype
| `Rcode_error (Rcode.NXDomain, Opcode.Query, _), Some qtype
| `Rcode_error (Rcode.ServFail, Opcode.Query, _), Some qtype ->
begin
Log.debug (fun m -> m "handling reply to %a" Packet.Question.pp packet.question);
(* (a) first check whether frame was in transit! *)
let key = fst packet.question, qtype in
let r, transit = was_in_transit t.transit key (fst packet.header) sender sport in
let t = { t with transit } in
match r with
| None -> Ok (t, [], [])
| Some (zone, edns) ->
(* (b) DNSSec verification of RRs *)
let t, packet, signed =
if FS.mem `Dnssec t.features then
let t, dnskeys =
match qtype with
| `K K Rr_map.Dnskey ->
let cache, ds = Dns_cache.get t.cache ts zone Rr_map.Ds in
{ t with cache },
begin match ds with
| Ok (`Entry (_, ds_set), _) ->
let keys = match reply with
| `Answer (a, _) -> Name_rr_map.find zone Rr_map.Dnskey a
| _ -> None
in
let ds_set = Dnssec.filter_ds_if_sha2_present ds_set in
Option.map (fun (_, dnskeys) ->
Rr_map.Ds_set.fold (fun ds acc ->
match Dnssec.validate_ds zone dnskeys ds with
| Ok key -> Rr_map.Dnskey_set.add key acc
| Error `Msg msg ->
Log.debug (fun m -> m "couldn't validate DS (for %a): %s"
Domain_name.pp zone msg);
acc
| Error `Extended e ->
Log.debug (fun m -> m "couldn't validate DS (for %a): %a"
Domain_name.pp zone
Extended_error.pp e);
acc)
ds_set Rr_map.Dnskey_set.empty)
keys
| _ ->
Log.warn (fun m -> m "no DS in cache for %a" Domain_name.pp zone);
None
end
| _ ->
let cache, dnskeys = Dns_cache.get t.cache ts zone Rr_map.Dnskey in
{ t with cache },
match dnskeys with
| Ok (`Entry (_, dnskey_set), _) -> Some dnskey_set
| _ ->
Log.warn (fun m -> m "no DNSKEYS in cache for %a" Domain_name.pp zone);
None
in
let packet, signed =
match dnskeys with
| None ->
Log.warn (fun m -> m "no DNSKEY present, couldn't validate packet");
packet, false
| Some dnskeys ->
match Dnssec.verify_packet now dnskeys packet with
| Ok packet -> packet, true
| Error `Msg msg ->
Log.err (fun m -> m "error %s verifying reply %a"
msg Packet.pp_reply reply);
packet, false
in
t, packet, signed
else
t, packet, false
in
(* (c) now we scrub and either *)
match scrub_it t.cache proto zone edns ts ~signed qtype packet with
| `Query_without_edns ->
let t, cs = build_query t ts proto key 1 zone None sender in
Log.debug (fun m -> m "resolve: requery without edns %a %a"
Ipaddr.pp sender pp_key key) ;
Ok (t, [], [ `Udp, sender, cs ])
| `Upgrade_to_tcp cache ->
(* RFC 2181 Sec 9: correct would be to drop entire frame, and retry with tcp *)
(* but we're happy to retrieve the partial information, it may be useful *)
let t = { t with cache } in
(* this may provoke the very same question again -
but since tcp is first, that should trigger the TCP connection,
which is then reused... ok, we may send the same query twice
with different ids *)
(* TODO we may want to get rid of the handle_awaiting_queries
entirely here!? *)
let (t, out_a, out_q), recursion_desired =
handle_awaiting_queries t ts key, false
in
let edns = Some (Edns.create ~dnssec_ok:(FS.mem `Dnssec t.features) ()) in
let t, cs = build_query ~recursion_desired t ts `Tcp key 1 zone edns sender in
Log.debug (fun m -> m "resolve: upgrade to tcp %a %a"
Ipaddr.pp sender pp_key key) ;
Ok (t, out_a, (`Tcp, sender, cs) :: out_q)
| `Try_another_ns ->
(* is this the right behaviour? by luck we'll use another path *)
Ok (handle_awaiting_queries t ts key)
| `Cache cache ->
let t = { t with cache } in
Ok (handle_awaiting_queries t ts key)
end
| v, _ ->
Log.err (fun m -> m "ignoring reply %a" Packet.pp_reply v);
Error ()
let handle_delegation t ts proto sender sport req (delegation, add_data) =
Log.debug (fun m -> m "handling delegation %a (for %a)" Packet.Answer.pp delegation Packet.pp req) ;
match req.Packet.data, Packet.Question.qtype req.question with
| `Query, Some qtype ->
let dnssec = FS.mem `Dnssec t.features && not (Packet.Flags.mem `Checking_disabled (snd req.header))
and dnssec_ok = match req.edns with None -> false | Some edns -> edns.Edns.dnssec_ok
in
let r, cache = Dns_resolver_cache.answer ~dnssec ~dnssec_ok t.cache ts (fst req.question) qtype in
let t = { t with cache } in
begin match r with
| `Query name ->
(* we should look into delegation for the actual delegation name,
but instead we're looking for any glue (A) in additional *)
let ips =
let ip4s, ip6s =
Domain_name.Map.fold (fun _ rrmap (ip4s, ip6s) ->
(match Rr_map.(find A rrmap) with
| None -> ip4s
| Some (_, ip4s') -> Ipaddr.V4.Set.union ip4s ip4s'),
(match Rr_map.(find Aaaa rrmap) with
| None -> ip6s
| Some (_, ip6s') -> Ipaddr.V6.Set.union ip6s ip6s'))
add_data (Ipaddr.V4.Set.empty, Ipaddr.V6.Set.empty)
in
let ip4s = List.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.Set.elements ip4s)
and ip6s = List.map (fun ip -> Ipaddr.V6 ip) (Ipaddr.V6.Set.elements ip6s)
in
match t.ip_protocol with
| `Both -> ip4s @ ip6s
| `Ipv4_only -> ip4s
| `Ipv6_only -> ip6s
in
begin match pick t.rng ips with
| None ->
Log.err (fun m -> m "something is wrong, delegation but no IP");
t, [], []
| Some ip ->
Log.debug (fun m -> m "found ip %a, maybe querying %a"
Ipaddr.pp ip pp_key (name, qtype)) ;
(* TODO is Domain_name.root correct here? *)
let checking_disabled = Packet.Flags.mem `Checking_disabled (snd req.header)
and dnssec_ok = match req.edns with None -> false | Some edns -> edns.Edns.dnssec_ok
in
let await = { ts; retry = 0; proto; zone = Domain_name.root; edns = req.edns; ip = sender; port = sport; question = (fst req.question, qtype); id = fst req.header; checking_disabled; dnssec_ok } in
let (cs, ip), t = query ~recursion_desired:true t ts await 0 ip name qtype in
t, [], [ `Udp, ip, cs ]
end
| `Packet (flags, reply, additional) ->
let max_size, edns = Edns.reply req.edns in
Log.debug (fun m -> m "delegation reply for %a from cache: %a"
Packet.pp req Packet.pp_reply reply) ;
let packet = Packet.create ?edns ?additional (fst req.header, flags) req.question (reply :> Packet.data) in
let ttl = Packet.minimum_ttl (reply :> Packet.data) in
let pkt, _ = Packet.encode ?max_size proto packet in
Dns_resolver_metrics.response_metric 0L;
t, [ proto, sender, sport, ttl, pkt ], []
(* send it out! we've a cache hit here! *)
end
| _ ->
Log.err (fun m -> m "ignoring %a" Packet.pp req) ;
let pkt =
Packet.create (fst req.header, Packet.Flags.empty)
req.question (`Rcode_error (Rcode.NotImp, Packet.opcode_data req.data, None))
in
t, [ proto, sender, sport, 0l, fst (Packet.encode proto pkt) ], []
let handle_buf t now ts query_allowed proto sender sport buf =
match Packet.decode buf with
(* | Error (`Bad_edns_version v) ->
Log.err (fun m -> m "bad edns version (from %a:%d) %u for@.%a"
Ipaddr.pp sender sport
v Cstruct.hexdump_pp buf) ;
t, handle_error ~error:Dns_enum.BadVersOrSig proto sender sport buf, [] *)
| Error e ->
Dns_resolver_metrics.resolver_stats `Error;
Log.err (fun m -> m "decode error (from %a:%d) %a for@.%a"
Ipaddr.pp sender sport
Packet.pp_err e Ohex.pp buf) ;
let answer = match Packet.raw_error buf Rcode.FormErr with
| None -> []
| Some data -> [ proto, sender, sport, 0l, data ]
in
t, answer, []
| Ok res ->
Log.debug (fun m -> m "reacting to packet from %a:%d"
Ipaddr.pp sender sport) ;
match res.Packet.data with
| #Packet.reply as reply ->
begin
match handle_reply t now ts proto sender sport res reply with
| Ok a ->
Log.debug (fun m -> m "handled reply %a:%d"
Ipaddr.pp sender sport) ;
a
| Error () -> t, [], []
end
| #Packet.request as req when query_allowed ->
Dns_resolver_metrics.resolver_stats `Queries;
if t.record_clients then
if not (Ipaddr.Set.mem sender t.clients) then begin
t.clients <- Ipaddr.Set.add sender t.clients;
Dns_resolver_metrics.resolver_stats `Clients
end;
begin
match handle_primary t.primary now ts proto sender sport res req buf with
| `Reply (primary, ttl, pkt) ->
Dns_resolver_metrics.response_metric 0L;
Log.debug (fun m -> m "handled primary %a:%d" Ipaddr.pp sender sport) ;
{ t with primary }, [ proto, sender, sport, ttl, pkt ], []
| `Delegation dele ->
Log.debug (fun m -> m "handled delegation %a:%d" Ipaddr.pp sender sport) ;
handle_delegation t ts proto sender sport res dele
| `None ->
Log.debug (fun m -> m "resolving %a:%d" Ipaddr.pp sender sport) ;
(* DNSSEC request DS / DNSKEY / NS from auth *)
resolve t ts proto sender sport res
end
| _ ->
Log.err (fun m -> m "ignoring unsolicited packet (query allowed? %b) %a" query_allowed Packet.pp res);
t, [], []
let query_root t now proto =
let root_ip () =
match pick t.rng (Dns_resolver_root.ips t.ip_protocol) with
| None -> assert false
| Some x -> x
in
let ip =
match Dns_cache.get t.cache now Domain_name.root Ns with
| _, Ok (`Entry (_, names), _) ->
let ip4s, ip6s =
Domain_name.Host_set.fold (fun name (v4s, v6s) ->
(match snd (Dns_cache.get t.cache now (Domain_name.raw name) A) with
| Ok (`Entry (_, ips), _) -> Ipaddr.V4.Set.union ips v4s
| _ -> v4s),
(match snd (Dns_cache.get t.cache now (Domain_name.raw name) Aaaa) with
| Ok (`Entry (_, ips), _) -> Ipaddr.V6.Set.union ips v6s
| _ -> v6s))
names (Ipaddr.V4.Set.empty, Ipaddr.V6.Set.empty)
in
let ip4s = List.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.Set.elements ip4s)
and ip6s = List.map (fun ip -> Ipaddr.V6 ip) (Ipaddr.V6.Set.elements ip6s)
in
let ips = match t.ip_protocol with
| `Both -> ip4s @ ip6s
| `Ipv4_only -> ip4s
| `Ipv6_only -> ip6s
in
begin match pick t.rng ips with
| Some ip -> ip
| None -> root_ip ()
end
| _ -> root_ip ()
in
let question = Domain_name.root, `K (Rr_map.K Ns)
and id = Randomconv.int16 t.rng
and edns = Some (Edns.create ())
and checking_disabled = false
and dnssec_ok = true
in
let el =
{ ts = now; retry = 0; proto; zone = Domain_name.root; edns; ip; port = 53; question; id; checking_disabled; dnssec_ok }
in
let key = question, ip, el.port, id in
let t = { t with transit = TM.add key el t.transit } in
let packet = Packet.create ?edns (id, Packet.Flags.empty) question `Query in
let cs, _ = Packet.encode proto packet in
t, (proto, ip, cs)
let max_retries = 5
let err_retries t question =
let t, reqs = find_queries t question in
t, List.fold_left (fun acc awaiting ->
Log.debug (fun m -> m "now erroring to %a" pp_key awaiting.question) ;
let packet = Packet.create (awaiting.id, Packet.Flags.empty)
(awaiting.question :> Packet.Question.t)
(`Rcode_error (Rcode.ServFail, Opcode.Query, None))
in
let buf, _ = Packet.encode awaiting.proto packet in
(awaiting.proto, awaiting.ip, awaiting.port, 0l, buf) :: acc)
[] reqs
let timer t ts =
let transit, rem =
TM.partition
(fun _ awaiting -> Int64.sub ts awaiting.ts < retry_interval)
t.transit
in
let t = { t with transit } in
if not (TM.is_empty transit && TM.is_empty rem) then
Log.debug (fun m -> m "try_other timer wheel -- keeping %d, running over %d"
(TM.cardinal transit) (TM.cardinal rem)) ;
TM.fold (fun ((name, typ), _ip, _port, _id) awaiting (t, out_a, out_q) ->
let retry = succ awaiting.retry in
if retry < max_retries then begin
let t, outa, outq = handle_awaiting_queries ~retry t ts (name, typ) in
(t, outa @ out_a, outq @ out_q)
end else begin
Log.info (fun m -> m "retry limit exceeded for %a at %a!"
pp_key (name, typ) Ipaddr.pp awaiting.ip) ;
let queried, out_as = err_retries t.queried (name, typ) in
({ t with queried }, out_as @ out_a, out_q)
end)
rem (t, [], [])
let primary_data t = Dns_server.Primary.data t.primary
let with_primary_data t now ts data =
let primary, outs = Dns_server.Primary.with_data t.primary now ts data in
{ t with primary }, outs

56
unikernel/duniverse/ocaml-dns/resolver/dns_resolver.mli Normal file
View file

@ -0,0 +1,56 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
type t
(** The type of a DNS resolver. *)
type feature =
[ `Dnssec | `Qname_minimisation | `Opportunistic_tls_authoritative ]
val create : ?record_clients:bool -> ?cache_size:int ->
?ip_protocol:[ `Both | `Ipv4_only | `Ipv6_only ] ->
feature list ->
int64 -> (int -> string) -> Dns_server.Primary.s -> t
(** [create ~record_clients ~cache_size ~ip_protocol features now rng primary]
creates the value of a resolver, pre-filled with root NS and their IP
addresses. If [ip_protocol] is provided, and set to [`V4_only], only IPv4
packets will be emitted. If [`V6_only] is set, only IPv6 packets will be
emitted. If [`Both] (the default), either IPv4 and IPv6 packets are
emitted. If [record_clients] is true (the default), the metrics of
the resolver will include the amount of clients. This keeps a set of
Ipaddr.t of all clients around, which may use some memory if it is a public
resolver.
Some features can be specified, whether DNSSec validation should be done,
whether query name minimisation should be done, and whether opportunistic
encryption using TLS to the authoritative should be done.
*)
val features : t -> feature list
val handle_buf : t -> Ptime.t -> int64 -> bool -> Dns.proto -> Ipaddr.t ->
int -> string ->
t * (Dns.proto * Ipaddr.t * int * int32 * string) list
* (Dns.proto * Ipaddr.t * string) list
(** [handle_buf t now ts query_or_reply proto sender source-port buf] handles
resolution of [buf], which leads to a new [t], a list of answers to be
transmitted (quintuple of protocol, ip address, port, minimum ttl, buffer),
and a list of queries (triple of protocol, ip address, buffer). *)
val query_root : t -> int64 -> Dns.proto ->
t * (Dns.proto * Ipaddr.t * string)
(** [query_root t now proto] potentially requests an update of the root
zone. Best invoked by a regular timer. *)
val timer : t -> int64 ->
t * (Dns.proto * Ipaddr.t * int * int32 * string) list
* (Dns.proto * Ipaddr.t * string) list
(** [timer t now] potentially retransmits DNS requests and/or sends NXDomain
answers. *)
val primary_data : t -> Dns_trie.t
(** [primary_data t] is the DNS trie of the primary. *)
val with_primary_data : t -> Ptime.t -> int64 -> Dns_trie.t -> t * (Ipaddr.t * string list) list
(** [with_primary_data t now ts data] is a pair [(t', outs)] where [t'] is [t]
updated with the [data] DNS trie, and [outs] is the data to send out (if
any). *)

496
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_cache.ml Normal file
View file

@ -0,0 +1,496 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
module N = Domain_name.Set
let src = Logs.Src.create "dns_resolver_cache" ~doc:"DNS resolver cache"
module Log = (val Logs.src_log src : Logs.LOG)
let _pp_err ppf = function
| `Cache_miss -> Fmt.string ppf "cache miss"
| `Cache_drop -> Fmt.string ppf "cache drop"
let pp_question ppf (name, typ) =
Fmt.pf ppf "%a (%a)" Domain_name.pp name Packet.Question.pp_qtype typ
let is_signed = function
| Dns_cache.AuthoritativeAnswer signed
| AuthoritativeAuthority signed -> signed
| _ -> None
let find_nsec t ts typ name =
let rec up name =
match snd (Dns_cache.get t ts name Nsec) with
| Ok (`Entry (ttl, nsec), rank) ->
if Bit_map.mem (Rr_map.to_int typ) nsec.Nsec.types then
Some (name, (ttl, nsec), rank)
else
None
| _ ->
if Domain_name.count_labels name >= 1 then
up (Domain_name.drop_label_exn name)
else
None
in
up name
let nsec_no t ts typ name =
match find_nsec t ts typ name with
| Some _ -> true
| None -> false
let find_nsec3 t ts typ name =
let rec up name =
match snd (Dns_cache.get_nsec3 t ts name) with
| Ok nsec3 ->
let (_, _, Nsec3.{ iterations ; salt ; _ }, _) = List.hd nsec3 in
let soa_name = Domain_name.drop_label_exn name in
let hashed_name = Dnssec.nsec3_hashed_name salt iterations ~soa_name name in
List.find_opt (fun (name, _, nsec3, _) ->
let name = Domain_name.drop_label_exn ~rev:true name in
let hashed_next_owner =
Domain_name.prepend_label_exn soa_name
(Base32.encode nsec3.Nsec3.next_owner_hashed)
in
(* TODO non-wc-expanded nsec3 only?? *)
(Domain_name.compare name hashed_name < 0 &&
Domain_name.compare hashed_name hashed_next_owner < 0) ||
(* TODO wc nsec3 as well? *)
(Domain_name.compare name hashed_name = 0 &&
not (Bit_map.mem (Rr_map.to_int typ) nsec3.types))
)
nsec3
| Error _ ->
if Domain_name.count_labels name > 1 then
up (Domain_name.drop_label_exn name)
else
None
in
up name
let nsec3_covering t ts typ name =
match find_nsec3 t ts typ name with
| None -> false
| Some _ -> true
let upwards_ds_nonexisting t ts name =
let rec go name =
if nsec_no t ts Ds name || nsec3_covering t ts Ds name then
true
else
match Domain_name.drop_label name with
| Error _ -> false
| Ok name -> go name
in
go name
let find_nearest_ns ip_proto dnssec ts t name =
let find_ns name = match snd (Dns_cache.get t ts name Ns) with
| Ok (`Entry (_, names), r) -> Domain_name.Host_set.elements names, is_signed r
| _ -> [], None
and find_dnskey name = match snd (Dns_cache.get t ts name Dnskey) with
| Ok _ -> true
| _ -> false
and dnskey_nonexisting name = match snd (Dns_cache.get t ts name Dnskey) with
| Ok _ -> false
| Error _ ->
(* no need to check for Ds nonexistance upwards, since we're only called
if we have a Ds *)
nsec_no t ts Dnskey name || nsec3_covering t ts Dnskey name
and need_to_query_for_ds name = match snd (Dns_cache.get t ts name Ds) with
| Ok _ -> false
| Error _ -> not (upwards_ds_nonexisting t ts name)
and have_ds name =
match snd (Dns_cache.get t ts name Ds) with
| Ok (`Entry _, _) -> true
| _ -> false
and find_address name =
let ip4s =
Result.fold
~ok:(function
| `Entry (_, ips), _ ->
List.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.Set.elements ips)
| _ -> [])
~error:(fun _ -> [])
(snd (Dns_cache.get t ts name A))
and ip6s =
Result.fold
~ok:(function
| `Entry (_, ips), _ ->
List.map (fun ip -> Ipaddr.V6 ip) (Ipaddr.V6.Set.elements ips)
| _ -> [])
~error:(fun _ -> [])
(snd (Dns_cache.get t ts name Aaaa))
in
match ip_proto with
| `Both -> ip4s @ ip6s
| `Ipv4_only -> ip4s
| `Ipv6_only -> ip6s
in
let have_ips_or_dnskey name ips =
if dnssec && not (find_dnskey name) && have_ds name then
if dnskey_nonexisting name then (
(* this is tricky, and likely bad - we have a DS but no DNSKEY *)
Log.warn (fun m -> m "DS present for %a, but nonexisting DNSKEY (NSEC/NSEC3)"
Domain_name.pp name);
`HaveIPs (name, ips))
else
(* if dnssec is enabled, and have a DS record, and we don't have a dnskey,
request it -- avoiding loops by only asking for dnskey if there's DS *)
`NeedDnskey (name, ips)
else
`HaveIPs (name, ips)
in
let rec go nam =
(* Log.info (fun m -> m "go %a" Domain_name.pp nam); *)
let ns, signed_ns = find_ns nam in
match ns with
| [] ->
(* Log.warn (fun m -> m "go no NS for %a" Domain_name.pp nam); *)
if Domain_name.(equal root nam) then
[ have_ips_or_dnskey nam (Dns_resolver_root.ips ip_proto) ]
else
go (Domain_name.drop_label_exn nam)
| _ when dnssec && need_to_query_for_ds nam ->
(* dnssec enabled, and no DS (and no nonexistance proof for DS) ->
query for DS (which is always provided by the domain above:
"." has it for ".coop" / ".com" for "example/com"
-> this also avoids loops, if we get a negative reply for DS, we move
on (and run into the case below)
*)
(* Log.info (fun m -> m "need to query for DS %a" Domain_name.pp nam); *)
List.map (function
| `HaveIPs (_name, ips) -> `NeedDs (nam, ips)
| `NeedDnskey _ | `NeedAddress _ | `NeedDs _
| `NeedSignedNs _ as r -> r)
(if Domain_name.(equal root nam) then
[ have_ips_or_dnskey name (Dns_resolver_root.ips ip_proto) ]
else
go (Domain_name.drop_label_exn nam))
| name_servers ->
List.fold_left (fun acc ns ->
let host = Domain_name.raw ns in
match find_address host with
| [] ->
(* Log.info (fun m -> m "go no address for NS %a (for %a)"
Domain_name.pp host
Domain_name.pp nam); *)
if Domain_name.is_subdomain ~subdomain:ns ~domain:nam then
(* we actually need glue *)
if Domain_name.(equal root nam) then
have_ips_or_dnskey nam (Dns_resolver_root.ips ip_proto) :: acc
else
(go (Domain_name.drop_label_exn nam)) @ acc
else
`NeedAddress (nam, host) :: acc
| ips ->
(* Log.info (fun m -> m "go address for NS %a (for %a): %a (dnssec %B signed_ns %B have_ds %B find_dnskey %B)"
Domain_name.pp host
Domain_name.pp nam
Ipaddr.pp ip
dnssec (Option.is_some signed_ns) (have_ds nam)
(find_dnskey nam)); *)
if dnssec && Option.is_none signed_ns && have_ds nam then
if find_dnskey nam then
`NeedSignedNs (nam, ips) :: acc
else if dnskey_nonexisting nam then (
(* Log.warn (fun m -> m "DS present for %a, but NSEC/NSEC3 for DNSKEY"
Domain_name.pp nam); *)
have_ips_or_dnskey nam ips :: acc)
else
`NeedDnskey (nam, ips) :: acc
else
have_ips_or_dnskey nam ips :: acc)
[] name_servers
in
go name
let resolve t ~qname_minimisation ~dnssec ip_proto ts name typ =
(* the standard recursive algorithm *)
let addresses = match ip_proto with
| `Both -> [`K (Rr_map.K A); `K (Rr_map.K Aaaa)]
| `Ipv4_only -> [`K (Rr_map.K A)]
| `Ipv6_only -> [`K (Rr_map.K Aaaa)]
in
(* with DNSSec:
- input is qname and qtyp
- (a) we have (validated) NS record (+DNSKEY) for zone -> move along
- (b) we miss a NS entry -> drop label and find one
---> we also want to collect DS and DNSKEY entries (or non-existence of DS)
---> we get DS by dnssec ok in EDNS
---> we may have unsigned NS (+ glue), and need to ask the NS for NS (+dnssec)
---> we may have unsigned glue, and need to go down for signed A/AAAA
*)
let rec go t visited types zone name =
Log.debug (fun m -> m "go %a (zone %a)" Domain_name.pp name Domain_name.pp zone) ;
let t =
if N.mem zone visited then
(* we need to break the cycle if there's one domain pointing to NS in
another domain, and this other domain NS pointing to one domain. *)
(* if we lack glue here, we should query .. for NS again with the hope
to get some glue *)
Dns_cache.remove t zone
else
t
in
List.concat_map (function
| `NeedAddress (zone, ns) -> go t (N.add zone visited) addresses zone ns
| `NeedDnskey (zone, ips) -> [ zone, zone, [`K (Rr_map.K Dnskey)], ips, t ]
| `NeedDs (zone, ips) -> [ zone, zone, [`K (Rr_map.K Ds)], ips, t ]
| `HaveIPs (zone, ips) ->
(* qname minimisation: if we can, query minimal qname (and NS)
this is possible as long as we haven't received a negative reply on
the NS query -- that's why we have another Dns_cache.get NS below *)
let name, types =
if qname_minimisation then
let n = Domain_name.count_labels name
and z = Domain_name.count_labels zone
in
let n' =
if succ z < n then
Domain_name.drop_label_exn ~amount:(n - succ z) name
else
name
in
let name' =
match snd (Dns_cache.get t ts n' Ns) with
| Ok (`Entry _, _) -> n'
| _ -> name
in
name', if Domain_name.equal name' name then types else [ `K (Rr_map.K Ns) ]
else
name, types
in
[ zone, name, types, ips, t ]
| `NeedSignedNs (domain, ips) -> [ domain, domain, [ `K (Rr_map.K Ns) ], ips, t ])
(find_nearest_ns ip_proto dnssec ts t (Domain_name.raw name))
in
go t N.empty [typ] Domain_name.root name
let to_map (name, soa) = Name_rr_map.singleton name Soa soa
let follow_cname t ts typ ~name ttl ~alias =
let rec follow t acc name =
let t, r = Dns_cache.get_or_cname t ts name typ in
match r with
| Error _ ->
Log.debug (fun m -> m "follow_cname: cache miss, need to query %a"
Domain_name.pp name);
`Query name, t
| Ok (`Alias (_, alias), r) ->
let acc' = Domain_name.Map.add name (Rr_map.singleton Cname (ttl, alias)) acc in
if Domain_name.Map.mem alias acc then begin
Log.warn (fun m -> m "follow_cname: cycle detected") ;
`Out (Rcode.NoError, is_signed r, acc', Name_rr_map.empty), t
end else begin
Log.debug (fun m -> m "follow_cname: alias to %a, follow again"
Domain_name.pp alias);
follow t acc' alias
end
| Ok (`Entry v, r) ->
let acc' = Domain_name.Map.add name Rr_map.(singleton typ v) acc in
Log.debug (fun m -> m "follow_cname: entry found, returning");
`Out (Rcode.NoError, is_signed r, acc', Name_rr_map.empty), t
| Ok (`No_domain res, r) ->
Log.debug (fun m -> m "follow_cname: nodom");
`Out (Rcode.NXDomain, is_signed r, acc, to_map res), t
| Ok (`No_data res, r) ->
Log.debug (fun m -> m "follow_cname: nodata");
`Out (Rcode.NoError, is_signed r, acc, to_map res), t
| Ok (`Serv_fail res, r) ->
Log.debug (fun m -> m "follow_cname: servfail") ;
`Out (Rcode.ServFail, is_signed r, acc, to_map res), t
in
let initial = Name_rr_map.singleton name Cname (ttl, alias) in
follow t initial alias
let signed_or_nonexisting ~dnssec t ts ty name r =
if dnssec then
Option.is_some (is_signed r) || nsec_no t ts ty name || nsec3_covering t ts ty name ||
upwards_ds_nonexisting t ts name
else
true
let ttl k = function
| Ok (`Entry v, _) -> Rr_map.ttl k v
| Ok ((`No_data (_, soa), _) | (`No_domain (_, soa), _) | (`Serv_fail (_, soa), _)) ->
soa.Soa.minimum
| Ok (`Alias (ttl, _), _) -> ttl
| Error _ -> 0l
let answer ~dnssec ~dnssec_ok t ts name (typ : Packet.Question.qtype) =
let packet _t _add ty rcode ~ttl ~rrsig answer authority =
let answer =
if dnssec_ok then
if Domain_name.Map.cardinal answer > 0 then
match rrsig with
| Some rrsig -> Name_rr_map.add name Rrsig (ttl, Rr_map.Rrsig_set.singleton rrsig) answer
| None -> answer
else
answer
else
answer
in
let authority =
if dnssec_ok then
if Domain_name.Map.cardinal authority = 1 then
let name, rr_map = Domain_name.Map.choose authority in
match Rr_map.find Soa rr_map with
| None -> authority
| Some _soa ->
let authority =
match rrsig with
| None -> authority
| Some rrsig ->
Name_rr_map.add name Rrsig (ttl, Rr_map.Rrsig_set.singleton rrsig) authority
in
match ty with
| None -> authority
| Some ty ->
match find_nsec t ts ty name, find_nsec3 t ts ty name with
| Some (name, (ttl, nsec), rank), _ ->
let authority = Name_rr_map.add name Nsec (ttl, nsec) authority in
(match is_signed rank with
| Some rrsig -> Name_rr_map.add name Rrsig (ttl, Rr_map.Rrsig_set.singleton rrsig) authority
| None -> authority)
| _, Some (name, ttl, nsec3, rank) ->
let authority = Name_rr_map.add name Nsec3 (ttl, nsec3) authority in
(match is_signed rank with
| Some rrsig -> Name_rr_map.add name Rrsig (ttl, Rr_map.Rrsig_set.singleton rrsig) authority
| None -> authority)
| None, _ -> authority
else
authority
else
authority
in
let data = (answer, authority) in
let flags =
let f = Packet.Flags.(add `Recursion_available (singleton `Recursion_desired)) in
if dnssec && match rrsig with Some _ -> true | None -> false then
Packet.Flags.add `Authentic_data f
else
f
(* XXX: we should look for a fixpoint here ;) *)
(* and additional, t = if add then additionals t ts answer else [], t *)
and data = match rcode with
| Rcode.NoError -> `Answer data
| x ->
let data = if Packet.Answer.is_empty data then None else Some data in
`Rcode_error (x, Opcode.Query, data)
in
flags, data, None
in
match typ with
| `Any ->
let t, r = Dns_cache.get_any t ts name in
let ttl = match r with
| Ok (`No_domain (_, soa), _) -> soa.Soa.minimum
| Ok (`Entries _rrs, _) -> 0l
| Error _ -> 0l
in
begin match r with
| Error _e ->
(* Log.warn (fun m -> m "error %a while looking up %a, query"
pp_err e pp_question (name, typ)); *)
`Query name, t
| Ok (`No_domain res, r) ->
Log.debug (fun m -> m "no domain while looking up %a, query" pp_question (name, typ));
`Packet (packet t false None Rcode.NXDomain ~ttl ~rrsig:(is_signed r) Domain_name.Map.empty (to_map res)), t
| Ok (`Entries rr_map, r) ->
Log.debug (fun m -> m "entries while looking up %a" pp_question (name, typ));
let data = Domain_name.Map.singleton name rr_map in
`Packet (packet t true None Rcode.NoError ~ttl ~rrsig:(is_signed r) data Domain_name.Map.empty), t
end
| `K (Rr_map.K ty) ->
let t, r = Dns_cache.get_or_cname t ts name ty in
let ttl = ttl ty r in
match r with
| Error _e ->
(* Log.warn (fun m -> m "error %a while looking up %a, query"
_pp_err _e pp_question (name, typ)); *)
`Query name, t
| Ok (`No_domain res, r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else (
Log.debug (fun m -> m "no domain while looking up %a" pp_question (name, typ));
`Packet (packet t false (Some ty) Rcode.NXDomain ~ttl ~rrsig:(is_signed r) Domain_name.Map.empty (to_map res)), t)
| Ok (`No_data res, r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else (
Log.debug (fun m -> m "no data while looking up %a" pp_question (name, typ));
`Packet (packet t false (Some ty) Rcode.NoError ~ttl ~rrsig:(is_signed r) Domain_name.Map.empty (to_map res)), t)
| Ok (`Serv_fail res, r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else (
Log.debug (fun m -> m "serv fail while looking up %a" pp_question (name, typ));
`Packet (packet t false (Some ty) Rcode.ServFail ~ttl ~rrsig:None Domain_name.Map.empty (to_map res)), t)
| Ok (`Alias (ttl, alias), r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else
begin
Log.debug (fun m -> m "alias while looking up %a" pp_question (name, typ));
match ty with
| Cname ->
let data = Name_rr_map.singleton name Cname (ttl, alias) in
`Packet (packet t false (Some ty) Rcode.NoError ~ttl ~rrsig:(is_signed r) data Domain_name.Map.empty), t
| ty ->
match follow_cname t ts ty ~name ttl ~alias with
| `Out (rcode, rrsig, an, au), t -> `Packet (packet t true (Some ty) rcode ~ttl ~rrsig an au), t
| `Query n, t -> `Query n, t
end
| Ok (`Entry v, r) ->
if not (signed_or_nonexisting ~dnssec t ts ty name r) then `Query name, t else
(Log.debug (fun m -> m "entry while looking up %a" pp_question (name, typ));
let data = Name_rr_map.singleton name ty v in
`Packet (packet t true (Some ty) Rcode.NoError ~ttl ~rrsig:(is_signed r) data Domain_name.Map.empty), t)
let pick_n rng n xs =
let l = List.length xs in
if n >= l then
xs
else
let rec pick amount bound =
if amount = 0 then
[]
else
let e = Randomconv.int ~bound rng in
let ips'' = pick (amount - 1) (bound - 1) in
e :: List.map (fun idx -> if idx < e then idx else succ idx) ips''
in
let idx = pick n l in
List.map (List.nth xs) idx
let handle_query t ~qname_minimisation ~dnssec ~dnssec_ok ~rng ip_proto ts (qname, qtype) =
match answer ~dnssec ~dnssec_ok t ts qname qtype with
| `Packet (flags, data, additional), t ->
Log.debug (fun m -> m "handle_query: reply %a (%a)" Domain_name.pp qname
Packet.Question.pp_qtype qtype);
`Reply (flags, data, additional), t
| `Query name, t ->
(* DS should be requested at the parent *)
let name', recover =
if Domain_name.count_labels name > 1 && qtype = `K (Rr_map.K Ds) then
let n' = Domain_name.drop_label_exn name in
n', fun n -> if Domain_name.equal n n' then name else n
else
name, Fun.id
in
let actions = resolve t ~qname_minimisation ~dnssec ip_proto ts name' qtype in
let up_to_three = pick_n rng 3 actions in
let ip1 = 4 - List.length up_to_three in
let ip2 = max 1 (3 - List.length up_to_three) in
let _i, queries, t' =
List.fold_left (fun (i, acc, _t) (zone, name'', types, ips, t) ->
let name'' = recover name'' in
let number_of_ips = if i = 0 then ip1 else ip2 in
let ips = pick_n rng number_of_ips ips in
Log.debug (fun m -> m "handle_query %a (%a) query %a, resolve zone %a query %a (%a), ips %a"
Domain_name.pp qname Packet.Question.pp_qtype qtype
Domain_name.pp name Domain_name.pp zone Domain_name.pp name''
Fmt.(list ~sep:(any ", ") Packet.Question.pp_qtype) types
Fmt.(list ~sep:(any ", ") Ipaddr.pp) ips);
let actions =
List.map (fun ip -> (zone, (name'', types), ip)) ips
in
succ i, acc @ actions, Some t)
(0, [], None) up_to_three
in
`Queries queries, Option.value ~default:t t'

25
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_cache.mli Normal file
View file

@ -0,0 +1,25 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
val pp_question : ([ `raw ] Domain_name.t * Packet.Question.qtype) Fmt.t
val follow_cname : Dns_cache.t -> int64 -> 'a Rr_map.key -> name:[ `raw ] Domain_name.t -> int32 ->
alias:[ `raw ] Domain_name.t ->
[ `Out of Rcode.t * Rrsig.t option * Name_rr_map.t * Name_rr_map.t
| `Query of [ `raw ] Domain_name.t ] * Dns_cache.t
val answer : dnssec:bool -> dnssec_ok:bool -> Dns_cache.t -> int64 -> [ `raw ] Domain_name.t -> Packet.Question.qtype ->
[ `Query of [ `raw ] Domain_name.t
| `Packet of Packet.Flags.t * Packet.reply * Name_rr_map.t option ] * Dns_cache.t
val resolve : Dns_cache.t -> qname_minimisation:bool -> dnssec:bool ->
[`Both | `Ipv4_only | `Ipv6_only] -> int64 -> [ `raw ] Domain_name.t ->
Packet.Question.qtype ->
([ `raw ] Domain_name.t * [ `raw ] Domain_name.t * Packet.Question.qtype list * Ipaddr.t list * Dns_cache.t) list
val handle_query : Dns_cache.t -> qname_minimisation:bool -> dnssec:bool -> dnssec_ok:bool ->
rng:(int -> string) -> [`Both | `Ipv4_only | `Ipv6_only ] ->
int64 ->
[ `raw ] Domain_name.t * Packet.Question.qtype ->
[ `Reply of Packet.Flags.t * Packet.reply * Name_rr_map.t option
| `Queries of ([ `raw ] Domain_name.t * ([ `raw ] Domain_name.t * Packet.Question.qtype list) * Ipaddr.t) list ] * Dns_cache.t

18
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_metrics.ml Normal file
View file

@ -0,0 +1,18 @@
let resolver_stats =
let f = function
| `Error -> "error"
| `Queries -> "queries"
| `Blocked -> "blocked"
| `Clients -> "clients"
in
let src = Dns.counter_metrics ~f "dns-resolver" in
(fun r -> Metrics.add src (fun x -> x) (fun d -> d r))
let response_metric =
let store = ref (0L, 0L) in
let data dp =
store := (Int64.succ (fst !store), Int64.add dp (snd !store));
Metrics.Data.v [ Metrics.uint "mean response" (Duration.to_ms (Int64.div (snd !store) (fst !store))) ]
in
let src = Metrics.Src.v ~tags:Metrics.Tags.[] ~data "dns-resolver-timings" in
(fun dp -> Metrics.add src (fun x -> x) (fun d -> d dp))

3
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_metrics.mli Normal file
View file

@ -0,0 +1,3 @@
val resolver_stats : [ `Blocked | `Clients | `Error | `Queries ] -> unit
val response_metric : int64 -> unit

82
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_root.ml Normal file
View file

@ -0,0 +1,82 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Dns
let root_servers =
List.map (fun (n, ip4, ip6) ->
Domain_name.(host_exn (of_string_exn n)),
Ipaddr.V4.of_string_exn ip4,
Ipaddr.V6.of_string_exn ip6)
[
"a.root-servers.net", "198.41.0.4", "2001:503:ba3e::2:30" ; (* VeriSign, Inc. *)
"b.root-servers.net", "170.247.170.2", "2801:1b8:10::b" ; (* University of Southern California (ISI) *)
"c.root-servers.net", "192.33.4.12", "2001:500:2::c" ; (* Cogent Communications *)
"d.root-servers.net", "199.7.91.13", "2001:500:2d::d" ; (* University of Maryland *)
"e.root-servers.net", "192.203.230.10", "2001:500:a8::e" ; (* NASA (Ames Research Center) *)
"f.root-servers.net", "192.5.5.241", "2001:500:2f::f" ; (* Internet Systems Consortium, Inc. *)
"g.root-servers.net", "192.112.36.4", "2001:500:12::d0d" ; (* US Department of Defense (NIC) *)
"h.root-servers.net", "198.97.190.53", "2001:500:1::53" ; (* US Army (Research Lab) *)
"i.root-servers.net", "192.36.148.17", "2001:7fe::53" ; (* Netnod *)
"j.root-servers.net", "192.58.128.30", "2001:503:c27::2:30" ; (* VeriSign, Inc. *)
"k.root-servers.net", "193.0.14.129", "2001:7fd::1" ; (* RIPE NCC *)
"l.root-servers.net", "199.7.83.42", "2001:500:9f::42" ; (* ICANN *)
"m.root-servers.net", "202.12.27.33", "2001:dc3::35" ; (* WIDE Project *)
]
let a_ttl = 3600000l
let ns_ttl = 518400l
let ns_records =
let ns =
let add_to_set set (name, _, _) = Domain_name.Host_set.add name set in
List.fold_left add_to_set Domain_name.Host_set.empty root_servers
in
(ns_ttl, ns)
let a_records =
List.map (fun (name, ip, _) ->
Domain_name.raw name, (a_ttl, Ipaddr.V4.Set.singleton ip))
root_servers
let aaaa_records =
List.map (fun (name, _, ip) ->
Domain_name.raw name, (a_ttl, Ipaddr.V6.Set.singleton ip))
root_servers
let ips protocol =
List.fold_left (fun acc (_, ip4, ip6) ->
match protocol with
| `Both -> Ipaddr.V4 ip4 :: Ipaddr.V6 ip6 :: acc
| `Ipv4_only -> Ipaddr.V4 ip4 :: acc
| `Ipv6_only -> Ipaddr.V6 ip6 :: acc)
[] root_servers
let reserved_zone_records =
let n = Domain_name.of_string_exn in
(* RFC 6761, avoid them to get out of here + multicast DNS 6762 *)
let zones =
Domain_name.Set.(add (n "local") (* multicast dns, RFC 6762 *)
(add (n "test") (add (n "invalid") (* RFC 6761 *)
(add (n "localhost") (* RFC 6761, draft let-localhost-be-localhost *)
empty))))
in
let local_net_name = "127.in-addr.arpa" in
Domain_name.Set.add (n local_net_name) zones
let stub_soa s =
let nameserver = Domain_name.prepend_label_exn s "ns"
and hostmaster = Domain_name.prepend_label_exn s "hostmaster"
in
{ Soa.nameserver ; hostmaster ; serial = 0l ; refresh = 300l ; retry = 300l ;
expiry = 300l ; minimum = 300l }
let reserved_zones =
let inv s = Rr_map.(B (Soa, stub_soa s)) in
Domain_name.Set.fold (fun n acc -> (n, inv n) :: acc) reserved_zone_records []
let reserved =
Domain_name.Set.fold (fun name trie ->
Dns_trie.insert name Rr_map.Soa (stub_soa name) trie)
reserved_zone_records Dns_trie.empty
let root_servers =
List.map (fun (n, ip4, ip6) -> Domain_name.raw n, ip4, ip6) root_servers

27
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_root.mli Normal file
View file

@ -0,0 +1,27 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Dns
val root_servers : ([ `raw ] Domain_name.t * Ipaddr.V4.t * Ipaddr.V6.t) list
(** [root_servers] are the root servers. *)
val ns_records : (int32 * Domain_name.Host_set.t)
(** [ns_records] is the root nameserver binding. *)
val a_records : ([ `raw ] Domain_name.t * (int32 * Ipaddr.V4.Set.t)) list
(** [a_records] is a list of names and bindings (A records) for the root
servers. *)
val aaaa_records : ([ `raw ] Domain_name.t * (int32 * Ipaddr.V6.Set.t)) list
(** [aaaa_records] is a list of names and bindings (AAAA records) for the root
servers. *)
val ips : [ `Both | `Ipv4_only | `Ipv6_only ] -> Ipaddr.t list
(** [ips ip_proto] is a list of ip addresses of the root servers. *)
val reserved_zones : ([ `raw ] Domain_name.t * Rr_map.b) list
(** [reserved_zones] is a list of names and bindings for reserved zones
specified by RFCs (private network address ranges, private domains) *)
val reserved : Dns_trie.t
(** [reserved] is a trie with all [reserved_zones]. *)

3
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_shared.ml Normal file
View file

@ -0,0 +1,3 @@
module Root = Dns_resolver_root
module Metrics = Dns_resolver_metrics
module Block = Dns_block

281
unikernel/duniverse/ocaml-dns/resolver/dns_resolver_utils.ml Normal file
View file

@ -0,0 +1,281 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
open Dns_resolver_cache
let src = Logs.Src.create "dns_resolver_util" ~doc:"DNS resolver util"
module Log = (val Logs.src_log src : Logs.LOG)
type e = E : 'a Rr_map.key * 'a Dns_cache.entry -> e
let invalid_soa name =
let p pre =
Result.value ~default:name
(Result.bind
(Domain_name.prepend_label name "invalid")
(fun n -> Domain_name.prepend_label n pre))
in
{
Soa.nameserver = p "ns" ; hostmaster = p "hostmaster" ;
serial = 1l ; refresh = 16384l ; retry = 2048l ;
expiry = 1048576l ; minimum = 300l
}
let rrsig rr_map ty =
match Rr_map.find Rrsig rr_map with
| Some v ->
Rr_map.Rrsig_set.find_first_opt (fun rrsig ->
rrsig.Rrsig.type_covered = Rr_map.to_int ty)
(snd v)
| None -> None
let noerror bailiwick (_, flags) ~signed q_name q_type (answer, authority) additional =
(* maybe should be passed explicitly (when we don't do qname minimisation) *)
let in_bailiwick name = Domain_name.is_subdomain ~domain:bailiwick ~subdomain:name in
(* ANSWER *)
let answers, anames =
match Domain_name.Map.find q_name answer with
| None ->
(* NODATA (no answer, but SOA (or not) in authority) *)
begin
(* RFC2308, Sec 2.2 "No data":
- answer is empty
- authority has a) SOA + NS, b) SOA, or c) nothing *)
(* an example for this behaviour is NS:
asking for AAAA www.soup.io, get empty answer + SOA in authority
asking for AAAA coffee.soup.io, get empty answer + authority *)
(* the "sub" should be relaxed - for dig ns mail.mehnert.org I get soa in mehnert.org!
--> but how to discover SOA/zone boundaries? *)
let rank rrsig =
if Packet.Flags.mem `Authoritative flags then
Dns_cache.AuthoritativeAuthority (if signed then rrsig else None)
else
Dns_cache.Additional
in
match
Domain_name.Map.fold (fun name rr_map acc ->
if Domain_name.is_subdomain ~subdomain:q_name ~domain:name then
match Rr_map.find Soa rr_map with
| Some soa -> (name, soa, rr_map) :: acc
| None -> acc
else
acc)
authority []
with
| (name, soa, rr_map)::_ ->
begin match q_type with
| `Any -> [] (* i really don't know how to handle ANY NoDATA*)
| `K Rr_map.K k -> [ q_name, E (k, `No_data (name, soa)), rank (rrsig rr_map Soa) ]
(* this is wrong for the normal iterative algorithm:
it asks for foo.com @root, and get .com NS in AU and A in AD
| [] when not (Packet.Header.FS.mem `Truncation flags) ->
Log.warn (fun m -> m "noerror answer, but nothing in authority whose sub is %a in %a, invalid_soa!"
pp_question (q_name, q_type) Name_rr_map.pp authority) ;
[ q_type, q_name, Additional, `No_data (q_name, invalid_soa q_name) ] *)
end
| [] -> [] (* general case when we get an answer from root server *)
end, Domain_name.Set.empty
| Some rr_map ->
let rank rrsig =
if Packet.Flags.mem `Authoritative flags then
Dns_cache.AuthoritativeAnswer (if signed then rrsig else None)
else
Dns_cache.NonAuthoritativeAnswer
in
(* collect those rrsets which are of interest depending on q_type! *)
match q_type with
| `Any ->
Rr_map.fold (fun (B (k, v)) (acc, names) ->
(q_name, E (k, `Entry v), rank (rrsig rr_map k)) :: acc,
Domain_name.Host_set.fold (fun n acc ->
Domain_name.Set.add (Domain_name.raw n) acc)
(Rr_map.names k v) names)
rr_map ([], Domain_name.Set.empty)
| `K (Rr_map.K Cname) ->
begin match Rr_map.find Cname rr_map with
| Some v -> [ q_name, E (Cname, `Entry v), rank (rrsig rr_map Cname) ],
Domain_name.Host_set.fold (fun n acc ->
Domain_name.Set.add (Domain_name.raw n) acc)
(Rr_map.names Cname v) Domain_name.Set.empty
| None ->
(* case no cname *)
Log.warn (fun m -> m "noerror answer with right name, but no cname in %a, invalid soa for %a"
Name_rr_map.pp answer pp_question (q_name, q_type));
[ q_name, E (Cname, `No_data (q_name, invalid_soa q_name)), rank None ],
Domain_name.Set.empty
end
| `K (Rr_map.K k) -> match Rr_map.find k rr_map with
| Some v ->
[ q_name, E (k, `Entry v), rank (rrsig rr_map k) ],
Domain_name.Host_set.fold (fun n acc ->
Domain_name.Set.add (Domain_name.raw n) acc)
(Rr_map.names k v) Domain_name.Set.empty
| None -> match Rr_map.find Cname rr_map with
| None ->
(* case neither TYP nor cname *)
Log.warn (fun m -> m "noerror answer with right name, but not TYP nor cname in %a, invalid soa for %a"
Name_rr_map.pp answer pp_question (q_name, q_type));
[ q_name, E (k, `No_data (q_name, invalid_soa q_name)), rank None ],
Domain_name.Set.empty
| Some cname ->
(* explicitly register as CNAME so it'll be found *)
(* should we try to find further records for the new alias? *)
[ q_name, E (Cname, `Entry cname), rank (rrsig rr_map Cname) ],
Domain_name.Set.singleton (snd cname)
in
(* AUTHORITY - NS and DS records, also nsec and nsec3 *)
let ns, nsnames =
(* authority points us to NS of q_name! *)
(* we collect a list of NS records and the ns names *)
(* TODO need to be more careful, q: foo.com a: foo.com a 1.2.3.4 au: foo.com ns blablubb.com ad: blablubb.com A 1.2.3.4 *)
let rank s =
if Packet.Flags.mem `Authoritative flags then
Dns_cache.AuthoritativeAuthority (if signed then s else None)
else
Dns_cache.Additional
in
let ns, others, names =
Domain_name.Map.fold (fun name map (ns_acc, other_acc, s) ->
if in_bailiwick name then
let ns, s =
match Rr_map.find Ns map with
| None -> ns_acc, s
| Some (ns : int32 * Domain_name.Host_set.t) ->
(name, ns) :: ns_acc, Domain_name.Host_set.fold (fun n acc ->
Domain_name.Set.add (Domain_name.raw n) acc)
(snd ns) s
in
let others = match Rr_map.find Nsec map with
| None -> other_acc
| Some n -> (name, E (Nsec, `Entry n), rank (rrsig map Nsec)) :: other_acc
in
let others = match Rr_map.find Nsec3 map with
| None -> others
| Some n -> (name, E (Nsec3, `Entry n), rank (rrsig map Nsec3)) :: others
in
let others = match Rr_map.find Ds map with
| None -> others
| Some n -> (name, E (Ds, `Entry n), rank (rrsig map Ds)) :: others
in
ns, others, s
else
ns_acc, other_acc, s)
authority
([], [], Domain_name.Set.empty)
in
List.fold_left (fun acc (name, ns) ->
(name, E (Ns, `Entry ns), rank None) :: acc)
others ns, names
in
(* ADDITIONAL *)
(* maybe only these thingies which are subdomains of q_name? *)
(* preserve A/AAAA records only for NS lookups? *)
(* now we have processed:
- answer (filtered to where name = q_name)
- authority with SOA and NS entries
- names from these answers, and authority
- additional section can contain glue records if needed
- only A and AAAA records are of interest for glue *)
let glues =
let names = Domain_name.Set.union anames nsnames in
let names = Domain_name.Set.filter in_bailiwick names in
Domain_name.Set.fold (fun name acc ->
match Domain_name.Map.find name additional with
| None -> acc
| Some map ->
let a = match Rr_map.find A map with
| None -> acc
| Some v -> (name, E (A, `Entry v), Dns_cache.Additional) :: acc
in
match Rr_map.find Aaaa map with
| None -> a
| Some v -> (name, E (Aaaa, `Entry v), Dns_cache.Additional) :: a)
names []
in
(* This is defined in RFC2181, Sec9 -- answer is unique if authority or
additional is non-empty *)
let answer_complete =
not (Domain_name.Map.is_empty authority && Domain_name.Map.is_empty additional)
in
match answers, ns with
| [], [] when not answer_complete && Packet.Flags.mem `Truncation flags ->
(* special handling for truncated replies.. better not add anything *)
Log.warn (fun m -> m "truncated reply for %a, ignoring completely"
pp_question (q_name, q_type));
[]
| [], [] ->
(* not sure if this can happen, maybe discard everything? *)
Log.warn (fun m -> m "reply without answers or ns invalid so for %a"
pp_question (q_name, q_type));
begin match q_type with
| `Any -> []
| `K Rr_map.K k -> [ q_name, E (k,`No_data (q_name, invalid_soa q_name)), Dns_cache.Additional ]
end
| _, _ -> answers @ ns @ glues
let find_soa name authority =
let rec go name =
match Domain_name.Map.find name authority with
| None -> go (Domain_name.drop_label_exn name)
| Some rrmap -> match Rr_map.(find Soa rrmap) with
| None -> go (Domain_name.drop_label_exn name)
| Some soa -> name, soa, rrsig rrmap Soa
in
try Some (go name) with Invalid_argument _ -> None
let nxdomain (_, flags) ~signed name data =
(* we can't do much if authoritiative is not set (some auth dns do so) *)
(* There are cases where answer is non-empty, but contains a CNAME *)
(* RFC 2308 Sec 1 + 2.1 show that NXDomain is for the last QNAME! *)
(* -> need to potentially extract CNAME(s) *)
let answer, authority = match data with
| None -> Name_rr_map.empty, Name_rr_map.empty
| Some x -> x
in
let cnames =
let rec go acc name =
match Domain_name.Map.find name answer with
| None -> acc
| Some rrmap -> match Rr_map.(find Cname rrmap) with
| None -> acc
| Some (ttl, alias) -> go ((name, (ttl, alias), rrsig rrmap Cname) :: acc) alias
in
go [] name
in
let soa = find_soa name authority in
(* since NXDomain have CNAME semantics, we store them as CNAME *)
let rank rrsig =
if Packet.Flags.mem `Authoritative flags then
Dns_cache.AuthoritativeAnswer (if signed then rrsig else None)
else
Dns_cache.NonAuthoritativeAnswer
in
(* we conclude NXDomain, there are 3 cases we care about:
no soa in authority and no cname answer -> inject an invalid_soa (avoid loops)
a matching soa, no cname -> NoDom q_name
_, a matching cname -> NoErr q_name with cname
*)
let entries =
let soa_name, soa, rrsig = match soa with
| None -> name, invalid_soa name, None
| Some x -> x
in
match cnames with
| [] -> [ name, E (Cname, `No_domain (soa_name, soa)), rrsig ]
| rrs -> List.map (fun (name, cname, rrsig) -> (name, E (Cname, `Entry cname), rrsig)) rrs
in
(* the cname does not matter *)
List.map (fun (name, res, rrsig) -> name, res, rank rrsig) entries
let scrub zone ~signed qtype p =
Log.debug (fun m -> m "scrubbing (bailiwick %a) data %a"
Domain_name.pp zone Packet.pp p);
let qname = fst p.question in
match p.Packet.data with
| `Answer data ->
Ok (noerror zone p.header ~signed qname qtype data p.additional)
| `Rcode_error (Rcode.NXDomain, _, data) ->
Ok (nxdomain p.Packet.header ~signed qname data)
| e -> Error (Packet.rcode_data e)

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

@ -0,0 +1,16 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
type e = E : 'a Rr_map.key * 'a Dns_cache.entry -> e
val scrub : [ `raw ] Domain_name.t -> signed:bool -> Packet.Question.qtype ->
Packet.t ->
(([ `raw ] Domain_name.t * e * Dns_cache.rank) list, Rcode.t) result
(** [scrub bailiwick packet] returns a list of entries to-be-added to the
cache. This respects only in-bailiwick resources records, and qualifies the
[packet]. The purpose is to avoid cache poisoning by not accepting all
resource records. *)
val invalid_soa : [ `raw ] Domain_name.t -> Soa.t
(** [invalid_soa name] returns a stub SOA for [name]. *)

15
unikernel/duniverse/ocaml-dns/resolver/dune Normal file
View file

@ -0,0 +1,15 @@
(library
(name dns_resolver)
(public_name dns-resolver)
(instrumentation
(backend bisect_ppx))
(wrapped false)
(modules dns_resolver dns_resolver_utils dns_resolver_cache)
(libraries dns dns.cache dns-server lru duration randomconv dnssec logs dns_resolver_shared))
(library
(name dns_resolver_shared)
(public_name dns-resolver.shared)
(wrapped false)
(modules dns_resolver_shared dns_resolver_root dns_block dns_resolver_metrics)
(libraries dns dns-server metrics))

1954
unikernel/duniverse/ocaml-dns/server/dns_server.ml Normal file
View file

File diff suppressed because it is too large Load diff

238
unikernel/duniverse/ocaml-dns/server/dns_server.mli Normal file
View file

@ -0,0 +1,238 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
(** DNS Server implementation *)
(** Authentication, stored in a Dns_trie with privileges to operations embedded in the name. *)
module Authentication : sig
(** A key is a pair of a [`raw Domain_name.t] and a [Dnskey.t]. In the name,
operation privileges and potentially IP addresses are encoded, e.g.
[foo._transfer.example.com] may do AXFR on [example.com] and any
subdomain, e.g. [foo.example.com]. *)
type operation = [
| `Update
| `Transfer
| `Notify
]
(** The type of operations, sorted by highest ot lowest privileges, an
[`Update] may as well carry out a [`Transfer]. *)
val operation_to_string : operation -> string
(** [operation_to_string op] is the string representation of [op]. *)
val all_ops : operation list
(** [all_ops] is a list of all operations. *)
val access_granted : required:operation -> operation -> bool
(** [access_granted ~required key_operation] is [true] if [key_operation] is
authorised for [required] operation. *)
val zone_and_operation : 'a Domain_name.t -> ([`host] Domain_name.t * operation) option
(** [zone_and_operation key] is [Some (zone, op)], the [zone] of the [key],
and its operation [op]. If the [key] is not in the expected format, [None]
is returned. *)
val access : ?key:'a Domain_name.t -> zone:'b Domain_name.t -> operation -> bool
(** [access op ~key ~zone] checks whether [key] is authorised for [op] on
[zone]. *)
type t
(** Opaque type for storing authentication keys. *)
end
type t = private {
data : Dns_trie.t ;
auth : Authentication.t ;
unauthenticated_zone_transfer : bool ;
rng : int -> string ;
tsig_verify : Tsig_op.verify ;
tsig_sign : Tsig_op.sign ;
}
(** The state of a DNS server. *)
val create : ?unauthenticated_zone_transfer:bool ->
?tsig_verify:Tsig_op.verify ->
?tsig_sign:Tsig_op.sign ->
?auth:Authentication.t ->
Dns_trie.t ->
(int -> string) ->
t
(** [create ~unauthenticated_zone_transfer ~tsig_verify ~tsig_sign ~auth data rng]
constructs a [t]. See {!Primary.create} and {!Secondary.create} for the
logic running a primary or secondary server. *)
val with_data : t -> Dns_trie.t -> t
(** [with_data t data] is [t'] where the [data] field is updated with the
provided value. Be aware that this function breaks the semantics of a
primary server with secondaries, since secondaries won't be notified and
will be out of sync. Use if you know what you do. The data of a secondary
will usually come via zone transfer from the primary name services. *)
val text : 'a Domain_name.t -> Dns_trie.t -> (string, [> `Msg of string ]) result
(** [text name trie] results in a string representation (zonefile) of the trie. *)
val handle_question : t -> Packet.Question.t ->
(Packet.Flags.t * Packet.Answer.t * Name_rr_map.t option,
Rcode.t * Packet.Answer.t option) result
(** [handle_question t question] handles the DNS query [question] by looking
it up in the trie of [t]. The result is either an answer or an error. *)
val update_data : Dns_trie.t -> 'a Domain_name.t ->
Dns.Packet.Update.prereq list Domain_name.Map.t
* Dns.Packet.Update.update list Domain_name.Map.t ->
( Dns_trie.t * (Domain_name.Set.elt * Dns.Soa.t) list,
Dns.Rcode.t )
result
(** [update_data data domain update_content] applies the [update_content] to
the [data] for [domain]. This function breaks the semantics of a primary
server with secondaries, since the secondaries won't be notified of the
update and will be out of sync. Use if you know what you are doing. *)
val handle_update : t -> proto -> [ `raw ] Domain_name.t option ->
Packet.Question.t -> Packet.Update.t ->
(Dns_trie.t * ([`raw] Domain_name.t * Soa.t) list, Rcode.t) result
(** [handle_update t proto keyname question update] authenticates the update
request and processes the update. This function breaks the semantics of a
primary server with secondaries, since the secondaries won't be notified.
Use if you know what you are doing. *)
val handle_axfr_request : t -> proto -> [ `raw ] Domain_name.t option ->
Packet.Question.t -> (Packet.Axfr.t, Rcode.t) result
(** [handle_axfr_request t proto keyname question] authenticates the zone
transfer request and processes it. If the request is valid, and the zone
available, a zone transfer is returned. *)
type trie_cache
val handle_ixfr_request : t -> trie_cache -> proto -> [ `raw ] Domain_name.t option ->
Packet.Question.t -> Soa.t -> (Packet.Ixfr.t, Rcode.t) result
(** [handle_ixfr_request t cache proto keyname question soa] authenticates the
incremental zone transfer request and processes it. If valid, an incremental
zone transfer is returned. *)
val handle_tsig : ?mac:string -> t -> Ptime.t -> Packet.t ->
string -> (([ `raw ] Domain_name.t * Tsig.t * string * Dnskey.t) option,
Tsig_op.e * string option) result
(** [handle_tsig ~mac t now packet buffer] verifies the tsig
signature if present, returning the keyname, tsig, mac, and used key. *)
type packet_callback = Packet.Question.t -> Packet.reply option
(** [packet_callback question] either returns a reply to a DNS question [Some reply] or [None]. *)
module Primary : sig
type s
(** The state of a primary DNS server. *)
val server : s -> t
(** [server s] is the server of the primary. *)
val data : s -> Dns_trie.t
(** [data s] is the data store of [s]. *)
val with_data : s -> Ptime.t -> int64 -> Dns_trie.t ->
s * (Ipaddr.t * string list) list
(** [with_data s now ts trie] replaces the current data with [trie] in [s].
The returned notifications should be send out. *)
val with_keys : s -> Ptime.t -> int64 -> ('a Domain_name.t * Dnskey.t) list ->
s * (Ipaddr.t * string list) list
(** [with_keys s now ts keys] replaces the current keys with [keys] in [s],
and generates notifications. *)
val trie_cache : s -> trie_cache
(** [trie_cache s] is the trie cache of the server. *)
val create : ?trie_cache_entries:int -> ?keys:('a Domain_name.t * Dnskey.t) list ->
?unauthenticated_zone_transfer:bool ->
?tsig_verify:Tsig_op.verify -> ?tsig_sign:Tsig_op.sign ->
rng:(int -> string) -> Dns_trie.t -> s
(** [create ~trie_cache_entries ~keys ~unauthenticated_zone_transfer
~tsig_verify ~tsig_sign ~rng data] creates a primary server. If
[unauthenticated_zone_transfer] is provided and [true] (defaults to
[false]), anyone can transfer the zones. [trie_cache_entries] is the
backlog to keep in memory for incremental zone transfers (IXFR, default is 5). This
affects memory usage. *)
val handle_packet : ?packet_callback:packet_callback -> s -> Ptime.t -> int64
-> proto -> Ipaddr.t -> int -> Packet.t -> 'a Domain_name.t option ->
s * Packet.t option * (Ipaddr.t * string list) list *
[> `Notify of Soa.t option | `Keep ] option
(** [handle_packet ~packet_callback s now ts src src_port proto key packet]
handles the given [packet], returning new state, an answer, and
potentially notify packets to secondary name servers. If [packet_callback]
is specified, it is called for each incoming query. If it returns
[Some reply], this reply is used instead of the usual lookup in the
zone data. It can be used for custom query processing, such as for load
balancing or transporting data. *)
val handle_buf : ?packet_callback:packet_callback -> s -> Ptime.t -> int64
-> proto -> Ipaddr.t -> int -> string ->
s * string list * (Ipaddr.t * string list) list *
[ `Notify of Soa.t option | `Signed_notify of Soa.t option | `Keep ] option *
[ `raw ] Domain_name.t option
(** [handle_buf ~packet_callback s now ts proto src src_port buffer] decodes
the [buffer], processes the DNS frame using {!handle_packet}, and encodes
the reply. The result is a new state, potentially a list of answers to the
requestor, a list of notifications to send out, information whether a
notify (or signed notify) was received, and the hmac key used for
authentication. If [packet_callback] is specified, it is called for each
incoming query. If it returns [Some reply], this reply is used instead of
the usual lookup in the zone data. This can be used for custom query
processing, such as for load balancing or transporting data. *)
val closed : s -> Ipaddr.t -> s
(** [closed s ip] marks the connection to [ip] closed. *)
val timer : s -> Ptime.t -> int64 ->
s * (Ipaddr.t * string list) list
(** [timer s now ts] may encode some notifications to secondary name servers
if previous ones were not acknowledged. *)
val to_be_notified : s -> [ `host ] Domain_name.t ->
(Ipaddr.t * [ `raw ] Domain_name.t option) list
(** [to_be_notified s zone] returns a list of pairs of IP address and optional
tsig key name of the servers to be notified for a zone change. This list
is based on (a) NS entries for the zone, (b) registered TSIG transfer keys,
and (c) active connection (which transmitted a signed SOA). *)
end
module Secondary : sig
type s
(** The state of a secondary DNS server. *)
val data : s -> Dns_trie.t
(** [data s] is the zone data of [s]. *)
val with_data : s -> Dns_trie.t -> s
(** [with_data s trie] is [s] with its data replaced by [trie]. *)
val create : ?primary:Ipaddr.t ->
tsig_verify:Tsig_op.verify -> tsig_sign:Tsig_op.sign ->
rng:(int -> string) -> ('a Domain_name.t * Dnskey.t) list -> s
(** [create ~primary ~tsig_verify ~tsig_sign ~rng keys] creates a secondary
DNS server state. *)
val handle_packet : ?packet_callback:packet_callback -> s -> Ptime.t -> int64 ->
Ipaddr.t -> Packet.t -> 'a Domain_name.t option ->
s * Packet.t option * (Ipaddr.t * string) option
(** [handle_packet s now ts ip proto key t] handles the incoming packet. *)
val handle_buf : ?packet_callback:packet_callback -> s -> Ptime.t -> int64 ->
proto -> Ipaddr.t -> string ->
s * string option * (Ipaddr.t * string) option
(** [handle_buf ~packet_callback s now ts proto src buf] decodes [buf], processes with
{!handle_packet}, and encodes the results. *)
val timer : s -> Ptime.t -> int64 ->
s * (Ipaddr.t * string list) list
(** [timer s now ts] may request SOA or retransmit AXFR. *)
val closed : s -> Ptime.t -> int64 -> Ipaddr.t ->
s * string list
(** [closed s now ts ip] marks [ip] as closed, the returned buffers (SOA
requests) should be sent to [ip]. *)
end

551
unikernel/duniverse/ocaml-dns/server/dns_trie.ml Normal file
View file

@ -0,0 +1,551 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Dns
module Canonical : sig
type 'a t
val v : 'a Domain_name.t -> 'a t
val d : 'a t -> 'a Domain_name.t
end = struct
type 'a t = 'a Domain_name.t
let v n = Domain_name.canonical n
let d n = n
end
module O = struct
type t = string
let compare = String.compare
end
module M = Map.Make(O)
type t = N of t M.t * Rr_map.t
let empty = N (M.empty, Rr_map.empty)
let is_empty (N (sub, map)) = M.is_empty sub && Rr_map.is_empty map
let bindings t =
let rec go pre (N (sub, e)) =
let subs = M.bindings sub in
(pre, e) ::
List.fold_left
(fun acc (pre', va) ->
acc @ go (Domain_name.prepend_label_exn pre pre') va) [] subs
in
go Domain_name.root t
let pp_map name ppf map =
Fmt.(list ~sep:(any "@.") string) ppf
(List.map (Rr_map.text_b name) (Rr_map.bindings map))
let pp ppf t = List.iter (fun (name, map) -> pp_map name ppf map) (bindings t)
let rec equal (N (sub, map)) (N (sub', map')) =
Rr_map.equal { f = Rr_map.equal_rr } map map' && M.equal equal sub sub'
type e = [ `Delegation of [ `raw ] Domain_name.t * (int32 * Domain_name.Host_set.t)
| `EmptyNonTerminal of [ `raw ] Domain_name.t * Soa.t
| `NotAuthoritative
| `NotFound of [ `raw ] Domain_name.t * Soa.t ]
let pp_e ppf = function
| `Delegation (name, (ttl, ns)) ->
Fmt.pf ppf "delegation %a to TTL %lu %a" Domain_name.pp name ttl
Fmt.(list ~sep:(any ",@,") Domain_name.pp) (Domain_name.Host_set.elements ns)
| `EmptyNonTerminal (name, soa) ->
Fmt.pf ppf "empty non terminal %a SOA %a" Domain_name.pp name Soa.pp soa
| `NotAuthoritative -> Fmt.string ppf "not authoritative"
| `NotFound (name, soa) -> Fmt.pf ppf "not found %a soa %a" Domain_name.pp name Soa.pp soa
let ( let* ) = Result.bind
let guard p err = if p then Ok () else Error err
let ent name map =
let soa = Rr_map.get Soa map in
`EmptyNonTerminal (name, soa)
let to_ns name map =
let ttl, ns =
match Rr_map.find Ns map with
| None -> 0l, Domain_name.Host_set.empty
| Some (ttl, ns) -> ttl, ns
in
(name, ttl, ns)
let check_zone = function
| None -> Error `NotAuthoritative
| Some (`Delegation (name, (ttl, ns))) -> Error (`Delegation (name, (ttl, ns)))
| Some (`Soa (z, zmap)) -> Ok (z, zmap)
let lookup_res zone ty m =
let* z, zmap = check_zone zone in
match Rr_map.find ty m with
| Some v -> Ok (Rr_map.B (ty, v), to_ns z zmap)
| None -> match Rr_map.find Cname m with
| None when Rr_map.cardinal m = 1 && Rr_map.(mem Soa m) ->
(* this is primary a hack for localhost, which must be NXDomain,
but there's a SOA for localhost (to handle it authoritatively) *)
(* TODO should we check that the label-node map is empty?
well, if we have a proper authoritative zone, there'll be a NS *)
let soa = Rr_map.get Rr_map.Soa zmap in
Error (`NotFound (z, soa))
| None -> Error (ent z zmap)
| Some cname -> Ok (B (Cname, cname), to_ns z zmap)
let lookup_aux name t =
let name = Canonical.d name in
let k = Domain_name.to_array name in
let l = Array.length k in
let fzone idx map =
let name = Domain_name.(of_array (Array.sub (to_array name) 0 idx)) in
match Rr_map.mem Soa map, Rr_map.find Ns map with
| true, _ -> Some (`Soa (name, map))
| false, Some ns -> Some (`Delegation (name, ns))
| false, None -> None
in
let rec go idx zone = function
| N (sub, map) ->
let zone = match fzone idx map with None -> zone | Some x -> Some x in
if idx = l then Ok (zone, sub, map)
else match M.find (Array.get k idx) sub with
| exception Not_found ->
begin match zone with
| None -> Error `NotAuthoritative
| Some (`Delegation (name, (ttl, ns))) ->
Error (`Delegation (name, (ttl, ns)))
| Some (`Soa (name, map)) ->
(* may still be a wildcard *)
match M.find "*" sub with
| exception Not_found ->
let soa = Rr_map.get Soa map in
Error (`NotFound (name, soa))
| N (sub, map) -> Ok (zone, sub, map)
end
| x -> go (succ idx) zone x
in
go 0 None t
let lookup_with_cname name ty t =
let* zone, _sub, map = lookup_aux (Canonical.v name) t in
lookup_res zone ty map
let lookup name key t =
let* zone, _sub, map = lookup_aux (Canonical.v name) t in
let* z, zmap = check_zone zone in
Option.to_result ~none:(ent z zmap) (Rr_map.find key map)
let lookup_any name t =
match lookup_aux (Canonical.v name) t with
| Error e -> Error e
| Ok (zone, _sub, m) ->
let* z, zmap = check_zone zone in
Ok (m, to_ns z zmap)
let lookup_glue name t =
match lookup_aux (Canonical.v name) t with
| Error _ -> None, None
| Ok (_zone, _sub, map) -> Rr_map.find A map, Rr_map.find Aaaa map
let zone name t =
match lookup_aux (Canonical.v name) t with
| Error (`NotFound (zone, soa)) -> Ok (zone, soa)
| Error e -> Error e
| Ok (zone, _, _) ->
match check_zone zone with
| Error e -> Error e
| Ok (name, map) ->
(* we ended with `Soa, which checked that map contains a Soa *)
Ok (name, Rr_map.get Soa map)
let fold key (N (sub, map)) f s =
let get name map acc =
match Rr_map.find key map with
| Some a -> f name a acc
| None -> acc
in
let rec collect name sub acc =
List.fold_left (fun acc (pre, N (sub, map)) ->
let n' = Domain_name.prepend_label_exn name pre in
let keys = get n' map acc in
collect n' sub keys)
acc (M.bindings sub)
in
let name = Domain_name.root in
collect name sub (get name map s)
let collect_rrs name sub map =
let collect_map top name rrmap =
if not top && Rr_map.mem Ns rrmap then
(* delegation *)
let ns_entries =
Option.fold ~none:[]
~some:(fun ns -> [ name, Rr_map.B (Ns, ns) ])
(Rr_map.find Ns rrmap)
and ds_entries =
Option.fold ~none:[]
~some:(fun ds -> [ name, Rr_map.B (Ds, ds) ])
(Rr_map.find Ds rrmap)
and rrsig_entries =
Option.fold ~none:[]
~some:(fun rrsig -> [ name, Rr_map.B (Rrsig, rrsig) ])
(Rr_map.find Rrsig rrmap)
in
ns_entries @ ds_entries @ rrsig_entries, false
else
Rr_map.fold (fun v acc -> (name, v) :: acc) rrmap [], true
in
let rec go top name sub map =
let entries, recurse = collect_map top name map in
if recurse then
List.fold_left
(fun acc (pre, N (sub, map)) ->
acc @ go false (Domain_name.prepend_label_exn name pre) sub map)
entries (M.bindings sub)
else
entries
in
go true name sub map
let collect_entries name sub map =
let ttlsoa =
match Rr_map.find Soa map with
| Some v -> Some v
| None when Domain_name.count_labels name = 0 ->
Some { Soa.nameserver = Domain_name.root ;
hostmaster = Domain_name.root ;
serial = 0l ; refresh = 0l ; retry = 0l ;
expiry = 0l ; minimum = 0l }
| None -> None
in
match ttlsoa with
| None -> Error `NotAuthoritative
| Some soa ->
let entries = collect_rrs name sub (Rr_map.remove Soa map) in
let res =
List.fold_left (fun acc (name, (Rr_map.B (k, v))) ->
Name_rr_map.add name k v acc) Domain_name.Map.empty entries
in
Ok (soa, res)
let entries name t =
let name = Domain_name.raw name in
let* zone, sub, map = lookup_aux (Canonical.v name) t in
match zone with
| None -> Error `NotAuthoritative
| Some (`Delegation (name, (ttl, ns))) ->
Error (`Delegation (name, (ttl, ns)))
| Some (`Soa (name', _)) when Domain_name.equal name name' ->
collect_entries name sub map
| Some (`Soa (_, _)) -> Error `NotAuthoritative
type zone_check = [ `Missing_soa of [ `raw ] Domain_name.t
| `Cname_other of [ `raw ] Domain_name.t
| `Bad_ttl of [ `raw ] Domain_name.t * Rr_map.b
| `Empty of [ `raw ] Domain_name.t * Rr_map.k
| `Missing_address of [ `host ] Domain_name.t
| `Soa_not_a_host of [ `raw ] Domain_name.t * string ]
let pp_zone_check ppf = function
| `Missing_soa name -> Fmt.pf ppf "missing soa for %a" Domain_name.pp name
| `Cname_other name -> Fmt.pf ppf "%a contains a cname record, and also other entries" Domain_name.pp name
| `Bad_ttl (name, v) -> Fmt.pf ppf "bad TTL for %a %a" Domain_name.pp name Rr_map.pp_b v
| `Empty (name, typ) -> Fmt.pf ppf "%a empty %a" Domain_name.pp name Rr_map.ppk typ
| `Missing_address name -> Fmt.pf ppf "missing address record for %a" Domain_name.pp name
| `Soa_not_a_host (name, msg) -> Fmt.pf ppf "%a the SOA nameserver is not a hostname: %s" Domain_name.pp name msg
(* TODO: check for no cname loops? and dangling cname!? *)
let check trie =
let has_address name =
match lookup name Rr_map.A trie with
| Ok _ -> true
| Error (`Delegation _) -> true
| _ -> match lookup name Rr_map.Aaaa trie with
| Ok _ -> true
| _ -> false
in
let rec check_sub names state sub map =
let name = Domain_name.of_strings_exn names in
let state' =
match Rr_map.find Soa map with
| None -> begin match Rr_map.find Ns map with
| None -> state
| Some _ -> `None
end
| Some _ -> `Soa name
in
let* () =
guard ((Rr_map.mem Cname map && Rr_map.cardinal map = 1) ||
not (Rr_map.mem Cname map)) (`Cname_other name)
in
let* () =
Rr_map.fold (fun v r ->
let* () = r in
match v with
| B (Dnskey, (ttl, keys)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Dnskey_set.is_empty keys then
Error (`Empty (name, Rr_map.K Dnskey))
else Ok ()
| B (Ns, (ttl, names)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Domain_name.Host_set.is_empty names then
Error (`Empty (name, K Ns))
else
let domain = match state' with `None -> name | `Soa zone -> zone in
Domain_name.Host_set.fold (fun name r ->
let* () = r in
if Domain_name.is_subdomain ~subdomain:name ~domain then
guard (has_address name) (`Missing_address name)
else
Ok ()) names (Ok ())
| B (Cname, (ttl, _)) ->
if ttl < 0l then Error (`Bad_ttl (name, v)) else Ok ()
| B (Mx, (ttl, mxs)) ->
if ttl < 0l then
Error (`Bad_ttl (name, v))
else if Rr_map.Mx_set.is_empty mxs then
Error (`Empty (name, K Mx))
else
let domain = match state' with `None -> name | `Soa zone -> zone in
Rr_map.Mx_set.fold (fun { mail_exchange ; _ } r ->
let* () = r in
if Domain_name.is_subdomain ~subdomain:mail_exchange ~domain then
guard (has_address mail_exchange) (`Missing_address mail_exchange)
else
Ok ())
mxs (Ok ())
| B (Ptr, (ttl, name)) ->
if ttl < 0l then Error (`Bad_ttl (Domain_name.raw name, v)) else Ok ()
| B (Soa, soa) ->
begin match Domain_name.host soa.nameserver with
| Error (`Msg m) -> Error (`Soa_not_a_host (soa.nameserver, m))
| Ok _ -> Ok ()
end
| B (Txt, (ttl, txts)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Txt_set.is_empty txts then
Error (`Empty (name, K Txt))
else if
Rr_map.Txt_set.exists (fun s -> String.length s > 0) txts
then
Ok ()
else
Error (`Empty (name, K Txt))
| B (A, (ttl, a)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Ipaddr.V4.Set.is_empty a then
Error (`Empty (name, K A))
else Ok ()
| B (Aaaa, (ttl, aaaa)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Ipaddr.V6.Set.is_empty aaaa then
Error (`Empty (name, K Aaaa))
else Ok ()
| B (Srv, (ttl, srvs)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Srv_set.is_empty srvs then
Error (`Empty (name, K Srv))
else Ok ()
| B (Svcb, (ttl, svcbs)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Svcb_set.is_empty svcbs then
Error (`Empty (name, K Svcb))
else Ok ()
| B (Https, (ttl, httpss)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Https_set.is_empty httpss then
Error (`Empty (name, K Https))
else Ok ()
| B (Caa, (ttl, caas)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Caa_set.is_empty caas then
Error (`Empty (name, K Caa))
else Ok ()
| B (Tlsa, (ttl, tlsas)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Tlsa_set.is_empty tlsas then
Error (`Empty (name, K Tlsa))
else Ok ()
| B (Sshfp, (ttl, sshfps)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Sshfp_set.is_empty sshfps then
Error (`Empty (name, K Sshfp))
else Ok ()
| B (Ds, (ttl, ds)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Ds_set.is_empty ds then
Error (`Empty (name, K Ds))
else Ok ()
| B (Rrsig, (ttl, rrs)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Rrsig_set.is_empty rrs then
Error (`Empty (name, K Rrsig))
else Ok ()
| B (Nsec, (ttl, _rr)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else Ok ()
| B (Nsec3, (ttl, _rr)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else Ok ()
| B (Loc, (ttl, locs)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Loc_set.is_empty locs then
Error (`Empty (name, Rr_map.K Loc))
else Ok ()
| B (Null, (ttl, nulls)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Null_set.is_empty nulls then
Error (`Empty (name, Rr_map.K Null))
else Ok ()
| B (Unknown x, (ttl, datas)) ->
if ttl < 0l then Error (`Bad_ttl (name, v))
else if Rr_map.Txt_set.is_empty datas then
Error (`Empty (name, K (Unknown x)))
else Ok ())
map (Ok ())
in
M.fold (fun lbl (N (sub, map)) r ->
let* () = r in
check_sub (lbl :: names) state' sub map) sub (Ok ())
in
let (N (sub, map)) = trie in
check_sub [] `None sub map
let find f name t =
let name = Canonical.d name in
let lbls = Domain_name.to_array name in
let l = Array.length lbls in
let rec go idx (N (sub, map)) =
if idx = l then
let sub', map' = f sub map in
N (sub', map')
else
let lbl = Array.get lbls idx in
let node = match M.find lbl sub with
| exception Not_found -> empty
| x -> x
in
let node' = go (succ idx) node in
if is_empty node' then
N (M.remove lbl sub, map)
else
N (M.add lbl node' sub, map)
in
go 0 t
let replace name k v t =
find (fun sub map -> sub, Rr_map.add k v map) (Canonical.v name) t
let insert name k v t =
let name = Canonical.v name in
let merge sub map =
let new_v = match Rr_map.find k map with
| None -> v
| Some v' -> Rr_map.union_rr k v' v
in
sub, Rr_map.add k new_v map
in
find merge name t
let replace_map m t =
Domain_name.Map.fold (fun name map trie ->
find (fun sub _ -> sub, map) (Canonical.v name) trie) m t
let insert_map m t =
Domain_name.Map.fold (fun name map trie ->
let union sub old = sub, Rr_map.union { f = Rr_map.unionee } old map in
find union (Canonical.v name) trie)
m t
let remove k ty v t =
let remove sub map =
let map' = match Rr_map.find ty map with
| None -> map
| Some old -> match Rr_map.remove_rr ty old v with
| None -> Rr_map.remove ty map
| Some v' -> Rr_map.add ty v' map
in
sub, map'
in
find remove (Canonical.v k) t
let remove_ty k ty t =
let remove sub map = sub, Rr_map.remove ty map in
find remove (Canonical.v k) t
let remove_all k t =
let remove sub _ = sub, Rr_map.empty in
find remove (Canonical.v k) t
let remove_map m t =
let merge k present remove = match present, remove with
| None, None -> None
| Some x, None -> Some x
| None, Some _ -> None
| Some x, Some y -> Rr_map.remove_rr k x y
in
Domain_name.Map.fold (fun name map trie ->
let remove sub old = sub, Rr_map.merge { f = merge } old map in
find remove (Canonical.v name) trie)
m t
let remove_zone name t =
let remove sub _ =
(* go through all of sub, and retain those subtrees with Soa *)
let rec fold_sub sub =
M.fold (fun lbl node acc ->
match go node with None -> acc | Some n -> M.add lbl n acc)
sub M.empty
and go (N (sub, map)) =
match Rr_map.find Soa map with
| None ->
(* no SOA, continue search *)
let sub' = fold_sub sub in
if M.is_empty sub' then None else Some (N (sub', Rr_map.empty))
| Some _ ->
(* SOA, retain this submap *)
Some (N (sub, map))
in
fold_sub sub, Rr_map.empty (* drop the initial RRmap in any case! *)
in
find remove (Canonical.v name) t
let diff zone req_soa ~old current =
match entries zone current with
| Error _ -> Error (`Msg "couldn't find zone in current trie")
| Ok (soa, map) ->
if not (Soa.newer ~old:req_soa soa) then
Ok (soa, `Empty)
else
match entries zone old with
| Error _ -> Ok (soa, `Full map)
| Ok (oldsoa, oldmap) ->
(* first, we fold over old map and collect the differences in two maps *)
let (to_remove, to_add), names =
Domain_name.Map.fold (fun name old ((to_remove, to_add), names) ->
let newmap =
match Domain_name.Map.find name map with
| None -> Rr_map.empty | Some x -> x
in
(match Rr_map.diff ~old newmap with
| None, None -> to_remove, to_add
| Some rm, None -> Domain_name.Map.add name rm to_remove, to_add
| None, Some add -> to_remove, Domain_name.Map.add name add to_add
| Some rm, Some add ->
Domain_name.Map.add name rm to_remove,
Domain_name.Map.add name add to_add),
Domain_name.Set.add name names)
oldmap Domain_name.((Map.empty, Map.empty), Set.empty)
in
(* now we fold over newmap and add then unless already handled *)
let to_add =
Domain_name.Map.fold (fun name newmap to_add ->
if Domain_name.Set.mem name names then
to_add
else
Domain_name.Map.add name newmap to_add)
map to_add
in
Ok (soa, `Difference (oldsoa, to_remove, to_add))

140
unikernel/duniverse/ocaml-dns/server/dns_trie.mli Normal file
View file

@ -0,0 +1,140 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
(** Prefix tree data structure for domain names
The key is a {!Domain_name}, whereas the value may be any resource record.
The representation is a tree, where the edges are domain name labels, and
the nodes carry a {{!Dns.Rr_map.t}resource map}.
Some special treatment is applied for zones, which must have a start of
authority entry and a set of name servers. End of authority, also known as
delegation, is supported. Aliases (canonical names, CNAME records) are also
supported.
The data structure tries to preserve invariants recommended by the domain
name system, such as that for any name there may either be an alias or any
other record, there must be a SOA record, and multiple NS records for an
authoritative zone, a resource type must have entries of the given type (no
NS record for A type, the ttl for all resource records of a rrset is the
same.
*)
open Dns
(** {2 Abstract trie type} *)
type t
(** The type of the trie. *)
val pp : t Fmt.t
(** [pp ppf t] pretty prints [t] to [ppf]. *)
val empty : t
(** [empty] is the empty trie. *)
val equal : t -> t -> bool
(** [equal a b] compares [a] with [b]. *)
(** {2 Operations to modify the trie} *)
val insert_map : Rr_map.t Domain_name.Map.t -> t -> t
(** [insert_map m t] inserts all elements of the domain name map [m] into
[t], potentially existing are unioned with {!Dns.Rr_map.unionee}. *)
val replace_map : Rr_map.t Domain_name.Map.t -> t -> t
(** [replace_map m t] replaces in the trie [t] all existing bindings of the
domain name map [m] with the provided map. *)
val remove_map : Rr_map.t Domain_name.Map.t -> t -> t
(** [remove_map m t] removes all elements of the domain name map [m] from
[t]. *)
val insert : 'a Domain_name.t -> 'b Rr_map.key -> 'b -> t -> t
(** [insert n k v t] inserts [k, v] under [n] in [t]. Existing entries are
unioneed with {!Dns.Rr_map.union_rr}. *)
val replace : 'a Domain_name.t -> 'b Rr_map.key -> 'b -> t -> t
(** [replace n k v t] inserts [k, v] under [n] in [t]. Existing entries are
replaced. *)
val remove : 'a Domain_name.t -> 'b Rr_map.key -> 'b -> t -> t
(** [remove k ty v t] removes [ty, v] from [t] at [k]. Beware, this may lead
to a [t] where the initially mentioned invariants are violated. *)
val remove_ty : 'a Domain_name.t -> 'b Rr_map.key -> t -> t
(** [remove_ty k ty t] removes [ty] from [t] at [k]. Beware, this may lead to a
[t] where the initially mentioned invariants are violated. *)
val remove_all : 'a Domain_name.t -> t -> t
(** [remove_all k t] removes all entries of [k] in [t]. Beware, this may lead to
a [t] where the initially mentioned invariants are violated. *)
val remove_zone : 'a Domain_name.t -> t -> t
(** [remove_zone name t] remove the zone [name] from [t], retaining subzones
(entries with [Soa] records). This removes as well any delegations. *)
(** {2 Checking invariants} *)
type zone_check = [ `Missing_soa of [ `raw ] Domain_name.t
| `Cname_other of [ `raw ] Domain_name.t
| `Bad_ttl of [ `raw ] Domain_name.t * Rr_map.b
| `Empty of [ `raw ] Domain_name.t * Rr_map.k
| `Missing_address of [ `host ] Domain_name.t
| `Soa_not_a_host of [ `raw ] Domain_name.t * string ]
val pp_zone_check : zone_check Fmt.t
(** [pp_err ppf err] pretty prints the error [err]. *)
val check : t -> (unit, zone_check) result
(** [check t] checks all invariants. *)
(** {2 Lookup} *)
type e = [ `Delegation of [ `raw ] Domain_name.t * (int32 * Domain_name.Host_set.t)
| `EmptyNonTerminal of [ `raw ] Domain_name.t * Soa.t
| `NotAuthoritative
| `NotFound of [ `raw ] Domain_name.t * Soa.t ]
(** The type of lookup errors. *)
val pp_e : e Fmt.t
(** [pp_e ppf e] pretty-prints [e] on [ppf]. *)
val zone : 'a Domain_name.t -> t ->
([ `raw ] Domain_name.t * Soa.t, e) result
(** [zone k t] returns either the zone and soa for [k] in [t], or an error. *)
val lookup_with_cname : 'a Domain_name.t -> 'b Rr_map.key -> t ->
(Rr_map.b * ([ `raw ] Domain_name.t * int32 * Domain_name.Host_set.t), e) result
(** [lookup_with_cname k ty t] finds [k, ty] in [t]. It either returns the found
resource record set and authority information, a cname alias and authority
information, or an error. *)
val lookup : 'a Domain_name.t -> 'b Rr_map.key -> t -> ('b, e) result
(** [lookup k ty t] finds [k, ty] in [t], which may lead to an error. *)
val lookup_any : 'a Domain_name.t -> t ->
(Rr_map.t * ([ `raw ] Domain_name.t * int32 * Domain_name.Host_set.t), e) result
(** [lookup_any k t] looks up all resource records of [k] in [t], and returns
that and the authority information. *)
val lookup_glue : 'a Domain_name.t -> t ->
(int32 * Ipaddr.V4.Set.t) option * (int32 * Ipaddr.V6.Set.t) option
(** [lookup_glue k t] finds glue records (A, AAAA) for [k] in [t]. It ignores
potential DNS invariants, e.g. that there is no surrounding zone. *)
val entries : 'a Domain_name.t -> t ->
(Dns.Soa.t * Rr_map.t Domain_name.Map.t, e) result
(** [entries name t] returns either the SOA and all entries for the requested
[name], or an error. *)
val fold : 'a Rr_map.key -> t -> ([ `raw ] Domain_name.t -> 'a -> 'b -> 'b) -> 'b -> 'b
(** [fold key t f acc] calls [f] with [dname value acc] element in [t]. *)
val diff : 'a Domain_name.t -> Soa.t -> old:t -> t ->
(Soa.t * [ `Empty | `Full of Name_rr_map.t | `Difference of Soa.t * Name_rr_map.t * Name_rr_map.t ],
[> `Msg of string ]) result
(** [diff zone soa ~old trie] computes the difference of [zone] in [old] and
[trie], and returns either [`Empty] if [soa] is equal or newer than the one
in [trie], [`Full] (the same as [entries]) if [zone] is not present in [old],
or [`Difference (old_soa, deleted, added)]. Best used with IXFR. An error
occurs if [zone] is not present in [trie]. *)

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

@ -0,0 +1,5 @@
(library
(name dns_server)
(public_name dns-server)
(wrapped false)
(libraries dns randomconv duration metrics))

5928
unikernel/duniverse/ocaml-dns/src/dns.ml Normal file
View file

File diff suppressed because it is too large Load diff

1464
unikernel/duniverse/ocaml-dns/src/dns.mli Normal file
View file

File diff suppressed because it is too large Load diff

8
unikernel/duniverse/ocaml-dns/src/dune Normal file
View file

@ -0,0 +1,8 @@
(library
(name dns)
(public_name dns)
(wrapped false)
(libraries fmt ipaddr logs ptime gmap domain-name metrics base64 ohex)
; (preprocess (pps ppx_expect)) ; once https://github.com/ocaml/dune/issues/897 is resolved
; (inline_tests)
)

201
unikernel/duniverse/ocaml-dns/test/cache.ml Normal file
View file

@ -0,0 +1,201 @@
open Dns
let ip = Ipaddr.V4.of_string_exn
let name = Domain_name.of_string_exn
let invalid_soa name =
let p pre =
Domain_name.(prepend_label_exn name "invalid" |> fun n -> prepend_label_exn n pre)
in
{
Soa.nameserver = p "ns" ; hostmaster = p "hostmaster" ;
serial = 1l ; refresh = 16384l ; retry = 2048l ;
expiry = 1048576l ; minimum = 300l
}
let cached_err =
let module M = struct
type t = [ `Cache_miss | `Cache_drop ]
let pp ppf = function
| `Cache_miss -> Fmt.string ppf "cache miss"
| `Cache_drop -> Fmt.string ppf "cache drop"
let equal a b = match a, b with
| `Cache_miss, `Cache_miss -> true
| `Cache_drop, `Cache_drop -> true
| _ -> false
end in
(module M: Alcotest.TESTABLE with type t = M.t)
let entry_eq t a b =
match a, b with
| `Entry b, `Entry b' -> Rr_map.equal_rr t b b'
| `No_data (name, soa), `No_data (name', soa') -> Domain_name.equal name name' && Dns.Soa.compare soa soa' = 0
| `No_domain (name, soa), `No_domain (name', soa') -> Domain_name.equal name name' && Dns.Soa.compare soa soa' = 0
| `Serv_fail (name, soa), `Serv_fail (name', soa') -> Domain_name.equal name name' && Dns.Soa.compare soa soa' = 0
| _, _ -> false
let cached_ok (t : 'a Rr_map.key) =
let pp ppf res = Dns_cache.pp_entry t ppf (fst res)
and equal (r, rank) (r', rank') =
entry_eq t r r' && Dns_cache.compare_rank rank rank' = 0
in
Alcotest.testable pp equal
let cached_r t = Alcotest.(result (cached_ok t) cached_err)
let empty_cache () =
let cache = Dns_cache.empty 100 in
Alcotest.check (cached_r Rr_map.A) "empty cache results in Cache_miss"
(Error `Cache_miss)
(snd (Dns_cache.get cache 0L (name "an-actual-website.com") A))
let cache_a () =
let cache = Dns_cache.empty 100 in
let name = name "an-actual-website.com" in
let a = 250l, Ipaddr.V4.Set.singleton (ip "1.2.3.4") in
let cache = Dns_cache.set cache 0L name A (AuthoritativeAnswer None) (`Entry a) in
Alcotest.check (cached_r Rr_map.A) "cache with A results in res"
(Ok (`Entry a, AuthoritativeAnswer None))
(snd (Dns_cache.get cache 0L name A)) ;
Alcotest.check (cached_r Rr_map.Cname) "cache with A results in CacheMiss"
(Error `Cache_miss) (snd (Dns_cache.get cache 0L name Cname))
let cache_nodata () =
let cache = Dns_cache.empty 100 in
let name = name "an-alias.com"
and subname = name "another-domain.an-alias.com"
in
let soa = invalid_soa name in
let nodata = `No_data (subname, soa) in
let a = 250l, Ipaddr.V4.Set.singleton (ip "1.2.3.4") in
let cache = Dns_cache.set cache 0L name A (AuthoritativeAnswer None) (`Entry a) in
let cache = Dns_cache.set cache 0L subname A (AuthoritativeAnswer None) nodata in
Alcotest.check (cached_r Rr_map.A) "cache with A nodata results in nodata"
(Ok (nodata, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L subname A)) ;
Alcotest.check (cached_r Rr_map.Ns) "cache with A nodata results in cache miss for NS"
(Error `Cache_miss) (snd (Dns_cache.get cache 0L subname Ns)) ;
Alcotest.check (cached_r Rr_map.A) "cache with A nodata results in a record"
(Ok (`Entry a, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L name A)) ;
Alcotest.check (cached_r Rr_map.Ns) "cache with A nodata results in cache miss for NS'"
(Error `Cache_miss) (snd (Dns_cache.get cache 0L name Ns)) ;
let cache = Dns_cache.set cache 0L subname A (AuthoritativeAnswer None) (`Entry a) in
Alcotest.check (cached_r Rr_map.A) "cache with A nodata results in nodata"
(Ok (`Entry a, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L subname A))
let cache_nodom () =
let cache = Dns_cache.empty 100 in
let name = name "an-alias.com"
and subname = name "another-domain.an-alias.com"
and subsubname = name "fo.another-domain.an-alias.com"
in
let soa = invalid_soa name in
let nodom = `No_domain (subname, soa) in
let a = 250l, Ipaddr.V4.Set.singleton (ip "1.2.3.4") in
let cache = Dns_cache.set cache 0L name A (AuthoritativeAnswer None) (`Entry a) in
let cache = Dns_cache.set cache 0L subname A (AuthoritativeAnswer None) nodom in
Alcotest.check (cached_r Rr_map.A) "cache with A nodom results in nodom"
(Ok (nodom, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L subname A)) ;
Alcotest.check (cached_r Rr_map.Ns) "cache with A nodom results in nodom for NS"
(Ok (nodom, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L subname Ns)) ;
Alcotest.check (cached_r Rr_map.Ns) "cache with A nodom results in nodom for Ns and subsub"
(Ok (nodom, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L subsubname Ns)) ;
Alcotest.check (cached_r Rr_map.A) "cache with A nodom results in nodom for A and subsub"
(Ok (nodom, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L subsubname A)) ;
Alcotest.check (cached_r Rr_map.A) "cache with A nodom results in a record"
(Ok (`Entry a, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L name A)) ;
Alcotest.check (cached_r Rr_map.Ns) "cache with A nodom results in cache miss for NS'"
(Error `Cache_miss) (snd (Dns_cache.get cache 0L name Ns)) ;
let cache = Dns_cache.set cache 0L subname A (AuthoritativeAnswer None) (`Entry a) in
Alcotest.check (cached_r Rr_map.A) "cache with A nodata results in nodom"
(Ok (`Entry a, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L subname A))
let cache_tests = [
"empty cache", `Quick, empty_cache ;
"cache with A", `Quick, cache_a ;
"cache nodata", `Quick, cache_nodata ;
"cache nodom", `Quick, cache_nodom ;
]
let entry_or_cname t a b = match a, b with
| (`Alias (ttl, name), r),
(`Alias (ttl', name'), r') ->
ttl = ttl' && Domain_name.equal name name' && Dns_cache.compare_rank r r' = 0
| (#Dns_cache.entry as e1, r1), (#Dns_cache.entry as e2, r2) ->
entry_eq t e1 e2 && Dns_cache.compare_rank r1 r2 = 0
| _ -> false
let pp_or_cname t ppf = function
| `Alias (ttl, name), _ -> Fmt.pf ppf "alias %lu %a" ttl Domain_name.pp name
| #Dns_cache.entry as e, _ -> Dns_cache.pp_entry t ppf e
let cname_or_cached t =
Alcotest.testable (pp_or_cname t) (entry_or_cname t)
let cached_cname_r t = Alcotest.result (cname_or_cached t) cached_err
let empty = Dns_cache.empty 100
let cname_empty_cache () =
Alcotest.check (cached_cname_r Rr_map.A) "empty cache results in Cache_miss"
(Error `Cache_miss)
(snd (Dns_cache.get_or_cname empty 0L (name "foo.com") A))
let cname_cache_a () =
let name = name "foo.com" in
let a = 250l, Ipaddr.V4.Set.singleton (ip "1.2.3.4") in
let cache = Dns_cache.set empty 0L name A (AuthoritativeAnswer None) (`Entry a) in
Alcotest.check (cached_cname_r Rr_map.A) "cache with A results in res"
(Ok (`Entry a, AuthoritativeAnswer None))
(snd (Dns_cache.get_or_cname cache 0L name A)) ;
Alcotest.check (cached_cname_r Rr_map.Cname) "cache with A results in CacheMiss"
(Error `Cache_miss)
(snd (Dns_cache.get_or_cname cache 0L name Cname))
let cname_cache_cname () =
let rel = name "bar.com" in
let name = name "foo.com" in
let cname = 250l, rel in
let cache = Dns_cache.set empty 0L name Cname (AuthoritativeAnswer None) (`Entry cname) in
Alcotest.check (cached_cname_r Rr_map.Cname) "cache with CNAME results in res"
(Ok (`Alias cname, AuthoritativeAnswer None))
(snd (Dns_cache.get_or_cname cache 0L name Cname)) ;
Alcotest.check (cached_cname_r Rr_map.A) "cache with CNAME results in res for A"
(Ok (`Alias cname, AuthoritativeAnswer None))
(snd (Dns_cache.get_or_cname cache 0L name A)) ;
Alcotest.check (cached_cname_r Rr_map.Ns) "cache with CNAME results in res for NS"
(Ok (`Alias cname, AuthoritativeAnswer None))
(snd (Dns_cache.get_or_cname cache 0L name Ns))
let cname_cache_cname_nodata () =
let rel = name "bar.com" in
let name = name "foo.com" in
let cname = 250l, rel in
let bad_soa = invalid_soa name in
let cache =
Dns_cache.set
(Dns_cache.set empty 0L name Cname (AuthoritativeAnswer None) (`Entry cname))
0L name Ns (AuthoritativeAnswer None) (`No_data (name, bad_soa))
in
Alcotest.check (cached_cname_r Rr_map.Cname) "cache with CNAME results in res"
(Ok (`Alias cname, AuthoritativeAnswer None))
(snd (Dns_cache.get_or_cname cache 0L name Cname)) ;
Alcotest.check (cached_cname_r Rr_map.Ns) "cache with CNAME results in res for NS"
(Ok (`Alias cname, AuthoritativeAnswer None))
(snd (Dns_cache.get_or_cname cache 0L name Ns)) ;
Alcotest.check (cached_cname_r Rr_map.A) "cache with CNAME results in res for A"
(Ok (`Alias cname, AuthoritativeAnswer None))
(snd (Dns_cache.get_or_cname cache 0L name A))
let cname_cache_tests = [
"empty cache", `Quick, cname_empty_cache ;
"cache with A", `Quick, cname_cache_a ;
"cache with CNAME", `Quick, cname_cache_cname ;
"cache with another cname", `Quick, cname_cache_cname_nodata ;
]
let tests = [
"cache tests", cache_tests;
"cname cache tests", cname_cache_tests;
]
let () = Alcotest.run "DNS cache tests" tests

328
unikernel/duniverse/ocaml-dns/test/client.ml Normal file
View file

@ -0,0 +1,328 @@
let ip =
let module M = struct
type t = Ipaddr.V4.t
let pp = Ipaddr.V4.pp
let equal a b = Ipaddr.V4.compare a b = 0
end in
(module M : Alcotest.TESTABLE with type t = M.t)
let ipset = Alcotest.(slist ip Ipaddr.V4.compare)
let p_cs = Alcotest.testable (Ohex.pp_hexdump ()) String.equal
module Make_query_tests = struct
let produces_same_output () =
let rng n = String.make n '\x00' in
let name:'a Domain_name.t = Domain_name.of_string_exn "example.com" in
let actual, _state = Dns_client.Pure.make_query rng `Tcp `Auto name Dns.Rr_map.A in
let expected = Ohex.decode
"00 2e 00 00 01 00 00 01 00 00 00 00 00 01 07 65
78 61 6d 70 6c 65 03 63 6f 6d 00 00 01 00 01 00
00 29 02 00 00 00 00 00 00 06 00 0b 00 02 04 b0" in
Alcotest.check p_cs "produces cool stuff" expected actual
let tests = [
"produces same output", `Quick, produces_same_output;
"fails on unspported query_type", `Quick, produces_same_output;
]
end
module Parse_response_tests = struct
let unpacks_response () =
(* Bytes 3, 4 are set to `00 00` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 00 00 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
(* This `rng` generates zeros, used for the query ID above *)
let rng n = String.make n '\x00' in
let name:'a Domain_name.t = Domain_name.of_string_exn "foo.com" in
let _actual, state = Dns_client.Pure.make_query rng `Tcp `Auto name Dns.Rr_map.A in
match Dns_client.Pure.handle_response state ipv4_buf with
| Ok `Data _ -> () (* TODO: Alcotest TESTABLE for this return value *)
| _ -> ignore(failwith "error")
let fails_to_unpack_mismatched () =
(* TODO: It is possible to use crowbar here, to generate the ipv4_buf *)
(* Bytes 3, 4 are set to `aa aa` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 aa aa 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
(* This `rng` generates zeros, used for the query ID above *)
let rng n = String.make n '\x00' in
let name:'a Domain_name.t = Domain_name.of_string_exn "foo.com" in
let _actual, state = Dns_client.Pure.make_query rng `Tcp `Auto name Dns.Rr_map.A in
match Dns_client.Pure.parse_response state ipv4_buf with
| Error `Msg _ -> ()
| __ -> failwith "should have rejected mismatched input"
(* TODO: Alcotest TESTABLE for this return value *)
let tests = [
"unpacks some kind of response", `Quick, unpacks_response;
"fails to unpack response with mismatching query ID", `Quick, fails_to_unpack_mismatched;
]
end
(* {!Transport} provides a mock implementation of the transport used by
Dns_client.Make. The mock data uses the default_debug_info reference cell.
*)
type debug_info = string
let default_debug_info = ref []
module Transport (*: Dns_client.S
with type io_addr = debug_info
and type stack = unit
and type +'a io = 'a *)
= struct
type io_addr = debug_info
type stack = Dns.proto
type context = debug_info list ref
type t = Dns.proto
type +'a io = 'a
let create ?nameservers:_ ~timeout:_ proto = proto
let nameservers proto = proto, !default_debug_info
let rng n = String.make n '\x00'
let clock () = 0L
let bind a b = b a
let lift v = v
let close _ = ()
let connect a = Ok (a, default_debug_info)
let send_recv (mock_responses : context) _ =
match !mock_responses with
| [] -> failwith("nothing to recv from the wire")
| hd::tail -> mock_responses := tail; Ok hd
end
(* Now that we have our {!Transport} implementation we can include the logic
that goes on top of it: *)
include Dns_client.Make(Transport)
module Transport_with_time_machine = struct
include Transport
(* the timestamps are for: cache lookup1, cache upate, cache lookup2, cache update2 *)
let timestamps = ref [0L; 0L; Duration.of_sec 601 ; Duration.of_sec 601]
let clock () =
match !timestamps with
| [] -> assert false
| head::tail -> timestamps := tail; head
end
module Dns_client_with_time_machine = Dns_client.Make(Transport_with_time_machine)
module Gethostbyname_tests = struct
let foo_com_is_valid () =
let domain_name = Domain_name.(of_string_exn "foo.com" |> host_exn) in
(* Bytes 3, 4 are set to `00 00` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 00 00 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
let t = create `Tcp in
default_debug_info := [ipv4_buf];
match gethostbyname t domain_name with
| Ok _ip -> ()
| Error _ -> failwith "foo.com should have been returned"
let returns_from_the_cache () =
let domain_name = Domain_name.(of_string_exn "foo.com" |> host_exn) in
(* Bytes 3, 4 are set to `00 00` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 00 00 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
let t = create `Tcp in
default_debug_info := [ipv4_buf];
match gethostbyname t domain_name with
| Error _ -> failwith "foo.com should have been returned"
| Ok _ip ->
default_debug_info := [];
match gethostbyname t domain_name with
| Error _ -> failwith "should have been cached"
| Ok _ -> () (* we returned content, but the wire stayed silent *)
let uses_network_when_cache_evicted () =
let domain_name = Domain_name.(of_string_exn "foo.com" |> host_exn) in
(* Bytes 3, 4 are set to `00 00` - these represent query ID *)
let ipv4_buf = Ohex.decode
"00 77 00 00 81 80 00 01 00 01 00 02 00 02 03 66
6f 6f 03 63 6f 6d 00 00 01 00 01 c0 0c 00 01 00
01 00 00 02 2a 00 04 17 17 56 2c c0 0c 00 02 00
01 00 01 87 ae 00 10 03 6e 73 31 09 64 69 67 69
6d 65 64 69 61 c0 10 c0 0c 00 02 00 01 00 01 87
ae 00 06 03 6e 73 32 c0 39 c0 35 00 01 00 01 00
02 40 8a 00 04 17 15 f2 58 c0 51 00 01 00 01 00
02 40 8a 00 04 17 15 f3 77" in
let t = Dns_client_with_time_machine.create `Tcp in
default_debug_info := [ipv4_buf];
match Dns_client_with_time_machine.gethostbyname t domain_name with
| Error _ -> failwith "foo.com should have been returned"
| Ok _ip ->
default_debug_info := [ipv4_buf];
match Dns_client_with_time_machine.gethostbyname t domain_name with
| Error _ -> failwith "should have been cached"
| Ok _ -> (* we returned content, AND the wire was used *)
assert (!default_debug_info = [])
let tests = [
"foo.com is valid", `Quick, foo_com_is_valid;
"when cache is populated, return from cache", `Quick, returns_from_the_cache;
"when content evicted, use network", `Quick, uses_network_when_cache_evicted;
]
end
module Getaddrinfo_tests = struct
let supports_mx_packets () =
let domain_name = Domain_name.(of_string_exn "google.com" |> host_exn) in
(* a google.com MX record - bytes 3,4 are set to the query ID 00 00 *)
let ipv4_buf = Ohex.decode
"02 1e 00 00 81 80 00 01 00 05 00 04 00 0f 06 67
6f 6f 67 6c 65 03 63 6f 6d 00 00 0f 00 01 c0 0c
00 0f 00 01 00 00 02 58 00 11 00 1e 04 61 6c 74
32 05 61 73 70 6d 78 01 6c c0 0c c0 0c 00 0f 00
01 00 00 02 58 00 04 00 0a c0 2f c0 0c 00 0f 00
01 00 00 02 58 00 09 00 28 04 61 6c 74 33 c0 2f
c0 0c 00 0f 00 01 00 00 02 58 00 09 00 14 04 61
6c 74 31 c0 2f c0 0c 00 0f 00 01 00 00 02 58 00
09 00 32 04 61 6c 74 34 c0 2f c0 0c 00 02 00 01
00 00 ad 8c 00 06 03 6e 73 31 c0 0c c0 0c 00 02
00 01 00 00 ad 8c 00 06 03 6e 73 34 c0 0c c0 0c
00 02 00 01 00 00 ad 8c 00 06 03 6e 73 33 c0 0c
c0 0c 00 02 00 01 00 00 ad 8c 00 06 03 6e 73 32
c0 0c c0 2f 00 01 00 01 00 00 00 e0 00 04 6c b1
77 1b c0 6c 00 01 00 01 00 00 00 0d 00 04 ac d9
c2 1b 04 41 4c 54 32 c0 2f 00 01 00 01 00 00 00
0d 00 04 6c b1 61 1b c0 81 00 01 00 01 00 00 00
e0 00 04 6c b1 08 1a c0 94 00 01 00 01 00 03 8b
b6 00 04 d8 ef 20 0a c0 ca 00 01 00 01 00 03 8f
54 00 04 d8 ef 22 0a c0 b8 00 01 00 01 00 03 8b
b6 00 04 d8 ef 24 0a c0 a6 00 01 00 01 00 03 97
5d 00 04 d8 ef 26 0a c0 2f 00 1c 00 01 00 00 00
f9 00 10 2a 00 14 50 40 13 0c 01 00 00 00 00 00
00 00 1b c0 6c 00 1c 00 01 00 00 00 f9 00 10 24
04 68 00 40 03 0c 04 00 00 00 00 00 00 00 1b 04
41 4c 54 33 c0 2f 00 1c 00 01 00 00 01 1b 00 10
26 07 f8 b0 40 0e 0c 00 00 00 00 00 00 00 00 1b
c0 94 00 1c 00 01 00 02 64 96 00 10 20 01 48 60
48 02 00 32 00 00 00 00 00 00 00 0a c0 ca 00 1c
00 01 00 04 54 3a 00 10 20 01 48 60 48 02 00 34
00 00 00 00 00 00 00 0a c0 b8 00 1c 00 01 00 01
79 ea 00 10 20 01 48 60 48 02 00 36 00 00 00 00
00 00 00 0a c0 a6 00 1c 00 01 00 01 d1 ba 00 10
20 01 48 60 48 02 00 38 00 00 00 00 00 00 00 0a" in
let mock_state = create `Tcp in
default_debug_info := [ipv4_buf];
match getaddrinfo mock_state Dns.Rr_map.Mx domain_name with
| Ok (_ttl, mx_set) ->
let make_mx_record (preference, domain_name) =
Dns.Mx.{
preference;
mail_exchange = Domain_name.host_exn (Domain_name.of_string_exn domain_name)
} in
(* assert this is Google MX *)
Alcotest.(check bool __LOC__ true (Dns.Rr_map.Mx_set.equal mx_set
(Dns.Rr_map.Mx_set.of_list
(List.map make_mx_record [
(10, "aspmx.l.google.com");
(20, "alt1.aspmx.l.google.com");
(30, "alt2.aspmx.l.google.com");
(40, "alt3.aspmx.l.google.com");
(50, "alt4.aspmx.l.google.com")
]))))
| Error _ -> failwith "foo.com should have been returned"
let fails_on_partial_udp_packet () =
let domain_name = Domain_name.(of_string_exn "google.com" |> host_exn) in
(* A partial google.com MX record
first two bytes identify this as a TCP packet - dropped here
bytes 3,4 are set to the query ID 00 00
*)
let udp_buf = Ohex.decode
" 00 00 81 80 00 01 00 05 00 04 00 0f 06 67
6f 6f 67 6c 65 03 63 6f " in
let mock_state = create `Udp in
default_debug_info := [udp_buf];
match getaddrinfo mock_state Dns.Rr_map.Mx domain_name with
| Error `Msg actual ->
let expected = "Truncated UDP response" in
Alcotest.(check string "reports the truncated UDP packet failure" expected actual)
| Ok (_, _) -> failwith "Should have reported the Truncated UDP packet"
let cname_and_nodata_packet () =
(* we request a non-existing record type of existing domain name, which is
an alias - the reply is a CNAME with NoData *)
(* concretely, requesting AAAA raw.githubusercontent.com, reply is
AN: raw.githubusercontent.com CNAME github.map.fastly.net
AU: SOA fastly.net *)
let domain_name =
Domain_name.(of_string_exn "raw.githubusercontent.com" |> host_exn)
in
let udp_buf = Ohex.decode {|
00 00 81 80 00 01 00 01 00 01 00 00 03 72
61 77 11 67 69 74 68 75 62 75 73 65 72 63 6f 6e
74 65 6e 74 03 63 6f 6d 00 00 1c 00 01 c0 0c 00
05 00 01 00 00 00 16 00 17 06 67 69 74 68 75 62
03 6d 61 70 06 66 61 73 74 6c 79 03 6e 65 74 00
c0 42 00 06 00 01 00 00 00 14 00 2e 03 6e 73 31
c0 42 0a 68 6f 73 74 6d 61 73 74 65 72 06 66 61
73 74 6c 79 c0 22 78 39 c6 29 00 00 0e 10 00 00
02 58 00 09 3a 80 00 00 00 1e|}
in
let mock_state = create `Udp in
default_debug_info := [udp_buf];
match getaddrinfo mock_state Dns.Rr_map.Aaaa domain_name with
| Error `Msg actual ->
let expected = "DNS cache error no data fastly.net" in
let len = String.length expected in
Alcotest.(check string __LOC__ expected (String.sub actual 0 len))
| Ok (_, _) -> Alcotest.fail "Should have returned nodata"
let tests = [
"supports_mx_packets", `Quick, supports_mx_packets;
"a partial UDP response packet fails", `Quick, fails_on_partial_udp_packet;
"cname and nodata in packet", `Quick, cname_and_nodata_packet;
]
end
let tests = [
"make_query tests", Make_query_tests.tests;
"parse_response tests", Parse_response_tests.tests;
"gethostbyname tests", Gethostbyname_tests.tests;
"getaddrinfo tests", Getaddrinfo_tests.tests;
]
let () = Alcotest.run "DNS client tests" tests

53
unikernel/duniverse/ocaml-dns/test/dune Normal file
View file

@ -0,0 +1,53 @@
(test
(name tests)
(package dns)
(libraries dns alcotest)
(modules tests))
(test
(name server)
(package dns-server)
(libraries base64 dns-server dns-server.zone dns-tsig alcotest mirage-crypto-rng.unix)
(modules server))
(test
(name tsig)
(package dns-tsig)
(libraries dns-tsig alcotest)
(modules tsig))
(test
(name resolver)
(package dns-resolver)
(libraries dns-resolver alcotest logs.fmt)
(modules resolver))
(test
(name client)
(package dns-client)
(libraries dns-client alcotest)
(modules client))
(test
(name cache)
(package dns)
(libraries dns.cache alcotest)
(modules cache))
(test
(name resolvconf)
(package dns-client)
(libraries dns-client.resolvconf ipaddr alcotest)
(modules resolvconf))
(test
(name test_dnssec)
(package dnssec)
(libraries dns dnssec mirage-crypto-pk base64 logs.fmt alcotest)
(modules test_dnssec))
(test
(name test_rfc9460)
(package dns-server)
(libraries dns-server dns-server.zone logs.fmt alcotest)
(modules test_rfc9460))

118
unikernel/duniverse/ocaml-dns/test/resolvconf.ml Normal file
View file

@ -0,0 +1,118 @@
let ok =
let module M = struct
type t = [ `Nameserver of Ipaddr.t ] list
let pp =
let pp_one ppf = function
| `Nameserver ip -> Fmt.pf ppf "nameserver %a" Ipaddr.pp ip
in
Fmt.(list ~sep:(any "\n") pp_one)
let equal a b = compare a b = 0 (* TODO polymorphic equality *)
end in
(module M: Alcotest.TESTABLE with type t = M.t)
let err =
let module M = struct
type t = [ `Msg of string ]
let pp ppf = function
| `Msg m -> Fmt.string ppf m
let equal _ _ = true
end in
(module M: Alcotest.TESTABLE with type t = M.t)
let test_one test_name (data, expected) () =
Alcotest.(check (result ok err)
("resolvconf " ^ test_name) expected (Dns_resolvconf.parse data))
let v4_ns = [ "8.8.8.8" ; "8.8.4.4" ]
and v6_ns = [ "2001:4860:4860::8888" ; "2001:4860:4860::8844" ]
let ok_result ns =
Ok (List.map (fun s -> `Nameserver (Ipaddr.of_string_exn s)) ns)
let linux =
{|
# Not all of these are supported by TRust-DNS
# They are testing that they don't break parsing
options ndots:8 timeout:8 attempts:8
domain example.com
search example.com sub.example.com
nameserver 2001:4860:4860::8888
nameserver 2001:4860:4860::8844
nameserver 8.8.8.8
nameserver 8.8.4.4
# some options not supported by TRust-DNS
options rotate
options inet6 no-tld-query
# A basic option not supported
sortlist 130.155.160.0/255.255.240.0 130.155.0.0
|}
let macos =
{|
#
# Mac OS X Notice
#
# This file is not used by the host name and address resolution
# or the DNS query routing mechanisms used by most processes on
# this Mac OS X system.
#
# This file is automatically generated.
#
options ndots:8 timeout:8 attempts:8
domain example.com.
search example.com. sub.example.com.
nameserver 2001:4860:4860::8888
nameserver 2001:4860:4860::8844
nameserver 8.8.8.8
nameserver 8.8.4.4
|}
let openbsd =
{|
# Generated by em0 dhclient
nameserver 8.8.8.8
nameserver 8.8.4.4
lookup file bind
|}
let simple =
{|
nameserver 8.8.8.8
nameserver 8.8.4.4
|}
let nixos =
{|
nameserver fe80::c2d7:aaff:fe96:8d82%wlp3s0
|}
let nixos2 =
{|
nameserver 8.8.8.8
nameserver 8.8.4.4
nameserver fe80::c2d7:aaff:fe96:8d82%wlp3s0
nameserver 8.8.8.8
nameserver 8.8.4.4
|}
let local_ns = [ "fe80::c2d7:aaff:fe96:8d82" ]
let tests = [
"linux", `Quick, test_one "linux" (linux, ok_result (v6_ns @ v4_ns)) ;
"macos", `Quick, test_one "macos" (macos, ok_result (v6_ns @ v4_ns)) ;
"openbsd", `Quick, test_one "openbsd" (openbsd, ok_result v4_ns) ;
"simple", `Quick, test_one "simple" (simple, ok_result v4_ns) ;
"nixos", `Quick, test_one "nixos (with zone index)"
(nixos, ok_result local_ns) ;
"nixos 2", `Quick, test_one "nixos 2 (with zone index)"
(nixos2, ok_result (v4_ns @ local_ns @ v4_ns)) ;
]
let () = Alcotest.run "DNS resolvconf tests" [ "resolvconf tests", tests ]

1149
unikernel/duniverse/ocaml-dns/test/resolver.ml Normal file
View file

File diff suppressed because it is too large Load diff

2163
unikernel/duniverse/ocaml-dns/test/server.ml Normal file
View file

File diff suppressed because it is too large Load diff

2039
unikernel/duniverse/ocaml-dns/test/test_dnssec.ml Normal file
View file

File diff suppressed because it is too large Load diff

Some files were not shown because too many files have changed in this diff Show more