├── .gitignore ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── app ├── dns_cli.ml ├── dune ├── ocertify.ml ├── odns.ml ├── odnssec.ml ├── onotify.ml ├── oupdate.ml ├── ozone.ml └── resolver.ml ├── cache ├── dns_cache.ml ├── dns_cache.mli └── dune ├── certify ├── dns_certify.ml ├── dns_certify.mli └── dune ├── client ├── dns_client.ml ├── dns_client.mli └── dune ├── dns-certify.opam ├── dns-cli.opam ├── dns-client-lwt.opam ├── dns-client-miou-unix.opam ├── dns-client-mirage.opam ├── dns-client.opam ├── dns-mirage.opam ├── dns-resolver.opam ├── dns-server.opam ├── dns-stub.opam ├── dns-tsig.opam ├── dns.opam ├── dnssec.opam ├── dnssec ├── base32.ml ├── dnssec.ml └── dune ├── dune-project ├── lwt └── client │ ├── dns_client_lwt.ml │ ├── dns_client_lwt.mli │ └── dune ├── miou └── client │ ├── dns_client_miou_unix.ml │ ├── dns_client_miou_unix.mli │ └── dune ├── mirage ├── certify │ ├── dns_certify_mirage.ml │ ├── dns_certify_mirage.mli │ └── dune ├── client │ ├── dns_client_mirage.ml │ ├── dns_client_mirage.mli │ └── dune ├── dns_mirage.ml ├── dns_mirage.mli ├── dune ├── resolver │ ├── dns_resolver_mirage.ml │ ├── dns_resolver_mirage.mli │ └── dune ├── server │ ├── dns_server_mirage.ml │ ├── dns_server_mirage.mli │ └── dune └── stub │ ├── dns_stub_mirage.ml │ └── dune ├── resolvconf ├── dns_resolvconf.ml ├── dns_resolvconf.mli ├── dune ├── resolvconf_lexer.mll ├── resolvconf_parser.mly └── resolvconf_state.ml ├── resolver ├── dns_resolver.ml ├── dns_resolver.mli ├── dns_resolver_cache.ml ├── dns_resolver_cache.mli ├── dns_resolver_root.ml ├── dns_resolver_root.mli ├── dns_resolver_utils.ml ├── dns_resolver_utils.mli └── dune ├── server ├── dns_server.ml ├── dns_server.mli ├── dns_trie.ml ├── dns_trie.mli └── dune ├── src ├── dns.ml ├── dns.mli └── dune ├── test ├── cache.ml ├── client.ml ├── dune ├── resolvconf.ml ├── resolver.ml ├── server.ml ├── test_dnssec.ml ├── test_rfc9460.ml ├── tests.ml └── tsig.ml ├── tsig ├── dns_tsig.ml ├── dns_tsig.mli └── dune ├── unix └── client │ ├── dns_client_unix.ml │ ├── dns_client_unix.mli │ ├── dune │ └── ohost.ml └── zone ├── dns_zone.ml ├── dns_zone.mli ├── dns_zone_lexer.mll ├── dns_zone_parser.mly ├── dns_zone_state.ml ├── dns_zone_state.mli └── dune /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.install 3 | .merlin 4 | 5 | *pcap 6 | *out 7 | coverage/ 8 | *req 9 | *key 10 | *private 11 | *pem 12 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, 2018, Hannes Mehnert 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, 5 | are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, this 11 | list of conditions and the following disclaimer in the documentation and/or 12 | other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 15 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 16 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 18 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 19 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 20 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 21 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 22 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 23 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build clean test doc 2 | 3 | build: 4 | dune build 5 | 6 | test: 7 | dune runtest 8 | 9 | doc: 10 | dune build @doc 11 | 12 | clean: 13 | dune clean 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ocaml-dns - a Domain Name System (DNS) library 2 | 3 | (c) 2017-2019 Hannes Mehnert (robur.io, Center for the Cultivation of Technology) 4 | 5 | %%VERSION%% 6 | 7 | This library supports most of the domain name system used in the wild. It 8 | adheres to strict conventions. Failing early and hard. It is mostly 9 | implemented in the pure fragment of OCaml (no mutation, isolated IO, no 10 | exceptions). 11 | 12 | It all started out as an experiment to run a recursive resolver, but after 13 | initial prototypes it turned out that every configurable recursive resolver 14 | needs a fully-fledged authoritative nameserver as well (for overriding various 15 | zones such as `.localhost` and reverse lookups of RFC 1918 IP ranges). 16 | 17 | Legacy resource record types are not dealt with, and there is no plan to support 18 | `ISDN`, `MAILA`, `MAILB`, `WKS`, `MB`, `HINFO`, ... . `AXFR`, `IXFR`, 19 | and `UPDATE` is only handled via TCP connections. The only resource class 20 | supported is `IN` (the Internet). Truncated hmac in `TSIG` are not supported 21 | (always the full length of the hash algorithm is used). 22 | 23 | Please read [the blog article](https://hannes.robur.coop/Posts/DNS) for a more 24 | detailed overview. 25 | 26 | This library is published under the 2 clause BSD license. 27 | 28 | ## Supported RFCs 29 | 30 | * [RFC 1034](https://tools.ietf.org/html/rfc1034) Domain Names - Concepts and Facilities 31 | * [RFC 1035](https://tools.ietf.org/html/rfc1035) Domain Names - Implementation and Specification 32 | * [RFC 1876](https://tools.ietf.org/html/rfc1876) A Means for Expressing Location Information in the Domain Name System 33 | * [RFC 1912](https://tools.ietf.org/html/rfc1912) Common DNS Operational and Configuration Errors 34 | * [RFC 1995](https://tools.ietf.org/html/rfc1995) Incremental Zone Transfer in DNS 35 | * [RFC 1996](https://tools.ietf.org/html/rfc1996) A Mechanism for Prompt Notification of Zone Changes (DNS NOTIFY) 36 | * [RFC 2136](https://tools.ietf.org/html/rfc2136) Dynamic Updates in the domain name system (DNS UPDATE) 37 | * [RFC 2181](https://tools.ietf.org/html/rfc2181) Clarifications to the DNS Specification 38 | * [RFC 2308](https://tools.ietf.org/html/rfc2308) Negative Caching of DNS Queries (DNS NCACHE) 39 | * [RFC 2782](https://tools.ietf.org/html/rfc2782) A DNS RR for specifying the location of services (DNS SRV) 40 | * [RFC 2845](https://tools.ietf.org/html/rfc2845) Secret Key Transaction Authentication for DNS (TSIG) 41 | * [RFC 3596](https://tools.ietf.org/html/rfc3596) DNS Extensions to Support IP Version 6 42 | * [RFC 4033](https://tools.ietf.org/html/rfc4033) DNS Security Introduction and Requirements 43 | * [RFC 4034](https://tools.ietf.org/html/rfc4034) Resource Records for the DNS Security Extensions 44 | * [RFC 4035](https://tools.ietf.org/html/rfc4035) Protocol Modifications for the DNS Security Extensions 45 | * [RFC 4255](https://tools.ietf.org/html/rfc4255) Using DNS to Securely Publish Secure Shell (SSH) Key Fingerprints 46 | * [RFC 4343](https://tools.ietf.org/html/rfc4343) Domain Name System (DNS) Case Insensitivity Clarification 47 | * [RFC 4509](https://tools.ietf.org/html/rfc4509) Use of SHA-256 in DNSSEC Delegation Signer (DS) Resource Records (RRs) 48 | * [RFC 4592](https://tools.ietf.org/html/rfc4592) The Role of Wildcards in the Domain Name System 49 | * [RFC 4635](https://tools.ietf.org/html/rfc4635) HMAC SHA TSIG Algorithm Identifiers 50 | * `*` [RFC 5001](https://tools.ietf.org/html/rfc5001) DNS Name Server Identifier (NSID) Option 51 | * [RFC 5155](https://tools.ietf.org/html/rfc5155) DNS Security (DNSSEC) Hashed Authenticated Denial of Existence 52 | * [RFC 5358](https://tools.ietf.org/html/rfc5358) Preventing Use of Recursive Nameservers in Reflector Attacks 53 | * [RFC 5452](https://tools.ietf.org/html/rfc5452) Measures for Making DNS More Resilient against Forged Answers 54 | * [RFC 5936](https://tools.ietf.org/html/rfc5936) DNS Zone Transfer Protocol (AXFR) 55 | * [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 56 | * [RFC 6605](https://tools.ietf.org/html/rfc6605) Elliptic Curve Digital Signature Algorithm (DSA) for DNSSEC 57 | * [RFC 6698](https://tools.ietf.org/html/rfc6698.html) The DNS-Based Authentication of Named Entities (DANE) Transport Layer Security (TLS) Protocol: TLSA 58 | * [RFC 6761](https://tools.ietf.org/html/rfc6761) Special-Use Domain Names 59 | * `*` [RFC 6762](https://tools.ietf.org/html/rfc6762) Multicast DNS 60 | * [RFC 6844](https://tools.ietf.org/html/rfc6844) DNS Certification Authority Authorization (CAA) Resource Record 61 | * [RFC 6890](https://tools.ietf.org/html/rfc6890) Special-Purpose IP Address Registries 62 | * [RFC 6891](https://tools.ietf.org/html/rfc6891) Extension Mechanisms for DNS (EDNS(0)) 63 | * [RFC 6895](https://tools.ietf.org/html/rfc6895) Domain Name System (DNS) IANA Considerations (BCP 42) 64 | * [RFC 7129](https://tools.ietf.org/html/rfc7129) Authenticated Denial of Existence in the DNS 65 | * [RFC 7479](https://tools.ietf.org/html/rfc7479) Using Ed25519 in SSHFP Resource Records 66 | * [RFC 7626](https://tools.ietf.org/html/rfc7626) DNS Privacy Considerations 67 | * [RFC 7766](https://tools.ietf.org/html/rfc7766) DNS Transport over TCP - Implementation Requirements 68 | * [RFC 7816](https://tools.ietf.org/html/rfc7816) DNS Query Name Minimisation to Improve Privacy 69 | * [RFC 7828](https://tools.ietf.org/html/rfc7828) The edns-tcp-keepalive EDNS0 Option 70 | * `*` [RFC 7830](https://tools.ietf.org/html/rfc7830) The EDNS(0) Padding Option 71 | * `*` [RFC 7873](https://tools.ietf.org/html/rfc7873) Domain Name System (DNS) Cookies 72 | * [RFC 8080](https://tools.ietf.org/html/rfc8080) Edwards-Curve Digital Security Algorithm (EdDSA) for DNSSEC 73 | * [RFC 8109](https://tools.ietf.org/html/rfc8109) Initializing a DNS Resolver with Priming Queries 74 | * [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. 75 | 76 | `*`: Please note that the RFCs marked with `*` are only partially implemented 77 | (i.e. only wire format, but no logic handling the feature). 78 | 79 | ## Installation 80 | 81 | You first need to install [OCaml](https://ocaml.org) (at least 4.08.2) and 82 | [opam](https://opam.ocaml.org), the OCaml package manager (at least 2.0.0) on 83 | your machine (you can use opam to install an up-to-date OCaml (`opam switch 84 | 4.08.2`)). 85 | 86 | You may want to follow the [mirage installation 87 | instructions](https://mirage.io/wiki/install) to get `mirage` installed on your 88 | computer. 89 | 90 | To minimize the amount of run-time dependencies for each individual 91 | functionality, the library is split into multiple opam packages (core, server, 92 | client, resolver, cli, certify), with multiple ocamlfind libraries for the 93 | different backends (no optional dependencies) -- i.e. `dns-server.mirage` 94 | contains the MirageOS-specific DNS server code. 95 | 96 | Now the µDNS library is installed, and you can try out the examples. Find some 97 | examples at the [unikernel repository](https://github.com/roburio/unikernels). 98 | 99 | ## Documentation 100 | 101 | API documentation [is available online](https://mirage.github.io/ocaml-dns/). 102 | 103 | ## Transition from older versions 104 | 105 | The pre-4.0.0 versions of ocaml-dns had a significantly different interface, 106 | and so applications using them will need to be rewritten to follow the 107 | stricter coding style used in the post-4.0.0 branches. The major improvements 108 | from 1.x to the 4.x series are: 109 | 110 | - data (rrset) is defined in a single GADT in `Rr_map` 111 | - added support for: notify, dynamic update, zone transfer, tsig (hmac authentication), edns 112 | - no mutable data structures, leading to easier reasoning about library state 113 | - switched to an independent `domain_name` library which uses a faster and more 114 | compact `string array` instead of `string list` for storing domain names 115 | - integration with LetsEncrypt for provisioning valid X.509 certificates 116 | - no use of exceptions, instead preferring explicit result values from API functions 117 | 118 | Please get in touch on or on the Discuss forum 119 | at (with the `mirageos` tag) if you have any questions 120 | about migrating (or just general questions). 121 | 122 | ## Development 123 | 124 | To work with the [opam](https://opam.ocaml.org/) packages provided when 125 | developing modifications to DNS, or when pinning a specific version, 126 | you will have to pin the same *version* for all of them: 127 | 128 | ```csh 129 | : csh syntax 130 | set version=4.99.0 131 | set repo=git+https://github.com/mirage/ocaml-dns.git 132 | 133 | # the -y parameter means "force" or 134 | # "do go ahead and register a new package" 135 | 136 | # the -n parameter means 137 | # "just register the pin, don't actually install it yet" 138 | 139 | foreach pkg ( dns dns-{certify,cli,client,resolver,server,mirage,tsig,stub} ) 140 | opam pin add -y -n $pkg.$version --dev $repo 141 | end 142 | ``` 143 | 144 | ```bash 145 | : bash syntax 146 | version=4.99.0 147 | repo=git+https://github.com/mirage/ocaml-dns.git 148 | 149 | for pkg in dns dns-{certify,cli,client,resolver,server,mirage,tsig,stub} 150 | do 151 | opam pin add -y -n $pkg.$version --dev $repo 152 | done 153 | ``` 154 | 155 | Now you can install the packages you need, for instance: 156 | ```shell 157 | opam install dns-client 158 | ``` 159 | or 160 | ```shell 161 | opam install dns-resolver 162 | ``` 163 | -------------------------------------------------------------------------------- /app/dns_cli.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | let reporter_with_ts ~dst () = 3 | let pp_tags f tags = 4 | let pp tag () = 5 | let (Logs.Tag.V (def, value)) = tag in 6 | Format.fprintf f " %s=%a" (Logs.Tag.name def) (Logs.Tag.printer def) value; 7 | () 8 | in 9 | Logs.Tag.fold pp tags () 10 | in 11 | let report src level ~over k msgf = 12 | let tz_offset_s = Ptime_clock.current_tz_offset_s () in 13 | let posix_time = Ptime_clock.now () in 14 | let src = Logs.Src.name src in 15 | let k _ = 16 | over (); 17 | k () 18 | in 19 | msgf @@ fun ?header ?tags fmt -> 20 | Format.kfprintf k dst 21 | ("%a:%a %a [%s] @[" ^^ fmt ^^ "@]@.") 22 | (Ptime.pp_rfc3339 ?tz_offset_s ()) 23 | posix_time 24 | Fmt.(option ~none:(any "") pp_tags) 25 | tags Logs_fmt.pp_header (level, header) src 26 | in 27 | { Logs.report } 28 | 29 | let setup_log style_renderer level = 30 | Fmt_tty.setup_std_outputs ?style_renderer (); 31 | Logs.set_level level; 32 | Logs.set_reporter (reporter_with_ts ~dst:Format.std_formatter ()) 33 | 34 | let connect_tcp ip port = 35 | let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) in 36 | let fam = match ip with Ipaddr.V4 _ -> Unix.PF_INET | Ipaddr.V6 _ -> Unix.PF_INET6 in 37 | let sock = Unix.(socket fam SOCK_STREAM 0) in 38 | Unix.(setsockopt sock SO_REUSEADDR true) ; 39 | Unix.connect sock sa ; 40 | sock 41 | 42 | (* TODO EINTR, SIGPIPE *) 43 | let send_tcp sock buf = 44 | let size = String.length buf in 45 | let size_buf = 46 | let b = Bytes.create 2 in 47 | Bytes.set_int16_be b 0 size ; 48 | b 49 | in 50 | let data = Bytes.cat size_buf (Bytes.of_string buf) in 51 | let whole = size + 2 in 52 | let rec out off = 53 | if off = whole then () 54 | else 55 | let bytes = Unix.send sock data off (whole - off) [] in 56 | out (bytes + off) 57 | in 58 | out 0 59 | 60 | let recv_tcp sock = 61 | let rec read_exactly buf len off = 62 | if off = len then () 63 | else 64 | let n = Unix.recv sock buf off (len - off) [] in 65 | read_exactly buf len (off + n) 66 | in 67 | let buf = Bytes.create 2 in 68 | read_exactly buf 2 0 ; 69 | let len = Bytes.get_int16_be buf 0 in 70 | let buf' = Bytes.create len in 71 | read_exactly buf' len 0 ; 72 | Bytes.unsafe_to_string buf' 73 | 74 | open Cmdliner 75 | 76 | let setup_log = 77 | Term.(const setup_log 78 | $ Fmt_cli.style_renderer () 79 | $ Logs_cli.level ()) 80 | 81 | let ip_c = Arg.conv (Ipaddr.of_string, Ipaddr.pp) 82 | 83 | let namekey_c = 84 | let parse s = 85 | let ( let* ) = Result.bind in 86 | let* (name, key) = Dns.Dnskey.name_key_of_string s in 87 | let is_op s = 88 | Domain_name.(equal_label s "_update" || equal_label s "_transfer" || equal_label s "_notify") 89 | in 90 | let amount = match Domain_name.find_label ~rev:true name is_op with 91 | | None -> 0 92 | | Some x -> succ x 93 | in 94 | let* zone = Domain_name.drop_label ~amount name in 95 | let* zone = Domain_name.host zone in 96 | Ok (name, zone, key) 97 | in 98 | let pp ppf (name, zone, key) = 99 | Fmt.pf ppf "key name %a zone %a dnskey %a" 100 | Domain_name.pp name Domain_name.pp zone Dns.Dnskey.pp key 101 | in 102 | Arg.conv (parse, pp) 103 | 104 | let name_c = 105 | Arg.conv 106 | ((fun s -> Result.bind (Domain_name.of_string s) Domain_name.host), 107 | Domain_name.pp) 108 | 109 | let domain_name_c = 110 | Arg.conv (Domain_name.of_string, Domain_name.pp) 111 | -------------------------------------------------------------------------------- /app/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_cli) 3 | (public_name dns-cli) 4 | (wrapped false) 5 | (modules dns_cli) 6 | (libraries dns cmdliner ptime.clock.os logs.fmt fmt.cli logs.cli fmt.tty ipaddr.unix)) 7 | 8 | (executable 9 | (name ocertify) 10 | (public_name ocertify) 11 | (package dns-cli) 12 | (modules ocertify) 13 | (libraries dns dns-certify dns-cli bos fpath x509 ptime ptime.clock.os mirage-crypto-pk mirage-crypto-rng mirage-crypto-rng.unix)) 14 | 15 | (executable 16 | (name oupdate) 17 | (public_name oupdate) 18 | (package dns-cli) 19 | (modules oupdate) 20 | (libraries dns dns-tsig dns-cli ptime ptime.clock.os mirage-crypto-rng mirage-crypto-rng.unix randomconv)) 21 | 22 | (executable 23 | (name onotify) 24 | (public_name onotify) 25 | (package dns-cli) 26 | (modules onotify) 27 | (libraries dns dns-tsig dns-cli ptime ptime.clock.os mirage-crypto-rng mirage-crypto-rng.unix randomconv)) 28 | 29 | (executable 30 | (name ozone) 31 | (public_name ozone) 32 | (package dns-cli) 33 | (modules ozone) 34 | (libraries dns dns-cli dns-server.zone dns-server bos)) 35 | 36 | (executable 37 | (name odns) 38 | (public_name odns) 39 | (modules odns) 40 | (package dns-cli) 41 | (libraries dns dns-client-lwt dns-cli cmdliner mtime.clock.os 42 | lwt.unix ohex bos)) 43 | 44 | (executable 45 | (name odnssec) 46 | (public_name odnssec) 47 | (modules odnssec) 48 | (package dns-cli) 49 | (libraries dns dns-client-lwt dns-cli cmdliner mtime.clock.os 50 | lwt.unix dnssec)) 51 | 52 | (executable 53 | (name resolver) 54 | (public_name resolver) 55 | (modules resolver) 56 | (package dns-cli) 57 | (libraries dns-cli dns-resolver dns-resolver.mirage lwt.unix tcpip.stack-socket mirage-mtime.unix logs.fmt mirage-crypto-rng.unix)) 58 | -------------------------------------------------------------------------------- /app/ocertify.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | let ( let* ) = Result.bind 3 | 4 | let find_or_generate_key key_filename keytype keydata seed bits = 5 | let* f_exists = Bos.OS.File.exists key_filename in 6 | if f_exists then 7 | let* data = Bos.OS.File.read key_filename in 8 | X509.Private_key.decode_pem data 9 | else 10 | let* key = 11 | match keydata with 12 | | None -> Ok (X509.Private_key.generate ?seed ~bits keytype) 13 | | Some s -> 14 | let* s = Base64.decode s in 15 | X509.Private_key.of_octets s keytype 16 | in 17 | let pem = X509.Private_key.encode_pem key in 18 | let* () = Bos.OS.File.write ~mode:0o600 key_filename pem in 19 | Ok key 20 | 21 | let query_certificate sock fqdn csr = 22 | match Dns_certify.query Mirage_crypto_rng.generate (Ptime_clock.now ()) fqdn csr with 23 | | Error e -> Error e 24 | | Ok (out, cb) -> 25 | Dns_cli.send_tcp sock out; 26 | let data = Dns_cli.recv_tcp sock in 27 | cb data 28 | 29 | let nsupdate_csr sock host keyname zone dnskey csr = 30 | match Dns_certify.nsupdate Mirage_crypto_rng.generate Ptime_clock.now ~host ~keyname ~zone dnskey csr with 31 | | Error s -> Error s 32 | | Ok (out, cb) -> 33 | Dns_cli.send_tcp sock out; 34 | let data = Dns_cli.recv_tcp sock in 35 | match cb data with 36 | | Ok () -> Ok () 37 | | Error e -> Error (`Msg (Fmt.str "nsupdate reply error %a" Dns_certify.pp_u_err e)) 38 | 39 | let jump _ server_ip port hostname more_hostnames dns_key_opt csr key keytype keydata seed bits cert force = 40 | Mirage_crypto_rng_unix.use_default (); 41 | let fn suffix = function 42 | | None -> Fpath.(v (Domain_name.to_string hostname) + suffix) 43 | | Some x -> Fpath.v x 44 | in 45 | let csr_filename = fn "req" csr 46 | and key_filename = fn "key" key 47 | and cert_filename = fn "pem" cert 48 | in 49 | let* csr = 50 | let* f_exists = Bos.OS.File.exists csr_filename in 51 | if f_exists then 52 | let* data = Bos.OS.File.read csr_filename in 53 | X509.Signing_request.decode_pem data 54 | else 55 | let* key = find_or_generate_key key_filename keytype keydata seed bits in 56 | let* csr = Dns_certify.signing_request hostname ~more_hostnames key in 57 | let pem = X509.Signing_request.encode_pem csr in 58 | let* () = Bos.OS.File.write csr_filename pem in 59 | Ok csr 60 | in 61 | (* before doing anything, let's check whether cert_filename is present, 62 | the public key matches, and the certificate is still valid *) 63 | let now = Ptime_clock.now () in 64 | let tomorrow = 65 | let (d, ps) = Ptime.Span.to_d_ps (Ptime.to_span now) in 66 | Ptime.v (succ d, ps) 67 | in 68 | let* cert = 69 | let* f_exists = Bos.OS.File.exists cert_filename in 70 | if f_exists then 71 | let* data = Bos.OS.File.read cert_filename in 72 | let* certs = X509.Certificate.decode_pem_multiple data in 73 | match List.filter (fun c -> X509.Certificate.supports_hostname c hostname) certs with 74 | | [] -> Ok None 75 | | [ cert ] -> Ok (Some cert) 76 | | _ -> Error (`Msg "multiple certificates that match the hostname") 77 | else 78 | Ok None 79 | in 80 | let* () = 81 | match cert with 82 | | Some cert -> 83 | if not force && Dns_certify.cert_matches_csr ~until:tomorrow now csr cert then 84 | Error (`Msg "valid certificate with matching key already present") 85 | else 86 | Ok () 87 | | None -> Ok () 88 | in 89 | (* strategy: unless force is provided, we can request DNS, and if a 90 | certificate is present, compare its public key with csr public key *) 91 | let write_certificate certs = 92 | let data = X509.Certificate.encode_pem_multiple certs in 93 | let* () = Bos.OS.File.delete cert_filename in 94 | Bos.OS.File.write cert_filename data 95 | in 96 | let sock = Dns_cli.connect_tcp server_ip port in 97 | let* should_update = 98 | if force then 99 | Ok true 100 | else match query_certificate sock hostname csr with 101 | | Ok (server, chain) -> 102 | Logs.app (fun m -> m "found cached certificate in DNS"); 103 | let* () = write_certificate (server :: chain) in 104 | Ok false 105 | | Error `No_tlsa -> 106 | Logs.debug (fun m -> m "no TLSA found, sending update"); 107 | Ok true 108 | | Error (`Msg m) -> Error (`Msg m) 109 | | Error ((`Decode _ | `Bad_reply _ | `Unexpected_reply _) as e) -> 110 | Error (`Msg (Fmt.str "error %a while parsing TLSA reply" 111 | Dns_certify.pp_q_err e)) 112 | in 113 | if not should_update then 114 | Ok () 115 | else 116 | let* () = 117 | match dns_key_opt with 118 | | None -> Error (`Msg "no dnskey provided, but required for uploading CSR") 119 | | Some (keyname, zone, dnskey) -> 120 | let* () = nsupdate_csr sock hostname keyname zone dnskey csr in 121 | let rec request retries = 122 | match query_certificate sock hostname csr with 123 | | Error (`Msg msg) -> Error (`Msg msg) 124 | | Error #Dns_certify.q_err when retries = 0 -> 125 | Error (`Msg "failed to retrieve certificate (tried 10 times)") 126 | | Error `No_tlsa -> 127 | Logs.warn (fun m -> m "still no tlsa, sleeping two more seconds"); 128 | Unix.sleep 2; 129 | request (pred retries) 130 | | Error (#Dns_certify.q_err as e) -> 131 | Logs.err (fun m -> m "error %a while handling TLSA reply (retrying)" 132 | Dns_certify.pp_q_err e); 133 | request (pred retries) 134 | | Ok (server, chain) -> write_certificate (server :: chain) 135 | in 136 | request 10 137 | in 138 | Logs.app (fun m -> m "success! your certificate is stored in %a (private key %a, csr %a)" 139 | Fpath.pp cert_filename Fpath.pp key_filename Fpath.pp csr_filename); 140 | Ok () 141 | 142 | open Cmdliner 143 | 144 | let dns_server = 145 | let doc = "DNS server IP" in 146 | Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"IP") 147 | 148 | let port = 149 | let doc = "Port to connect to" in 150 | Arg.(value & opt int 53 & info [ "port" ] ~doc) 151 | 152 | let dns_key = 153 | let doc = "nsupdate key (name:alg:b64key, where name is YYY._update.zone)" in 154 | Arg.(value & opt (some Dns_cli.namekey_c) None & info [ "dns-key" ] ~doc ~docv:"KEY") 155 | 156 | let hostname = 157 | let doc = "Hostname (FQDN) to issue a certificate for" in 158 | Arg.(required & pos 1 (some Dns_cli.name_c) None & info [] ~doc ~docv:"HOSTNAME") 159 | 160 | let more_hostnames = 161 | let doc = "Additional hostnames to be included in the certificate as SubjectAlternativeName extension" in 162 | Arg.(value & opt_all Dns_cli.domain_name_c [] & info ["additional"] ~doc ~docv:"HOSTNAME") 163 | 164 | let csr = 165 | let doc = "certificate signing request filename (defaults to hostname.req)" in 166 | Arg.(value & opt (some string) None & info [ "csr" ] ~doc) 167 | 168 | let key = 169 | let doc = "private key filename (default to hostname.key)" in 170 | Arg.(value & opt (some string) None & info [ "key" ] ~doc) 171 | 172 | let seed = 173 | let doc = "private key seed (or full private key if keytype is a EC key)" in 174 | Arg.(value & opt (some string) None & info [ "seed" ] ~doc) 175 | 176 | let bits = 177 | let doc = "private key bits" in 178 | Arg.(value & opt int 4096 & info [ "bits" ] ~doc) 179 | 180 | let keydata = 181 | let doc = "private key (base64 encoded)" in 182 | Arg.(value & opt (some string) None & info [ "data" ] ~doc) 183 | 184 | let keytype = 185 | let doc = "keytype to generate" in 186 | Arg.(value & opt (enum X509.Key_type.strings) `RSA & info [ "type" ] ~doc) 187 | 188 | let cert = 189 | let doc = "certificate filename (defaults to hostname.pem)" in 190 | Arg.(value & opt (some string) None & info [ "certificate" ] ~doc) 191 | 192 | let force = 193 | let doc = "force signing request to DNS" in 194 | Arg.(value & flag & info [ "force" ] ~doc) 195 | 196 | let ocertify = 197 | let doc = "ocertify requests a signed certificate" in 198 | let man = [ `S "BUGS"; `P "Submit bugs to me";] in 199 | let term = 200 | 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)) 201 | and info = Cmd.info "ocertify" ~version:"%%VERSION_NUM%%" ~doc ~man 202 | in 203 | Cmd.v info term 204 | 205 | let () = exit (Cmd.eval ocertify) 206 | -------------------------------------------------------------------------------- /app/odnssec.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | open Dns 4 | 5 | let ( let* ) = Result.bind 6 | 7 | let pp_zone ppf (domain, query_type, query_value) = 8 | Fmt.string ppf 9 | (Rr_map.text_b domain (Rr_map.B (query_type, query_value))) 10 | 11 | let pp_nameserver ppf = function 12 | | `Plaintext (ip, port) -> Fmt.pf ppf "TCP %a:%d" Ipaddr.pp ip port 13 | | `Tls (tls_cfg, ip, port) -> 14 | Fmt.pf ppf "TLS %a:%d%a" Ipaddr.pp ip port 15 | Fmt.(option ~none:(any "") (append (any "#") Domain_name.pp)) 16 | ((Tls.Config.of_client tls_cfg).Tls.Config.peer_name) 17 | 18 | let jump () hostname typ ns = 19 | match Dns.Rr_map.of_string typ with 20 | | Ok K k -> 21 | Lwt_main.run ( 22 | let edns = Edns.create ~dnssec_ok:true ~payload_size:4096 () in 23 | let nameservers = match ns with 24 | | None -> None 25 | | Some ip -> Some (`Tcp, [ `Plaintext (ip, 53) ]) 26 | in 27 | let happy_eyeballs = Happy_eyeballs_lwt.create () in 28 | let t = Dns_client_lwt.create ?nameservers ~edns:(`Manual edns) happy_eyeballs in 29 | let (_, ns) = Dns_client_lwt.nameservers t in 30 | Logs.info (fun m -> m "querying NS %a for A records of %a" 31 | pp_nameserver (List.hd ns) Domain_name.pp hostname); 32 | let log_err = function 33 | | `Msg msg -> 34 | Logs.err (fun m -> m "error from resolver %s" msg); 35 | Error (`Msg "bad request") 36 | | `Partial -> 37 | Logs.err (fun m -> m "partial from resolver"); 38 | Error (`Msg "partial") 39 | | #Dnssec.err as e -> 40 | Logs.err (fun m -> m "dnssec error %a" Dnssec.pp_err e); 41 | Error (`Msg "error") 42 | in 43 | let now = Ptime_clock.now () in 44 | let retrieve_dnskey dnskeys ds_set requested_domain = 45 | Dns_client_lwt.(get_raw_reply t Dnskey requested_domain) >|= function 46 | | Error e -> log_err e 47 | | Ok reply -> 48 | let keys = 49 | match reply with 50 | | `Answer (answer, _) -> 51 | Option.map 52 | (fun (_, keys) -> 53 | let valid_keys = 54 | Rr_map.Ds_set.fold (fun ds acc -> 55 | match Dnssec.validate_ds requested_domain keys ds with 56 | | Ok key -> Rr_map.Dnskey_set.add key acc 57 | | Error `Msg msg -> 58 | Logs.warn (fun m -> m "couldn't validate DS (for %a): %s" 59 | Domain_name.pp requested_domain msg); 60 | acc) 61 | ds_set Rr_map.Dnskey_set.empty 62 | in 63 | Logs.debug (fun m -> m "found %d DNSKEYS with matching DS" 64 | (Rr_map.Dnskey_set.cardinal valid_keys)); 65 | valid_keys) 66 | (Name_rr_map.find requested_domain Dnskey answer) 67 | | _ -> None 68 | in 69 | let keys = Option.value ~default:dnskeys keys in 70 | match Dnssec.verify_reply now keys requested_domain Dnskey reply with 71 | | Error (`No_domain _ | `No_data _) -> 72 | Logs.warn (fun m -> m "no DNSKEY for %a" 73 | Domain_name.pp requested_domain); 74 | Error (`Msg (Fmt.str "missing DNSKEY for %a" 75 | Domain_name.pp requested_domain)) 76 | | Error e -> log_err e 77 | | Ok (_, keys) -> 78 | Logs.info (fun m -> m "verified RRSIG for DNSKEYS"); 79 | let keys = 80 | Rr_map.Dnskey_set.filter 81 | (fun k -> Dnskey.F.mem `Zone k.Dnskey.flags) 82 | keys 83 | in 84 | Ok keys 85 | in 86 | let retrieve_ds dnskeys name = 87 | Dns_client_lwt.(get_raw_reply t Ds name) >|= function 88 | | Error e -> log_err e 89 | | Ok reply -> 90 | match Dnssec.verify_reply ~follow_cname:false now dnskeys name Ds reply with 91 | | Ok (_, ds) -> Ok (Some ds) 92 | | Error (`No_domain _ | `No_data _) -> 93 | Logs.warn (fun m -> m "no data or no domain for DS in %a" 94 | Domain_name.pp name); 95 | Ok None 96 | | Error (`Cname a) -> 97 | Logs.warn (fun m -> m "cname alias for %a (DS) to %a" 98 | Domain_name.pp name 99 | Domain_name.pp a); 100 | Ok None 101 | | Error e-> 102 | log_err e 103 | in 104 | let rec retrieve_validated_dnskeys hostname = 105 | Logs.info (fun m -> m "validating and retrieving DNSKEYS for %a" Domain_name.pp hostname); 106 | if Domain_name.equal hostname Domain_name.root then begin 107 | Logs.info (fun m -> m "retrieving DNSKEYS for %a" Domain_name.pp hostname); 108 | retrieve_dnskey Rr_map.Dnskey_set.empty Dnssec.root_ds hostname 109 | end else 110 | let open Lwt_result.Infix in 111 | retrieve_validated_dnskeys Domain_name.(drop_label_exn hostname) >>= fun parent_dnskeys -> 112 | Logs.info (fun m -> m "retrieving DS for %a" Domain_name.pp hostname); 113 | retrieve_ds parent_dnskeys hostname >>= function 114 | | Some ds_set -> 115 | (* following 4509 - if there's a sha2 DS, drop sha1 ones *) 116 | let ds_set' = 117 | if 118 | Rr_map.Ds_set.exists 119 | (fun ds -> 120 | match ds.Ds.digest_type with 121 | | Ds.SHA256 | Ds.SHA384 -> true 122 | | _ -> false) 123 | ds_set 124 | then 125 | Rr_map.Ds_set.filter 126 | (fun ds -> not (ds.Ds.digest_type = Ds.SHA1)) 127 | ds_set 128 | else 129 | ds_set 130 | in 131 | if Rr_map.Ds_set.cardinal ds_set > Rr_map.Ds_set.cardinal ds_set' then 132 | Logs.warn (fun m -> m "dropped %d DS records (SHA1)" 133 | (Rr_map.Ds_set.cardinal ds_set' - Rr_map.Ds_set.cardinal ds_set)); 134 | Logs.info (fun m -> m "retrieving DNSKEYS for %a" Domain_name.pp hostname); 135 | retrieve_dnskey parent_dnskeys ds_set' hostname 136 | | None -> 137 | Logs.info (fun m -> m "no DS for %a, continuing with old keys" Domain_name.pp hostname); 138 | Lwt.return (Ok parent_dnskeys) 139 | in 140 | retrieve_validated_dnskeys hostname >>= function 141 | | Error _ as e -> Lwt.return e 142 | | Ok dnskeys -> 143 | Dns_client_lwt.(get_raw_reply t k hostname) >|= function 144 | | Error e -> log_err e 145 | | Ok reply -> 146 | match Dnssec.verify_reply now dnskeys hostname k reply with 147 | | Ok rrs -> 148 | Logs.app (fun m -> m "%a" pp_zone (hostname, k, rrs)); 149 | Ok () 150 | | Error (`No_domain _ | `No_data _) -> 151 | Logs.warn (fun m -> m "no data or no domain for %a (%a)" 152 | Domain_name.pp hostname Rr_map.ppk (K k)); 153 | Ok () 154 | | Error e -> log_err e 155 | ) 156 | | _ -> Error (`Msg "couldn't decode type") 157 | 158 | open Cmdliner 159 | 160 | let parse_domain : [ `raw ] Domain_name.t Arg.conv = 161 | Arg.conv' 162 | ((fun name -> 163 | Result.map_error 164 | (function `Msg m -> Fmt.str "Invalid domain: %S: %s" name m) 165 | (Domain_name.of_string name)), 166 | Domain_name.pp) 167 | 168 | let arg_domain : [ `raw ] Domain_name.t Term.t = 169 | let doc = "Host to operate on" in 170 | Arg.(value & opt parse_domain (Domain_name.of_string_exn "cloudflare.com") 171 | & info [ "host" ] ~docv:"HOST" ~doc) 172 | 173 | let parse_ip = 174 | Arg.conv' 175 | ((fun s -> 176 | match Ipaddr.of_string s with 177 | | Ok ip -> Ok ip 178 | | Error (`Msg m) -> Error ("failed to parse IP address: " ^ m)), 179 | Ipaddr.pp) 180 | 181 | let nameserver : Ipaddr.t option Term.t = 182 | let doc = "Nameserver to use" in 183 | Arg.(value & opt (some parse_ip) None & info [ "nameserver" ] ~docv:"NAMESERVER" ~doc) 184 | 185 | let arg_typ : string Term.t = 186 | let doc = "Type to query" in 187 | Arg.(value & opt string "A" & info ["type"] ~docv:"TYPE" ~doc) 188 | 189 | let cmd = 190 | let term = 191 | Term.(term_result (const jump $ Dns_cli.setup_log $ arg_domain $ arg_typ $ nameserver)) 192 | and info = Cmd.info "odnssec" ~version:"%%VERSION_NUM%%" 193 | in 194 | Cmd.v info term 195 | 196 | let () = exit (Cmd.eval cmd) 197 | -------------------------------------------------------------------------------- /app/onotify.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2019 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | let notify zone serial key now = 6 | let raw_zone = Domain_name.raw zone in 7 | let question = Packet.Question.create raw_zone Soa 8 | and soa = 9 | { Soa.nameserver = raw_zone ; hostmaster = raw_zone ; serial ; 10 | refresh = 0l; retry = 0l ; expiry = 0l ; minimum = 0l } 11 | and header = Randomconv.int16 Mirage_crypto_rng.generate, Packet.Flags.singleton `Authoritative 12 | in 13 | let p = Packet.create header question (`Notify (Some soa)) in 14 | match key with 15 | | None -> Ok (p, fst (Packet.encode `Tcp p), None) 16 | | Some (keyname, _, dnskey) -> 17 | Logs.debug (fun m -> m "signing with key %a: %a" Domain_name.pp keyname Dnskey.pp dnskey) ; 18 | match Dns_tsig.encode_and_sign ~proto:`Tcp p now dnskey keyname with 19 | | Ok (cs, mac) -> Ok (p, cs, Some mac) 20 | | Error e -> Error e 21 | 22 | let jump _ serverip port zone key serial = 23 | Mirage_crypto_rng_unix.use_default (); 24 | let now = Ptime_clock.now () in 25 | Logs.app (fun m -> m "notifying to %a:%d zone %a serial %lu" 26 | Ipaddr.pp serverip port Domain_name.pp zone serial) ; 27 | match notify zone serial key now with 28 | | Error s -> Error (`Msg (Fmt.str "signing %a" Dns_tsig.pp_s s)) 29 | | Ok (request, data, mac) -> 30 | let data_len = String.length data in 31 | Logs.debug (fun m -> m "built data %d" data_len) ; 32 | let socket = Dns_cli.connect_tcp serverip port in 33 | Dns_cli.send_tcp socket data ; 34 | let read_data = Dns_cli.recv_tcp socket in 35 | Unix.close socket ; 36 | match key with 37 | | None -> 38 | begin match Packet.decode read_data with 39 | | Ok reply -> 40 | begin match Packet.reply_matches_request ~request reply with 41 | | Ok `Notify_ack -> 42 | Logs.app (fun m -> m "successful notify!") ; 43 | Ok () 44 | | Ok r -> Error (`Msg (Fmt.str "expected notify ack, got %a" Packet.pp_reply r)) 45 | | Error e -> Error (`Msg (Fmt.str "notify reply %a is not ok %a" 46 | Packet.pp reply Packet.pp_mismatch e)) 47 | end 48 | | Error e -> 49 | Error (`Msg (Fmt.str "failed to decode notify reply! %a" Packet.pp_err e)) 50 | end 51 | | Some (keyname, _, dnskey) -> 52 | match Dns_tsig.decode_and_verify now dnskey keyname ?mac read_data with 53 | | Error e -> 54 | Error (`Msg (Fmt.str "failed to decode TSIG signed notify reply! %a" Dns_tsig.pp_e e)) 55 | | Ok (reply, _, _) -> 56 | match Packet.reply_matches_request ~request reply with 57 | | Ok `Notify_ack -> 58 | Logs.app (fun m -> m "successful TSIG signed notify!") ; 59 | Ok () 60 | | Ok r -> Error (`Msg (Fmt.str "expected notify ack, got %a" Packet.pp_reply r)) 61 | | Error e -> 62 | Error (`Msg (Fmt.str "expected reply to %a %a, got %a!" 63 | Packet.pp_mismatch e 64 | Packet.pp request Packet.pp reply)) 65 | 66 | open Cmdliner 67 | 68 | let serverip = 69 | let doc = "IP address of DNS server" in 70 | Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"SERVERIP") 71 | 72 | let port = 73 | let doc = "Port to connect to" in 74 | Arg.(value & opt int 53 & info [ "port" ] ~doc) 75 | 76 | let serial = 77 | let doc = "Serial number" in 78 | Arg.(value & opt int32 1l & info [ "serial" ] ~doc) 79 | 80 | let key = 81 | let doc = "DNS HMAC secret (name:alg:b64key)" in 82 | Arg.(value & opt (some Dns_cli.namekey_c) None & info [ "key" ] ~doc ~docv:"KEY") 83 | 84 | let zone = 85 | let doc = "Zone to notify" in 86 | Arg.(required & pos 1 (some Dns_cli.name_c) None & info [] ~doc ~docv:"ZONE") 87 | 88 | let cmd = 89 | let info = Cmd.info "onotify" ~version:"%%VERSION_NUM%%" 90 | and term = 91 | Term.(term_result (const jump $ Dns_cli.setup_log $ serverip $ port $ zone $ key $ serial)) 92 | in 93 | Cmd.v info term 94 | 95 | let () = exit (Cmd.eval cmd) 96 | -------------------------------------------------------------------------------- /app/oupdate.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | let create_update zone hostname ip_address = 6 | let zone = Packet.Question.create zone Soa 7 | and update = 8 | let up = 9 | Domain_name.Map.singleton hostname 10 | [ 11 | Packet.Update.Remove (Rr_map.K A) ; 12 | Packet.Update.Add Rr_map.(B (A, (60l, Ipaddr.V4.Set.singleton ip_address))) 13 | ] 14 | in 15 | (Domain_name.Map.empty, up) 16 | and header = Randomconv.int16 Mirage_crypto_rng.generate, Packet.Flags.empty 17 | in 18 | Packet.create header zone (`Update update) 19 | 20 | let jump _ serverip port (keyname, zone, dnskey) hostname ip_address = 21 | Mirage_crypto_rng_unix.use_default (); 22 | let now = Ptime_clock.now () in 23 | Logs.app (fun m -> m "updating to %a:%d zone %a A 600 %a %a" 24 | Ipaddr.pp serverip port 25 | Domain_name.pp zone 26 | Domain_name.pp hostname 27 | Ipaddr.V4.pp ip_address) ; 28 | Logs.debug (fun m -> m "using key %a: %a" Domain_name.pp keyname Dns.Dnskey.pp dnskey) ; 29 | let p = create_update zone hostname ip_address in 30 | match Dns_tsig.encode_and_sign ~proto:`Tcp p now dnskey keyname with 31 | | Error s -> 32 | Error (`Msg (Fmt.str "tsig sign error %a" Dns_tsig.pp_s s)) 33 | | Ok (data, mac) -> 34 | let data_len = String.length data in 35 | Logs.debug (fun m -> m "built data %d" data_len) ; 36 | let socket = Dns_cli.connect_tcp serverip port in 37 | Dns_cli.send_tcp socket data ; 38 | let read_data = Dns_cli.recv_tcp socket in 39 | (try (Unix.close socket) with _ -> ()) ; 40 | match Dns_tsig.decode_and_verify now dnskey keyname ~mac read_data with 41 | | Error e -> 42 | Error (`Msg (Fmt.str "nsupdate error %a" Dns_tsig.pp_e e)) 43 | | Ok (reply, _, _) -> 44 | match Packet.reply_matches_request ~request:p reply with 45 | | Ok `Update_ack -> 46 | Logs.app (fun m -> m "successful and signed update!") ; 47 | Ok () 48 | | Ok r -> 49 | Error (`Msg (Fmt.str "nsupdate expected update ack, received %a" Packet.pp_reply r)) 50 | | Error e -> 51 | Error (`Msg (Fmt.str "nsupdate error %a (reply %a does not match request %a)" 52 | Packet.pp_mismatch e Packet.pp reply Packet.pp p)) 53 | 54 | open Cmdliner 55 | 56 | let serverip = 57 | let doc = "IP address of DNS server" in 58 | Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"SERVERIP") 59 | 60 | let port = 61 | let doc = "Port to connect to" in 62 | Arg.(value & opt int 53 & info [ "port" ] ~doc) 63 | 64 | let key = 65 | let doc = "DNS HMAC secret (name:alg:b64key where name is yyy._update.zone)" in 66 | Arg.(required & pos 1 (some Dns_cli.namekey_c) None & info [] ~doc ~docv:"KEY") 67 | 68 | let hostname = 69 | let doc = "Hostname to modify" in 70 | Arg.(required & pos 2 (some Dns_cli.domain_name_c) None & info [] ~doc ~docv:"HOSTNAME") 71 | 72 | let ipv4_c = 73 | Arg.conv' 74 | ((fun s -> 75 | match Ipaddr.V4.of_string s with 76 | | Ok ip -> Ok ip 77 | | Error (`Msg m) -> Error ("failed to parse IP address: " ^ m)), 78 | Ipaddr.V4.pp) 79 | 80 | let ip_address = 81 | let doc = "New IP address" in 82 | Arg.(required & pos 3 (some ipv4_c) None & info [] ~doc ~docv:"IP") 83 | 84 | let cmd = 85 | let term = 86 | Term.(term_result (const jump $ Dns_cli.setup_log $ serverip $ port $ key $ hostname $ ip_address)) 87 | and info = Cmd.info "oupdate" ~version:"%%VERSION_NUM%%" 88 | in 89 | Cmd.v info term 90 | 91 | let () = exit (Cmd.eval cmd) 92 | -------------------------------------------------------------------------------- /app/ozone.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2019 Hannes Mehnert, all rights reserved *) 2 | 3 | (* goal is to check a given zonefile whether it is valid (and to-be-used 4 | by an authoritative NS - i.e. there must be a SOA record, TTL are good) 5 | if a NS/MX name is within the zone, it needs an address record 6 | the name of the file is taken as the domain name *) 7 | open Dns 8 | 9 | let ( let* ) = Result.bind 10 | 11 | let load_zone zone = 12 | let* data = Bos.OS.File.read Fpath.(v zone) in 13 | let* rrs = Dns_zone.parse data in 14 | let domain = Domain_name.of_string_exn Fpath.(basename (v zone)) in 15 | let bad = Domain_name.Map.filter 16 | (fun name _ -> not (Domain_name.is_subdomain ~domain ~subdomain:name)) 17 | rrs 18 | in 19 | if not (Domain_name.Map.is_empty bad) then 20 | Error (`Msg (Fmt.str "Entries of domain '%a' are not in its zone, won't handle this:@.%a" 21 | Domain_name.pp domain Dns.Name_rr_map.pp bad)) 22 | else 23 | Ok (Dns_trie.insert_map rrs Dns_trie.empty) 24 | 25 | let jump _ zone old = 26 | let* trie = load_zone zone in 27 | let* () = 28 | Result.map_error 29 | (fun e -> `Msg (Fmt.to_to_string Dns_trie.pp_zone_check e)) 30 | (Dns_trie.check trie) 31 | in 32 | Logs.app (fun m -> m "successfully checked zone") ; 33 | let zones = 34 | Dns_trie.fold Soa trie 35 | (fun name _ acc -> Domain_name.Set.add name acc) 36 | Domain_name.Set.empty 37 | in 38 | if Domain_name.Set.cardinal zones = 1 then 39 | let zone = Domain_name.Set.choose zones in 40 | let* zone_data = Dns_server.text zone trie in 41 | Logs.debug (fun m -> m "assembled zone data %s" zone_data) ; 42 | (match old with 43 | | None -> Ok () 44 | | Some fn -> 45 | let* old = load_zone fn in 46 | match Dns_trie.lookup zone Soa trie, Dns_trie.lookup zone Soa old with 47 | | Ok fresh, Ok old when Soa.newer ~old fresh -> 48 | Logs.debug (fun m -> m "zone %a newer than old" Domain_name.pp zone) ; 49 | Ok () 50 | | _ -> 51 | Error (`Msg "SOA comparison wrong")) 52 | else 53 | Error (`Msg "expected exactly one zone") 54 | 55 | open Cmdliner 56 | 57 | let newzone = 58 | let doc = "New zone file" in 59 | Arg.(required & pos 0 (some file) None & info [] ~doc ~docv:"ZONE") 60 | 61 | let oldzone = 62 | let doc = "Old zone file" in 63 | Arg.(value & opt (some file) None & info [ "old" ] ~doc ~docv:"ZONE") 64 | 65 | let cmd = 66 | let term = 67 | Term.(term_result (const jump $ Dns_cli.setup_log $ newzone $ oldzone)) 68 | and info = Cmd.info "ozone" ~version:"%%VERSION_NUM%%" 69 | in 70 | Cmd.v info term 71 | 72 | let () = exit (Cmd.eval cmd) 73 | -------------------------------------------------------------------------------- /app/resolver.ml: -------------------------------------------------------------------------------- 1 | 2 | module Resolver = Dns_resolver_mirage.Make(Tcpip_stack_socket.V4V6) 3 | 4 | open Lwt.Infix 5 | 6 | let main () = 7 | Mirage_crypto_rng_unix.use_default (); 8 | Udpv4v6_socket.connect ~ipv4_only:true ~ipv6_only:false Ipaddr.V4.Prefix.global None >>= fun udp -> 9 | Tcpv4v6_socket.connect ~ipv4_only:true ~ipv6_only:false Ipaddr.V4.Prefix.global None >>= fun tcp -> 10 | Tcpip_stack_socket.V4V6.connect udp tcp >>= fun stack -> 11 | let resolver = 12 | let primary_t = 13 | (* setup DNS server state: *) 14 | Dns_server.Primary.create ~rng:Mirage_crypto_rng.generate Dns_trie.empty 15 | in 16 | Dns_resolver.create ~dnssec:true ~ip_protocol:`Ipv4_only 17 | (Mirage_mtime.elapsed_ns ()) Mirage_crypto_rng.generate primary_t 18 | in 19 | let _fn = Resolver.resolver ~port:53530 stack resolver in 20 | Tcpip_stack_socket.V4V6.listen stack >|= fun () -> 21 | Ok () 22 | 23 | let jump () = 24 | Lwt_main.run (main ()) 25 | 26 | open Cmdliner 27 | 28 | let cmd = 29 | let term = 30 | Term.(term_result (const jump $ Dns_cli.setup_log)) 31 | and info = Cmd.info "resolver" ~version:"%%VERSION_NUM%%" 32 | in 33 | Cmd.v info term 34 | 35 | let () = exit (Cmd.eval cmd) 36 | -------------------------------------------------------------------------------- /cache/dns_cache.mli: -------------------------------------------------------------------------------- 1 | (** DNS cache - a least recently used cache of DNS responses 2 | 3 | This data structure allows to insert and retrieve entries into a least 4 | recently used data structure. An [`Entry] weights the cardinality of the 5 | resource record map, all other entries have a weight of 1. 6 | 7 | The time to live is preserved, and when it is exceeded the entry is no 8 | longer returned. 9 | *) 10 | 11 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 12 | open Dns 13 | 14 | (** The variant of the rank in the cache. *) 15 | type rank = 16 | | ZoneFile 17 | | ZoneTransfer 18 | | AuthoritativeAnswer of Rrsig.t option 19 | | AuthoritativeAuthority of Rrsig.t option 20 | | ZoneGlue 21 | | NonAuthoritativeAnswer 22 | | Additional 23 | 24 | val pp_rank : rank Fmt.t 25 | (** [pp_rank ppf rank] pretty-prints the [rank] on [ppf]. *) 26 | 27 | val compare_rank : rank -> rank -> int 28 | (** [compare_rank a b] compares the ranks [a] with [b]. *) 29 | 30 | (** The type of a DNS cache. *) 31 | type t 32 | 33 | val empty : int -> t 34 | (** [empty maximum_size] is an empty DNS cache with the maximum size as 35 | capacity. *) 36 | 37 | val size : t -> int 38 | (** [size cache] is the number of bindings currently in the [cache]. *) 39 | 40 | val capacity : t -> int 41 | (** [capacity cache] is the used weight. *) 42 | 43 | val pp : t Fmt.t 44 | (** [pp ppf t] pretty prints the cache [t] on [ppf]. *) 45 | 46 | (** The polymorphic variant of an entry: a resource record, or no data, 47 | no domain, or a server failure. *) 48 | type 'a entry = [ 49 | | `Entry of 'a 50 | | `No_data of [ `raw ] Domain_name.t * Soa.t 51 | | `No_domain of [ `raw ] Domain_name.t * Soa.t 52 | | `Serv_fail of [ `raw ] Domain_name.t * Soa.t 53 | ] 54 | 55 | val pp_entry : 'a Rr_map.key -> 'a entry Fmt.t 56 | (** [pp_entry ppf entry] pretty-prints [entry] on [ppf]. *) 57 | 58 | val get : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key -> 59 | t * ('a entry * rank, [ `Cache_miss | `Cache_drop ]) result 60 | (** [get cache timestamp type name] retrieves the query [type, name] from the 61 | [cache] using [timestamp]. If the time to live is exceeded, a [`Cache_drop] 62 | is returned. If there is no entry in the cache, a [`Cache_miss] is 63 | returned. *) 64 | 65 | val get_or_cname : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key -> 66 | t * ([ 'a entry | `Alias of int32 * [`raw] Domain_name.t] * rank, 67 | [ `Cache_miss | `Cache_drop ]) result 68 | (** [get_or_cname cache timestamp type name] is the same as [get], but if a 69 | [`Cache_miss] is encountered, a lookup for an alias (CNAME) is done. *) 70 | 71 | val get_any : t -> int64 -> [ `raw ] Domain_name.t -> 72 | t * ([ `Entries of Rr_map.t 73 | | `No_domain of [ `raw ] Domain_name.t * Soa.t ] * rank, 74 | [ `Cache_miss | `Cache_drop ]) result 75 | (** [get_any cache timestamp name] retrieves all resource records for [name] 76 | in [cache]. *) 77 | 78 | val get_nsec3 : t -> int64 -> [ `raw ] Domain_name.t -> 79 | t * (([`raw] Domain_name.t * int32 * Nsec3.t * rank) list, [ `Cache_miss | `Cache_drop ]) result 80 | (** [get_nsec3 cache timestamp name] retrieves all nsec3 resource records for 81 | the zone [name]. *) 82 | 83 | val set : t -> int64 -> [ `raw ] Domain_name.t -> 'a Rr_map.key -> rank -> 84 | 'a entry -> t 85 | (** [set cache timestamp type name rank value] attempts to insert 86 | [type, name, value] into the [cache] using the [timestamp] and [rank]. If 87 | an entry already exists with a higher [rank], the [cache] is unchanged. *) 88 | 89 | val remove : t -> [ `raw ] Domain_name.t -> t 90 | (** [remove cache name] removes [name] from [cache]. *) 91 | -------------------------------------------------------------------------------- /cache/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_cache) 3 | (public_name dns.cache) 4 | (modules dns_cache) 5 | (libraries domain-name dns duration lru metrics) 6 | (wrapped false)) 7 | -------------------------------------------------------------------------------- /certify/dns_certify.ml: -------------------------------------------------------------------------------- 1 | open Dns 2 | 3 | let src = Logs.Src.create "dns_certify" ~doc:"DNS certify" 4 | module Log = (val Logs.src_log src : Logs.LOG) 5 | 6 | let tlsa_is usage sel typ t = 7 | t.Tlsa.cert_usage = usage && 8 | t.Tlsa.selector = sel && 9 | t.Tlsa.matching_type = typ 10 | 11 | let is_csr t = 12 | tlsa_is Tlsa.Domain_issued_certificate Tlsa.Private Tlsa.No_hash t 13 | 14 | let csr req = 15 | let data = X509.Signing_request.encode_der req in 16 | { 17 | Tlsa.matching_type = Tlsa.No_hash ; 18 | cert_usage = Tlsa.Domain_issued_certificate ; 19 | selector = Tlsa.Private ; 20 | data 21 | } 22 | 23 | let is_certificate t = 24 | tlsa_is Tlsa.Domain_issued_certificate Tlsa.Full_certificate Tlsa.No_hash t 25 | 26 | let certificate cert = 27 | let data = X509.Certificate.encode_der cert in 28 | { 29 | Tlsa.matching_type = Tlsa.No_hash ; 30 | cert_usage = Tlsa.Domain_issued_certificate ; 31 | selector = Tlsa.Full_certificate ; 32 | data 33 | } 34 | 35 | let is_ca_certificate t = 36 | tlsa_is Tlsa.CA_constraint Tlsa.Full_certificate Tlsa.No_hash t 37 | 38 | let ca_certificate data = { 39 | Tlsa.matching_type = Tlsa.No_hash ; 40 | cert_usage = Tlsa.CA_constraint ; 41 | selector = Tlsa.Full_certificate ; 42 | data 43 | } 44 | 45 | let signing_request hostname ?(more_hostnames = []) key = 46 | let host = Domain_name.to_string hostname in 47 | let extensions = 48 | match more_hostnames with 49 | | [] -> X509.Signing_request.Ext.empty 50 | | _ -> 51 | let ext = 52 | let additional = List.map Domain_name.to_string more_hostnames in 53 | let gn = X509.General_name.(singleton DNS (host :: additional)) in 54 | X509.Extension.(singleton Subject_alt_name (false, gn)) 55 | in 56 | X509.Signing_request.Ext.(singleton Extensions ext) 57 | in 58 | X509.(Signing_request.create 59 | [Distinguished_name.(Relative_distinguished_name.singleton (CN host))] 60 | ~extensions key) 61 | 62 | let dns_header rng = 63 | let id = Randomconv.int16 rng in 64 | (id, Packet.Flags.empty) 65 | 66 | let le_label = "_letsencrypt" 67 | and p_label = "_tcp" 68 | 69 | let is_name name = 70 | if Domain_name.count_labels name < 2 then 71 | false 72 | else 73 | Domain_name.(equal_label le_label (get_label_exn name 0) && 74 | equal_label p_label (get_label_exn name 1)) 75 | 76 | let letsencrypt_name name = 77 | match Domain_name.(prepend_label (raw name) p_label) with 78 | | Ok name' -> Domain_name.prepend_label name' le_label 79 | | Error e -> Error e 80 | 81 | type u_err = [ `Tsig of Dns_tsig.e | `Bad_reply of Packet.mismatch * Packet.t | `Unexpected_reply of Packet.reply ] 82 | 83 | let pp_u_err ppf = function 84 | | `Tsig e -> Fmt.pf ppf "tsig error %a" Dns_tsig.pp_e e 85 | | `Bad_reply (e, res) -> Fmt.pf ppf "bad reply %a: %a" Packet.pp_mismatch e Packet.pp res 86 | | `Unexpected_reply r -> Fmt.pf ppf "unexpected reply %a" Packet.pp_reply r 87 | 88 | let nsupdate rng now ~host ~keyname ~zone dnskey request = 89 | match letsencrypt_name host with 90 | | Error e -> Error e 91 | | Ok host -> 92 | let tlsa = csr request in 93 | let zone = Packet.Question.create zone Soa 94 | and update = 95 | let up = 96 | Domain_name.Map.singleton host 97 | [ 98 | Packet.Update.Remove (K Tlsa) ; 99 | Packet.Update.Add (B (Tlsa, (3600l, Rr_map.Tlsa_set.singleton tlsa))) 100 | ] 101 | in 102 | (Domain_name.Map.empty, up) 103 | and header = dns_header rng 104 | in 105 | let packet = Packet.create header zone (`Update update) in 106 | let now = now () in 107 | match Dns_tsig.encode_and_sign ~proto:`Tcp packet now dnskey keyname with 108 | | Error e -> Error (`Msg (Fmt.to_to_string Dns_tsig.pp_s e)) 109 | | Ok (data, mac) -> 110 | Ok (data, (fun data -> 111 | match Dns_tsig.decode_and_verify now dnskey keyname ~mac data with 112 | | Error e -> Error (`Tsig e) 113 | | Ok (res, _, _) -> 114 | match Packet.reply_matches_request ~request:packet res with 115 | | Ok `Update_ack -> Ok () 116 | | Ok r -> Error (`Unexpected_reply r) 117 | | Error e -> Error (`Bad_reply (e, res)))) 118 | 119 | type q_err = [ 120 | | `Decode of Packet.err 121 | | `Bad_reply of Packet.mismatch * Packet.t 122 | | `Unexpected_reply of Packet.reply 123 | | `No_tlsa 124 | ] 125 | 126 | let pp_q_err ppf = function 127 | | `Decode err -> Fmt.pf ppf "decoding failed %a" Packet.pp_err err 128 | | `Bad_reply (e, res) -> Fmt.pf ppf "bad reply %a: %a" Packet.pp_mismatch e Packet.pp res 129 | | `Unexpected_reply r -> Fmt.pf ppf "unexpected reply %a" Packet.pp_reply r 130 | | `No_tlsa -> Fmt.pf ppf "No TLSA record found" 131 | 132 | (* may be better suited in X509? *) 133 | let cert_matches_csr ?until now csr cert = 134 | let until = match until with None -> now | Some x -> x in 135 | let csr_key = X509.Signing_request.((info csr).public_key) 136 | and csr_hostnames = X509.Signing_request.hostnames csr 137 | and cert_key = X509.Certificate.public_key cert 138 | and cert_hostnames = X509.Certificate.hostnames cert 139 | and (st, en) = X509.Certificate.validity cert 140 | in 141 | let valid = Ptime.is_later ~than:st now && Ptime.is_later ~than:until en in 142 | if not (String.equal (X509.Public_key.fingerprint cert_key) (X509.Public_key.fingerprint csr_key)) then begin 143 | Log.info (fun m -> m "public key of CSR and certificate %a do not match" 144 | X509.Certificate.pp cert); 145 | false 146 | end else if not (X509.Host.Set.equal cert_hostnames csr_hostnames) then begin 147 | Log.info (fun m -> m "hostnames of CSR %a and certificate %a do not match" 148 | X509.Host.Set.pp csr_hostnames X509.Host.Set.pp cert_hostnames); 149 | false 150 | end else if not valid then begin 151 | let pp_pt = Ptime.pp_rfc3339 () in 152 | Log.info (fun m -> m "Certificate is not valid now %a (until %a), it is \ 153 | valid from %a until %a)" 154 | pp_pt now pp_pt until pp_pt st pp_pt en); 155 | false 156 | end else 157 | true 158 | 159 | let tlsas_to_certchain host now csr tlsas = 160 | let certificates, ca_certificates = 161 | Rr_map.Tlsa_set.fold (fun tlsa (certs, cacerts as acc) -> 162 | if is_certificate tlsa || is_ca_certificate tlsa then 163 | match X509.Certificate.decode_der tlsa.Tlsa.data with 164 | | Error (`Msg msg) -> 165 | Log.warn (fun m -> m "couldn't decode tlsa record %a: %s (%a)" 166 | Domain_name.pp host msg 167 | Ohex.pp tlsa.Tlsa.data); 168 | acc 169 | | Ok cert -> 170 | match is_certificate tlsa, is_ca_certificate tlsa with 171 | | true, _ -> (cert :: certs, cacerts) 172 | | _, true -> (certs, cert :: cacerts) 173 | | _ -> acc 174 | else acc) 175 | tlsas ([], []) 176 | in 177 | match List.find_opt (cert_matches_csr now csr) certificates with 178 | | None -> Error `No_tlsa 179 | | Some server_cert -> 180 | match List.rev (X509.Validation.build_paths server_cert ca_certificates) with 181 | | (_server :: chain) :: _ -> Ok (server_cert, chain) 182 | | _ -> Ok (server_cert, []) (* build_paths always returns the server_cert *) 183 | 184 | let query rng now host csr = 185 | match letsencrypt_name host with 186 | | Error e -> Error e 187 | | Ok host -> 188 | let header = dns_header rng 189 | and question = Packet.Question.create host Tlsa 190 | in 191 | let request = Packet.create header question `Query in 192 | let out, _ = Packet.encode `Tcp request 193 | and react data = 194 | match Packet.decode data with 195 | | Error e -> Error (`Decode e) 196 | | Ok reply -> 197 | match Packet.reply_matches_request ~request reply with 198 | | Ok (`Answer (answer, _)) -> 199 | begin match Name_rr_map.find host Tlsa answer with 200 | | None -> Error `No_tlsa 201 | | Some (_, tlsas) -> tlsas_to_certchain host now csr tlsas 202 | end 203 | | Ok (`Rcode_error (Rcode.NXDomain, Opcode.Query, _)) -> Error `No_tlsa 204 | | Ok reply -> Error (`Unexpected_reply reply) 205 | | Error e -> Error (`Bad_reply (e, reply)) 206 | in 207 | Ok (out, react) 208 | -------------------------------------------------------------------------------- /certify/dns_certify.mli: -------------------------------------------------------------------------------- 1 | open Dns 2 | 3 | val signing_request : [`host] Domain_name.t -> 4 | ?more_hostnames:([`raw] Domain_name.t list) -> 5 | X509.Private_key.t -> (X509.Signing_request.t, [> `Msg of string ]) result 6 | (** [signing_request name ~more_hostnames key] creates a X509 signing request 7 | where [name] will be the common name in its subject, and if [more_hostnames] 8 | is provided and non-empty, [name :: more_hostnames] will be the value of a 9 | subjectAlternativeName extension. *) 10 | 11 | val letsencrypt_name : 'a Domain_name.t -> 12 | ([ `raw ] Domain_name.t, [> `Msg of string ]) result 13 | (** [letsencrypt_name host] is the service name at which we store let's encrypt 14 | certificates for the [host]. *) 15 | 16 | val is_csr : Dns.Tlsa.t -> bool 17 | (** [is_csr tlsa] is true if [tlsa] is a certificate signing request (cert_usage 18 | is Domain_issued_certificate, selector is Private, and matching_type is 19 | No_hash). *) 20 | 21 | val csr : X509.Signing_request.t -> Dns.Tlsa.t 22 | (** [csr req] is the signing request [req] encoded as TLSA record. *) 23 | 24 | val is_certificate : Dns.Tlsa.t -> bool 25 | (** [is_certificate tlsa] is true if [tlsa] is a certificate (cert_usage is 26 | Domain_issued_certificate, selector is Full_certificate, and matching_type 27 | is No_hash). *) 28 | 29 | val certificate : X509.Certificate.t -> Dns.Tlsa.t 30 | (** [certificate crt] is the certificate [crt] encoded as TLSA record. *) 31 | 32 | val is_ca_certificate : Dns.Tlsa.t -> bool 33 | (** [is_ca_certificate tlsa] is true if [tlsa] is a CA certificate (cert_usage 34 | is CA_constraint, selector is Full_certificate, and matching_type is 35 | No_hash). *) 36 | 37 | val ca_certificate : string -> Dns.Tlsa.t 38 | (** [ca_certificate data] is the CA certificate [data] encoded as TLSA record. *) 39 | 40 | val is_name : 'a Domain_name.t -> bool 41 | (** [is_name domain_name] is true if it contains the prefix used in this 42 | library ("_letsencrypt._tcp"). *) 43 | 44 | type u_err = [ 45 | | `Tsig of Dns_tsig.e 46 | | `Bad_reply of Packet.mismatch * Packet.t 47 | | `Unexpected_reply of Packet.reply 48 | ] 49 | (** The type of update errors. *) 50 | 51 | val pp_u_err : u_err Fmt.t 52 | (** [pp_u_err ppf u] pretty-prints [u] on [ppf]. *) 53 | 54 | val nsupdate : (int -> string) -> (unit -> Ptime.t) -> 55 | host:[ `host ] Domain_name.t -> keyname:'b Domain_name.t -> 56 | zone:[ `host ] Domain_name.t -> Dns.Dnskey.t -> X509.Signing_request.t -> 57 | (string * (string -> (unit, [> u_err ]) result), 58 | [> `Msg of string ]) result 59 | (** [nsupdate rng now ~host ~keyname ~zone dnskey csr] is a buffer with a DNS 60 | update that removes all TLSA records from the given [host], and adds a single 61 | TLSA record containing the certificate signing request. It also returns a 62 | function which decodes a given answer, checks it to be a valid reply, and 63 | returns either unit or an error. The outgoing packet is signed with the 64 | provided [dnskey], the answer is checked to be signed by the same key. If 65 | the sign operation fails, [nsupdate] returns an error. *) 66 | 67 | type q_err = [ 68 | | `Decode of Packet.err 69 | | `Bad_reply of Packet.mismatch * Packet.t 70 | | `Unexpected_reply of Packet.reply 71 | | `No_tlsa 72 | ] 73 | (** The type for query errors. *) 74 | 75 | val pp_q_err : q_err Fmt.t 76 | (** [pp_q_err ppf q] pretty-prints [q] on [ppf]. *) 77 | 78 | val cert_matches_csr : ?until:Ptime.t -> Ptime.t -> X509.Signing_request.t -> 79 | X509.Certificate.t -> bool 80 | (** [cert_matches_csr ~until now csr cert] is [true] if [cert] matches the 81 | signing request [csr], and is valid from [now] until [until] (defaults to 82 | [now]). The matching is [true] if the public key matches, and the set of 83 | hostnames in [csr] and [cert] are equal. A log message on the info level 84 | is emitted if the return value if [false]. *) 85 | 86 | val query : (int -> string) -> Ptime.t -> [ `host ] Domain_name.t -> 87 | X509.Signing_request.t -> 88 | (string * 89 | (string -> (X509.Certificate.t * X509.Certificate.t list, [> q_err ]) result), 90 | [> `Msg of string ]) result 91 | (** [query rng now csr] is a [buffer] with a DNS TLSA query for the name of 92 | [csr], and a function that decodes a given answer, either returning a X.509 93 | certificate valid [now] and matching [csr], and a CA chain, or an error. *) 94 | -------------------------------------------------------------------------------- /certify/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_certify) 3 | (public_name dns-certify) 4 | (wrapped false) 5 | (libraries dns dns-tsig x509 randomconv logs mirage-crypto-ec mirage-crypto-pk)) 6 | -------------------------------------------------------------------------------- /client/dns_client.mli: -------------------------------------------------------------------------------- 1 | (* TODO ideally there'd be something like mirage-flow-lwt that didn't depend 2 | on lwt and a ton of other things, and still provided [map] 3 | and [connect] and so on. leaving this stuff here for now until a 4 | better solution presents itself. *) 5 | 6 | val default_resolver_hostname : [`host] Domain_name.t 7 | 8 | val default_resolvers : Ipaddr.t list 9 | (** [default_resolver] is a list of IPv6 and IPv4 address of the default 10 | resolver. Currently it is the IP address of the UncensoredDNS.org 11 | anycast service. *) 12 | 13 | module type S = sig 14 | type context 15 | (** A context is a network connection initialized by {!connect} *) 16 | 17 | type +'a io 18 | (** [io] is the type of an effect. ['err] is a polymorphic variant. *) 19 | 20 | type io_addr 21 | (** An address for a given context type, usually this will consist of 22 | IP address + a TCP/IP or UDP/IP port number, but for some context types 23 | it can carry additional information for purposes of cryptographic 24 | verification. *) 25 | 26 | type stack 27 | (** A stack with which to connect. *) 28 | 29 | type t 30 | (** The abstract state of a DNS client. *) 31 | 32 | val create : ?nameservers:(Dns.proto * io_addr list) -> timeout:int64 -> 33 | stack -> t 34 | (** [create ~nameservers ~timeout stack] creates the state record of 35 | the DNS client. We use [timeout] (ns) as a cumulative time budget for 36 | connect and request timeouts. *) 37 | 38 | val nameservers : t -> Dns.proto * io_addr list 39 | (** The address of a nameservers that is supposed to work with 40 | the underlying context, can be used if the user does not want to 41 | bother with configuring their own.*) 42 | 43 | val rng : int -> string 44 | (** [rng t] is a random number generator. *) 45 | 46 | val clock : unit -> int64 47 | (** [clock t] is the monotonic clock. *) 48 | 49 | val connect : t -> (Dns.proto * context, [> `Msg of string ]) result io 50 | (** [connect t] is a new connection ([context]) to [t], or an error. *) 51 | 52 | val send_recv : context -> string -> (string, [> `Msg of string ]) result io 53 | (** [send_recv context buffer] sends [buffer] to the [context] upstream, and 54 | then reads a buffer. *) 55 | 56 | val close : context -> unit io 57 | (** [close context] closes the [context], freeing up resources. *) 58 | 59 | val bind : 'a io -> ('a -> 'b io) -> 'b io 60 | (** a.k.a. [>>=] *) 61 | 62 | val lift : 'a -> 'a io 63 | end 64 | 65 | module Make : functor (T : S) -> 66 | sig 67 | 68 | type t 69 | (** The abstract type of a DNS client. *) 70 | 71 | val transport : t -> T.t 72 | (** [transport t] is the transport of [t]. *) 73 | 74 | val create : ?cache_size:int -> 75 | ?edns:[ `None | `Auto | `Manual of Dns.Edns.t ] -> 76 | ?nameservers:(Dns.proto * T.io_addr list) -> ?timeout:int64 -> 77 | T.stack -> t 78 | (** [create ~cache_size ~edns ~nameservers ~timeout stack] creates the state 79 | of the DNS client. We use [timeout] (ns, default 5s) as a time budget for 80 | connect and request timeouts. To specify a timeout, use 81 | [create ~timeout:(Duration.of_sec 3)]. Whether or not to use 82 | {{:https://tools.ietf.org/html/rfc6891}EDNS} in queries is controlled 83 | by [~edns] (defaults to [`None]): if [None], no EDNS will be present, 84 | [`Auto] adds TCP Keepalive if protocol is TCP, [`Manual edns] adds the 85 | EDNS data specified. *) 86 | 87 | val nameservers : t -> Dns.proto * T.io_addr list 88 | (** [nameservers state] returns the list of nameservers to be used. *) 89 | 90 | val getaddrinfo : t -> 'response Dns.Rr_map.key -> 91 | 'a Domain_name.t -> 92 | ('response, [> `Msg of string ]) result T.io 93 | (** [getaddrinfo state query_type name] is the 94 | [query_type]-dependent response regarding [name], or 95 | an [Error _] message. See {!Dns_client.query_state} for more information 96 | about the result types. *) 97 | 98 | val gethostbyname : t -> [ `host ] Domain_name.t -> 99 | (Ipaddr.V4.t, [> `Msg of string ]) result T.io 100 | (** [gethostbyname state hostname] is the IPv4 address of 101 | [hostname] resolved via the [state] specified. 102 | If the query fails, or if the [domain] does not have any IPv4 addresses, 103 | an [Error _] message is returned. Any extraneous IPv4 addresses are 104 | ignored. For an example of using this API, see [unix/ohost.ml] in the 105 | distribution of this package. *) 106 | 107 | val gethostbyname6 : t -> [ `host ] Domain_name.t -> 108 | (Ipaddr.V6.t, [> `Msg of string ]) result T.io 109 | (** [gethostbyname6 state hostname] is the IPv6 address of 110 | [hostname] resolved via the [state] specified. 111 | 112 | It is the IPv6 equivalent of {!gethostbyname}. *) 113 | 114 | val get_resource_record : t -> 'response Dns.Rr_map.key -> 'a Domain_name.t -> 115 | ('response, 116 | [> `Msg of string 117 | | `No_data of [ `raw ] Domain_name.t * Dns.Soa.t 118 | | `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ]) result T.io 119 | (** [get_resource_record state query_type name] resolves 120 | [query_type, name] via the [state] specified. The 121 | behaviour is equivalent to {!getaddrinfo}, apart from the error return 122 | value - [get_resource_record] distinguishes some errors, at the moment 123 | [No_data] if the [name] exists, but not the [query_type], and 124 | [No_domain] if the [name] does not exist. This allows clients to treat 125 | these error conditions explicitly. *) 126 | 127 | val get_raw_reply : t -> 'response Dns.Rr_map.key -> 128 | 'a Domain_name.t -> 129 | (Dns.Packet.reply, [> `Partial | `Msg of string ]) result T.io 130 | (** [get_raw_reply state query_type name] resolves [query_type, name] via the 131 | [state] specified. The complete DNS reply is returned. CNAME records 132 | are not followed. This allows DNSSec to process the entire reply. *) 133 | end 134 | 135 | module Pure : sig 136 | (** The pure interface to the client part of uDns. 137 | 138 | Various helper modules to do with side effects are available from 139 | {!Dns_client_lwt}, {!Dns_client_unix} and so forth. *) 140 | 141 | type 'key query_state constraint 'key = 'a Dns.Rr_map.key 142 | (** [query_state] is parameterized over the query type, so the type of the 143 | representation of the answer depends on what the name server was asked to 144 | provide. See {!Dns.Rr_map.k} for a list of response types. The first 145 | element (the [int32]) in most of the tuples is the Time-To-Live (TTL) 146 | field returned from the server, which you can use to calculate when you 147 | should request fresh information in case you are writing a long-running 148 | application. *) 149 | 150 | val make_query : 151 | (int -> string) -> Dns.proto -> ?dnssec:bool -> 152 | [ `None | `Auto | `Manual of Dns.Edns.t ] -> 153 | 'a Domain_name.t -> 154 | 'query_type Dns.Rr_map.key -> 155 | string * 'query_type Dns.Rr_map.key query_state 156 | (** [make_query rng protocol name query_type] is [query, query_state] 157 | where [query] is the serialized DNS query to send to the name server, 158 | and [query_state] is the information required to validate the response. *) 159 | 160 | val parse_response : 'query_type Dns.Rr_map.key query_state -> string -> 161 | (Dns.Packet.reply, [ `Partial | `Msg of string]) result 162 | (** [parse_response query_state response] is the information contained in 163 | [response] parsed using [query_state] when the query was successful, or 164 | an [`Msg message] if the [response] did not match the [query_state] 165 | (or if the query failed). 166 | 167 | In a TCP usage context the [`Partial] means there are more bytes to be 168 | read in order to parse correctly. This can happen due to short reads or if 169 | the server (or something along the route) chunks its responses into 170 | multiple individual packets. In that case you should concatenate 171 | [response] and the next received data and call this function again. 172 | 173 | In a UDP usage context the [`Partial] means information was lost, due to 174 | an incomplete packet. *) 175 | 176 | val handle_response : 'query_type Dns.Rr_map.key query_state -> string -> 177 | ( [ `Data of 'query_type 178 | | `Partial 179 | | `No_data of [`raw] Domain_name.t * Dns.Soa.t 180 | | `No_domain of [`raw] Domain_name.t * Dns.Soa.t ], 181 | [`Msg of string]) result 182 | (** [handle_response query_state response] is the information contained in 183 | [response] parsed using [query_state] when the query was successful, or 184 | an [`Msg message] if the [response] did not match the [query_state] 185 | (or if the query failed). 186 | 187 | In a TCP usage context the [`Partial] means there are more bytes to be 188 | read in order to parse correctly. This can happen due to short reads or if 189 | the server (or something along the route) chunks its responses into 190 | multiple individual packets. In that case you should concatenate 191 | [response] and the next received data and call this function again. 192 | 193 | In a UDP usage context the [`Partial] means information was lost, due to 194 | an incomplete packet. *) 195 | 196 | end 197 | -------------------------------------------------------------------------------- /client/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_client) 3 | (public_name dns-client) 4 | (modules dns_client) 5 | (libraries dns.cache domain-name dns randomconv) 6 | (wrapped false)) 7 | -------------------------------------------------------------------------------- /dns-certify.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | doc: "https://mirage.github.io/ocaml-dns/" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 8 | license: "BSD-2-Clause" 9 | 10 | depends: [ 11 | "dune" {>= "2.7.0"} 12 | "ocaml" {>= "4.13.0"} 13 | "dns" {= version} 14 | "dns-tsig" {= version} 15 | "dns-mirage" {= version} 16 | "randomconv" {>= "0.2.0"} 17 | "duration" {>= "0.1.2"} 18 | "x509" {>= "1.0.0"} 19 | "lwt" {>= "4.2.1"} 20 | "mirage-sleep" {>= "4.0.0"} 21 | "mirage-ptime" {>= "5.0.0"} 22 | "tcpip" {>= "8.2.0"} 23 | "logs" 24 | "mirage-crypto-ec" 25 | "mirage-crypto-pk" {>= "1.0.0"} 26 | "mirage-crypto-rng" {>= "1.0.0"} 27 | ] 28 | 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | ["dune" "build" "-p" name "-j" jobs] 32 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 33 | ] 34 | 35 | synopsis: "MirageOS let's encrypt certificate retrieval" 36 | description: """ 37 | A function to retrieve a certificate when providing a hostname, TSIG key, server 38 | IP, and an optional key seed. Best used with an letsencrypt unikernel. 39 | """ 40 | x-maintenance-intent: [ "(latest)" ] 41 | -------------------------------------------------------------------------------- /dns-cli.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | doc: "https://mirage.github.io/ocaml-dns/" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 8 | license: "BSD-2-Clause" 9 | 10 | depends: [ 11 | "dune" {>= "2.7.0"} 12 | "ocaml" {>= "4.13.0"} 13 | "dns" {= version} 14 | "dnssec" {= version} 15 | "dns-tsig" {= version} 16 | "dns-client-lwt" {= version} 17 | "dns-server" {= version} 18 | "dns-certify" {= version} 19 | "dns-resolver" {= version} 20 | "bos" {>= "0.2.0"} 21 | "cmdliner" {>= "1.1.0"} 22 | "fpath" {>= "0.7.2"} 23 | "x509" {>= "1.0.0"} 24 | "mirage-crypto" {>= "1.0.0"} 25 | "mirage-crypto-pk" {>= "1.0.0"} 26 | "mirage-crypto-rng" {>= "2.0.0"} 27 | "mirage-mtime" {>= "5.0.0"} 28 | "mtime" {>= "2.1.0"} 29 | "ptime" {>= "1.2.0"} 30 | "tcpip" {>= "8.2.0"} 31 | "ohex" {>= "0.2.0"} 32 | "logs" {>= "0.6.3"} 33 | "fmt" {>= "0.8.8"} 34 | "ipaddr" {>= "4.0.0"} 35 | "lwt" {>= "4.0.0"} 36 | "randomconv" {>= "0.2.0"} 37 | "alcotest" {with-test} 38 | ] 39 | 40 | build: [ 41 | ["dune" "subst"] {dev} 42 | ["dune" "build" "-p" name "-j" jobs] 43 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 44 | ] 45 | 46 | synopsis: "Unix command line utilities using uDNS" 47 | description: """ 48 | 'oupdate' sends a DNS update frome to a DNS server that sets 'hostname A ip'. 49 | For authentication via TSIG, a hmac secret needs to be provided. 50 | 51 | 'ocertify' updates DNS with a certificate signing request, and polls a matching 52 | certificate. Best used with an letsencrypt unikernel. 53 | """ 54 | x-maintenance-intent: [ "(latest)" ] 55 | -------------------------------------------------------------------------------- /dns-client-lwt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Joe Hill"] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | license: "BSD-2-Clause" 8 | 9 | build: [ 10 | [ "dune" "subst"] {dev} 11 | [ "dune" "build" "-p" name "-j" jobs ] 12 | [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} 13 | ] 14 | 15 | depends: [ 16 | "dune" {>="2.7.0"} 17 | "ocaml" {>= "4.13.0"} 18 | "dns-client" {= version} 19 | "dns" {= version} 20 | "ipaddr" {>= "5.3.0"} 21 | "lwt" {>= "4.2.1"} 22 | "mtime" {>= "1.2.0"} 23 | "mirage-crypto-rng" {>= "1.2.0"} 24 | "happy-eyeballs-lwt" {>= "2.0.0"} 25 | "happy-eyeballs" {>= "2.0.0"} 26 | "tls-lwt" {>= "2.0.0"} 27 | "ca-certs" {>= "1.0.0"} 28 | ] 29 | synopsis: "DNS client API using lwt" 30 | description: """ 31 | A client implementation using uDNS and lwt for side effects. 32 | """ 33 | x-maintenance-intent: [ "(latest)" ] 34 | -------------------------------------------------------------------------------- /dns-client-miou-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Robur "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | license: "BSD-2-Clause" 8 | 9 | build: [ 10 | [ "dune" "subst"] {dev} 11 | [ "dune" "build" "-p" name "-j" jobs ] 12 | [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} 13 | ] 14 | 15 | depends: [ 16 | "dune" {>="2.7.0"} 17 | "ocaml" {>= "5.0.0"} 18 | "dns-client" {= version} 19 | "domain-name" {>= "0.4.0"} 20 | "ipaddr" {>= "5.3.0"} 21 | "miou" {>= "0.1.0"} 22 | "tls-miou-unix" {>= "2.0.0"} 23 | "happy-eyeballs" {>= "2.0.0"} 24 | "happy-eyeballs-miou-unix" {>= "2.0.0"} 25 | ] 26 | synopsis: "DNS client API for Miou" 27 | description: """ 28 | A client implementation using uDNS using Miou. 29 | """ 30 | x-maintenance-intent: [ "(latest)" ] 31 | -------------------------------------------------------------------------------- /dns-client-mirage.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Joe Hill"] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | license: "BSD-2-Clause" 8 | 9 | build: [ 10 | [ "dune" "subst"] {dev} 11 | [ "dune" "build" "-p" name "-j" jobs ] 12 | [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} 13 | ] 14 | 15 | depends: [ 16 | "dune" {>="2.7.0"} 17 | "ocaml" {>= "4.13.0"} 18 | "dns-client" {= version} 19 | "domain-name" {>= "0.4.0"} 20 | "ipaddr" {>= "5.3.0"} 21 | "lwt" {>= "4.2.1"} 22 | "tcpip" {>= "8.2.0"} 23 | "mirage-sleep" {>= "4.0.0"} 24 | "mirage-mtime" {>= "5.0.0"} 25 | "mirage-ptime" {>= "5.0.0"} 26 | "happy-eyeballs-mirage" {>= "2.0.0"} 27 | "happy-eyeballs" {>= "2.0.0"} 28 | "tls-mirage" {>= "2.0.0"} 29 | "x509" {>= "1.0.0"} 30 | "ca-certs-nss" {>= "3.108-1"} 31 | "mirage-crypto-rng" {>= "1.0.0"} 32 | ] 33 | synopsis: "DNS client API for MirageOS" 34 | description: """ 35 | A client implementation using uDNS using MirageOS. 36 | """ 37 | x-maintenance-intent: [ "(latest)" ] 38 | -------------------------------------------------------------------------------- /dns-client.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Joe Hill"] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | license: "BSD-2-Clause" 8 | 9 | build: [ 10 | [ "dune" "subst"] {dev} 11 | [ "dune" "build" "-p" name "-j" jobs ] 12 | [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} 13 | ] 14 | 15 | depends: [ 16 | "dune" {>="2.7.0"} 17 | "ocaml" {>= "4.13.0"} 18 | "dns" {= version} 19 | "randomconv" {>= "0.2.0"} 20 | "domain-name" {>= "0.4.0"} 21 | "mtime" {>= "1.2.0"} 22 | "mirage-crypto-rng" {>= "1.2.0"} 23 | "fmt" {>= "0.9.0"} 24 | "ipaddr" {>= "5.5.0"} 25 | "alcotest" {with-test} 26 | ] 27 | synopsis: "DNS client API" 28 | description: """ 29 | A client implementation using uDNS. 30 | """ 31 | x-maintenance-intent: [ "(latest)" ] 32 | -------------------------------------------------------------------------------- /dns-mirage.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | doc: "https://mirage.github.io/ocaml-dns/" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 8 | license: "BSD-2-Clause" 9 | 10 | depends: [ 11 | "dune" {>= "2.7.0"} 12 | "ocaml" {>= "4.13.0"} 13 | "cstruct" {>= "6.0.0"} 14 | "dns" {= version} 15 | "ipaddr" {>= "5.2.0"} 16 | "lwt" {>= "4.2.1"} 17 | "tcpip" {>= "8.2.0"} 18 | ] 19 | 20 | build: [ 21 | ["dune" "subst"] {dev} 22 | ["dune" "build" "-p" name "-j" jobs] 23 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 24 | ] 25 | 26 | synopsis: "An opinionated Domain Name System (DNS) library" 27 | description: """ 28 | µDNS supports most of the domain name system used in the wild. It adheres to 29 | strict conventions. Failing early and hard. It is mostly implemented in the 30 | pure fragment of OCaml (no mutation, isolated IO, no exceptions). 31 | 32 | Legacy resource record types are not dealt with, and there is no plan to support 33 | `ISDN`, `MAILA`, `MAILB`, `WKS`, `MB`, `NULL`, `HINFO`, ... . `AXFR` is only 34 | handled via TCP connections. The only resource class supported is `IN` (the 35 | Internet). Truncated hmac in `TSIG` are not supported (always the full length 36 | of the hash algorithm is used). 37 | 38 | Please read [the blog article](https://hannes.robur.coop/Posts/DNS) for a more 39 | detailed overview. 40 | """ 41 | x-maintenance-intent: [ "(latest)" ] 42 | -------------------------------------------------------------------------------- /dns-resolver.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | doc: "https://mirage.github.io/ocaml-dns/" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 8 | license: "BSD-2-Clause" 9 | 10 | depends: [ 11 | "dune" {>= "2.7.0"} 12 | "ocaml" {>= "4.13.0"} 13 | "dns" {= version} 14 | "dns-server" {= version} 15 | "dns-mirage" {= version} 16 | "dnssec" {= version} 17 | "lru" {>= "0.3.0"} 18 | "duration" {>= "0.1.2"} 19 | "randomconv" {>= "0.2.0"} 20 | "lwt" {>= "4.2.1"} 21 | "mirage-sleep" {>= "4.0.0"} 22 | "mirage-mtime" {>= "5.0.0"} 23 | "mirage-ptime" {>= "5.0.0"} 24 | "tcpip" {>= "8.2.0"} 25 | "alcotest" {with-test} 26 | "logs" 27 | "tls" {>= "1.0.0"} 28 | "tls-mirage" {>= "1.0.0"} 29 | "mirage-crypto-rng" {>= "1.0.0"} 30 | ] 31 | 32 | build: [ 33 | ["dune" "subst"] {dev} 34 | ["dune" "build" "-p" name "-j" jobs] 35 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 36 | ] 37 | 38 | synopsis: "DNS resolver business logic" 39 | description: """ 40 | Forwarding and recursive resolvers as value-passing functions. To be used with 41 | an effectful layer. 42 | """ 43 | x-maintenance-intent: [ "(latest)" ] 44 | -------------------------------------------------------------------------------- /dns-server.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | doc: "https://mirage.github.io/ocaml-dns/" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 8 | license: "BSD-2-Clause" 9 | 10 | depends: [ 11 | "dune" {>= "2.7.0"} 12 | "ocaml" {>= "4.13.0"} 13 | "cstruct" {>= "6.0.0"} 14 | "dns" {= version} 15 | "dns-mirage" {= version} 16 | "randomconv" {>= "0.2.0"} 17 | "duration" {>= "0.1.2"} 18 | "lwt" {>= "4.2.1"} 19 | "mirage-sleep" {>= "4.0.0"} 20 | "mirage-mtime" {>= "5.0.0"} 21 | "mirage-ptime" {>= "5.0.0"} 22 | "tcpip" {>= "8.2.0"} 23 | "mirage-crypto-rng" {with-test & >= "1.2.0"} 24 | "alcotest" {with-test} 25 | "dns-tsig" {with-test} 26 | "base64" {with-test & >= "3.0.0"} 27 | "metrics" 28 | "logs" {>= "0.7.0"} 29 | ] 30 | 31 | build: [ 32 | ["dune" "subst"] {dev} 33 | ["dune" "build" "-p" name "-j" jobs] 34 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 35 | ] 36 | 37 | synopsis: "DNS server, primary and secondary" 38 | description: """ 39 | Primary and secondary DNS server implemented in value-passing style. Needs an 40 | effectful layer to be useful. 41 | """ 42 | x-maintenance-intent: [ "(latest)" ] 43 | -------------------------------------------------------------------------------- /dns-stub.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | doc: "https://mirage.github.io/ocaml-dns/" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 8 | license: "BSD-2-Clause" 9 | 10 | depends: [ 11 | "dune" {>= "2.7.0"} 12 | "ocaml" {>= "4.13.0"} 13 | "cstruct" {>= "6.0.0"} 14 | "dns" {= version} 15 | "dns-client-mirage" {= version} 16 | "dns-mirage" {= version} 17 | "dns-resolver" {= version} 18 | "dns-tsig" {= version} 19 | "dns-server" {= version} 20 | "duration" {>= "0.1.2"} 21 | "randomconv" {>= "0.2.0"} 22 | "lwt" {>= "4.2.1"} 23 | "mirage-ptime" {>= "5.0.0"} 24 | "tcpip" {>= "8.2.0"} 25 | "metrics" 26 | "mirage-crypto-rng" {>= "1.0.0"} 27 | ] 28 | 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | ["dune" "build" "-p" name "-j" jobs] 32 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 33 | ] 34 | 35 | synopsis: "DNS stub resolver" 36 | description: """ 37 | Forwarding and recursive resolvers as value-passing functions. To be used with 38 | an effectful layer. 39 | """ 40 | x-maintenance-intent: [ "(latest)" ] 41 | -------------------------------------------------------------------------------- /dns-tsig.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | doc: "https://mirage.github.io/ocaml-dns/" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 8 | license: "BSD-2-Clause" 9 | 10 | depends: [ 11 | "dune" {>= "2.7.0"} 12 | "ocaml" {>= "4.13.0"} 13 | "dns" {= version} 14 | "digestif" {>= "1.2.0"} 15 | "base64" {>= "3.0.0"} 16 | "alcotest" {with-test} 17 | ] 18 | 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | ["dune" "build" "-p" name "-j" jobs] 22 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 23 | ] 24 | 25 | synopsis: "TSIG support for DNS" 26 | description: """ 27 | TSIG is used to authenticate nsupdate frames using a HMAC. 28 | """ 29 | x-maintenance-intent: [ "(latest)" ] 30 | -------------------------------------------------------------------------------- /dns.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Hannes Mehnert " "Reynir Björnsson "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | doc: "https://mirage.github.io/ocaml-dns/" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 8 | license: "BSD-2-Clause" 9 | 10 | depends: [ 11 | "dune" {>= "2.7.0"} 12 | "ocaml" {>= "4.13.0"} 13 | "logs" "ptime" 14 | "fmt" {>= "0.8.8"} 15 | "domain-name" {>= "0.4.0"} 16 | "gmap" {>= "0.3.0"} 17 | "ipaddr" {>= "5.2.0"} 18 | "alcotest" {with-test} 19 | "lru" {>= "0.3.0"} 20 | "duration" {>= "0.1.2"} 21 | "metrics" 22 | "ohex" {>= "0.2.0"} 23 | "base64" {>= "3.3.0"} 24 | ] 25 | conflicts: [ "result" {< "1.5"} ] 26 | build: [ 27 | ["dune" "subst"] {dev} 28 | ["dune" "build" "-p" name "-j" jobs] 29 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 30 | ] 31 | 32 | synopsis: "An opinionated Domain Name System (DNS) library" 33 | description: """ 34 | µDNS supports most of the domain name system used in the wild. It adheres to 35 | strict conventions. Failing early and hard. It is mostly implemented in the 36 | pure fragment of OCaml (no mutation, isolated IO, no exceptions). 37 | 38 | Legacy resource record types are not dealt with, and there is no plan to support 39 | `ISDN`, `MAILA`, `MAILB`, `WKS`, `MB`, `NULL`, `HINFO`, ... . `AXFR` is only 40 | handled via TCP connections. The only resource class supported is `IN` (the 41 | Internet). Truncated hmac in `TSIG` are not supported (always the full length 42 | of the hash algorithm is used). 43 | 44 | Please read [the blog article](https://hannes.robur.coop/Posts/DNS) for a more 45 | detailed overview. 46 | """ 47 | x-maintenance-intent: [ "(latest)" ] 48 | -------------------------------------------------------------------------------- /dnssec.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot coop" 3 | authors: ["Hannes Mehnert " "Reynir Björnsson "] 4 | homepage: "https://github.com/mirage/ocaml-dns" 5 | doc: "https://mirage.github.io/ocaml-dns/" 6 | dev-repo: "git+https://github.com/mirage/ocaml-dns.git" 7 | bug-reports: "https://github.com/mirage/ocaml-dns/issues" 8 | license: "BSD-2-Clause" 9 | 10 | depends: [ 11 | "dune" {>= "2.7.0"} 12 | "ocaml" {>= "4.13.0"} 13 | "dns" {= version} 14 | "alcotest" {with-test} 15 | "mirage-crypto" {>= "1.0.0"} 16 | "mirage-crypto-pk" {>= "1.0.0"} 17 | "mirage-crypto-ec" {>= "1.0.0"} 18 | "domain-name" {>= "0.4.0"} 19 | "base64" {with-test & >= "3.0.0"} 20 | "logs" {>= "0.7.0"} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | ["dune" "build" "-p" name "-j" jobs] 25 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 26 | ] 27 | 28 | synopsis: "DNSSec support for OCaml-DNS" 29 | description: """ 30 | DNSSec (DNS security extensions) for OCaml-DNS, including 31 | signing and verifying of RRSIG records. 32 | """ 33 | x-maintenance-intent: [ "(latest)" ] 34 | -------------------------------------------------------------------------------- /dnssec/base32.ml: -------------------------------------------------------------------------------- 1 | (* RFC 4648, Section 7 - Base 32 with extended hex alphabet *) 2 | 3 | let make_alphabet alphabet = 4 | if String.length alphabet <> 32 5 | then invalid_arg "Length of alphabet must be 32" ; 6 | if String.contains alphabet '=' 7 | then invalid_arg "Alphabet can not contain padding character" ; 8 | let emap = 9 | Array.init (String.length alphabet) (fun i -> Char.code alphabet.[i]) in 10 | let dmap = Array.make 256 (-1) in 11 | String.iteri (fun idx chr -> dmap.(Char.code chr) <- idx) alphabet ; 12 | (emap, dmap) 13 | 14 | let alphabet = make_alphabet "0123456789ABCDEFGHIJKLMNOPQRSTUV" 15 | 16 | let pad_char = '=' 17 | let pad_int = int_of_char pad_char 18 | 19 | let encode ?(pad = true) str = 20 | let len = String.length str in 21 | (* since String.get_uint8 is OCaml >= 4.13 only *) 22 | let str = Bytes.unsafe_of_string str in 23 | let out_len = (len + 4) / 5 * 8 in 24 | let out = Bytes.make out_len pad_char in 25 | let o1 b1 = b1 lsr 3 26 | and o2 b1 b2 = (b1 land 0x07) lsl 2 + b2 lsr 6 27 | and o3 b2 = (b2 land 0x3E) lsr 1 28 | and o4 b2 b3 = ((b2 land 0x01) lsl 4) + b3 lsr 4 29 | and o5 b3 b4 = (b3 land 0x0F) lsl 1 + b4 lsr 7 30 | and o6 b4 = (b4 land 0x7c) lsr 2 31 | and o7 b4 b5 = (b4 land 0x03) lsl 3 + b5 lsr 5 32 | and o8 b5 = b5 land 0x1F 33 | in 34 | let emit b1 b2 b3 b4 b5 off = 35 | List.iteri (fun idx v -> Bytes.set_uint8 out (off + idx) ((fst alphabet).(v))) 36 | [ o1 b1; o2 b1 b2; o3 b2; o4 b2 b3; o5 b3 b4; o6 b4; o7 b4 b5; o8 b5 ] 37 | in 38 | let rec enc s_off d_off = 39 | if s_off = len then 40 | (* case 1 *) 0 41 | else if s_off = len - 1 then 42 | (* case 2 - 6 padding = *) 43 | let b1 = Bytes.get_uint8 str s_off in 44 | let p1 = o1 b1 and p2 = o2 b1 0 in 45 | Bytes.set_uint8 out d_off ((fst alphabet).(p1)); 46 | Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2)); 47 | 6 48 | else if s_off = len - 2 then 49 | (* case 3 - 4 padding = *) 50 | let b1 = Bytes.get_uint8 str s_off 51 | and b2 = Bytes.get_uint8 str (s_off + 1) 52 | in 53 | let p1 = o1 b1 and p2 = o2 b1 b2 and p3 = o3 b2 and p4 = o4 b2 0 in 54 | Bytes.set_uint8 out d_off ((fst alphabet).(p1)); 55 | Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2)); 56 | Bytes.set_uint8 out (d_off + 2) ((fst alphabet).(p3)); 57 | Bytes.set_uint8 out (d_off + 3) ((fst alphabet).(p4)); 58 | 4 59 | else if s_off = len - 3 then 60 | (* case 4 - 3 padding = *) 61 | let b1 = Bytes.get_uint8 str s_off 62 | and b2 = Bytes.get_uint8 str (s_off + 1) 63 | and b3 = Bytes.get_uint8 str (s_off + 2) 64 | in 65 | let p1 = o1 b1 and p2 = o2 b1 b2 and p3 = o3 b2 and p4 = o4 b2 b3 and p5 = o5 b3 0 in 66 | Bytes.set_uint8 out d_off ((fst alphabet).(p1)); 67 | Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2)); 68 | Bytes.set_uint8 out (d_off + 2) ((fst alphabet).(p3)); 69 | Bytes.set_uint8 out (d_off + 3) ((fst alphabet).(p4)); 70 | Bytes.set_uint8 out (d_off + 4) ((fst alphabet).(p5)); 71 | 3 72 | else if s_off = len - 4 then 73 | (* case 5 - 1 padding = *) 74 | let b1 = Bytes.get_uint8 str s_off 75 | and b2 = Bytes.get_uint8 str (s_off + 1) 76 | and b3 = Bytes.get_uint8 str (s_off + 2) 77 | and b4 = Bytes.get_uint8 str (s_off + 3) 78 | in 79 | 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 80 | Bytes.set_uint8 out d_off ((fst alphabet).(p1)); 81 | Bytes.set_uint8 out (d_off + 1) ((fst alphabet).(p2)); 82 | Bytes.set_uint8 out (d_off + 2) ((fst alphabet).(p3)); 83 | Bytes.set_uint8 out (d_off + 3) ((fst alphabet).(p4)); 84 | Bytes.set_uint8 out (d_off + 4) ((fst alphabet).(p5)); 85 | Bytes.set_uint8 out (d_off + 5) ((fst alphabet).(p6)); 86 | Bytes.set_uint8 out (d_off + 6) ((fst alphabet).(p7)); 87 | 1 88 | else 89 | let b1 = Bytes.get_uint8 str s_off in 90 | let b2 = Bytes.get_uint8 str (s_off + 1) in 91 | let b3 = Bytes.get_uint8 str (s_off + 2) in 92 | let b4 = Bytes.get_uint8 str (s_off + 3) in 93 | let b5 = Bytes.get_uint8 str (s_off + 4) in 94 | emit b1 b2 b3 b4 b5 d_off; 95 | enc (s_off + 5) (d_off + 8) 96 | in 97 | let padding_bytes = enc 0 0 in 98 | let out_s = Bytes.unsafe_to_string out in 99 | if pad then out_s else String.sub out_s 0 (out_len - padding_bytes) 100 | 101 | (* RFC 4648 section 10 102 | BASE32-HEX("") = "" 103 | BASE32-HEX("f") = "CO======" 104 | BASE32-HEX("fo") = "CPNG====" 105 | BASE32-HEX("foo") = "CPNMU===" 106 | BASE32-HEX("foob") = "CPNMUOG=" 107 | BASE32-HEX("fooba") = "CPNMUOJ1" 108 | BASE32-HEX("foobar") = "CPNMUOJ1E8======" 109 | *) 110 | 111 | let decode ?(unpadded = false) str = 112 | let ( let* ) = Result.bind in 113 | let* str = 114 | let lmod8 = String.length str mod 8 in 115 | if lmod8 > 0 then 116 | if unpadded then 117 | Ok (str ^ String.make (8 - lmod8) pad_char) 118 | else 119 | Error (`Msg "invalid input length (not divisible by 8)") 120 | else 121 | Ok str 122 | in 123 | let len = String.length str in 124 | let str = Bytes.unsafe_of_string str in 125 | let out_len = len / 8 * 5 in (* max length *) 126 | let out = Bytes.create out_len in 127 | let o1 b1 b2 = b1 lsl 3 + b2 lsr 2 128 | and o2 b2 b3 b4 = (b2 land 0x03) lsl 6 + b3 lsl 1 + b4 lsr 4 129 | and o3 b4 b5 = (b4 land 0x0F) lsl 4 + b5 lsr 1 130 | and o4 b5 b6 b7 = (b5 land 0x01) lsl 7 + b6 lsl 2 + b7 lsr 3 131 | and o5 b7 b8 = (b7 land 0x07) lsl 5 + b8 132 | in 133 | let c ~off idx = 134 | let r = (snd alphabet).(idx) in 135 | if r = -1 then 136 | Error (`Msg ("bad encoding at " ^ string_of_int off)) 137 | else 138 | Ok r 139 | in 140 | let emit s_off v1 v2 v3 v4 v5 v6 v7 v8 off = 141 | let* b1 = c ~off:s_off v1 in 142 | let* b2 = c ~off:(s_off + 1) v2 in 143 | let* b3 = c ~off:(s_off + 2) v3 in 144 | let* b4 = c ~off:(s_off + 3) v4 in 145 | let* b5 = c ~off:(s_off + 4) v5 in 146 | let* b6 = c ~off:(s_off + 5) v6 in 147 | let* b7 = c ~off:(s_off + 6) v7 in 148 | let* b8 = c ~off:(s_off + 7) v8 in 149 | Bytes.set_uint8 out off (o1 b1 b2); 150 | Bytes.set_uint8 out (off + 1) (o2 b2 b3 b4); 151 | Bytes.set_uint8 out (off + 2) (o3 b4 b5); 152 | Bytes.set_uint8 out (off + 3) (o4 b5 b6 b7); 153 | Bytes.set_uint8 out (off + 4) (o5 b7 b8); 154 | Ok () 155 | in 156 | let rec dec s_off d_off = 157 | if s_off = len then 158 | Ok (0, 0) 159 | else 160 | let v1 = Bytes.get_uint8 str s_off 161 | and v2 = Bytes.get_uint8 str (s_off + 1) 162 | and v3 = Bytes.get_uint8 str (s_off + 2) 163 | and v4 = Bytes.get_uint8 str (s_off + 3) 164 | and v5 = Bytes.get_uint8 str (s_off + 4) 165 | and v6 = Bytes.get_uint8 str (s_off + 5) 166 | and v7 = Bytes.get_uint8 str (s_off + 6) 167 | and v8 = Bytes.get_uint8 str (s_off + 7) 168 | in 169 | if v3 = pad_int then 170 | let* b1 = c ~off:s_off v1 in 171 | let* b2 = c ~off:(s_off + 1) v2 in 172 | let p1 = o1 b1 b2 in 173 | Bytes.set_uint8 out d_off p1; 174 | Ok (6, 4) 175 | else if v5 = pad_int then 176 | let* b1 = c ~off:s_off v1 in 177 | let* b2 = c ~off:(s_off + 1) v2 in 178 | let* b3 = c ~off:(s_off + 2) v3 in 179 | let* b4 = c ~off:(s_off + 3) v4 in 180 | let p1 = o1 b1 b2 181 | and p2 = o2 b2 b3 b4 182 | in 183 | Bytes.set_uint8 out d_off p1; 184 | Bytes.set_uint8 out (d_off + 1) p2; 185 | Ok (4, 3) 186 | else if v6 = pad_int then 187 | let* b1 = c ~off:s_off v1 in 188 | let* b2 = c ~off:(s_off + 1) v2 in 189 | let* b3 = c ~off:(s_off + 2) v3 in 190 | let* b4 = c ~off:(s_off + 3) v4 in 191 | let* b5 = c ~off:(s_off + 4) v5 in 192 | let p1 = o1 b1 b2 193 | and p2 = o2 b2 b3 b4 194 | and p3 = o3 b4 b5 195 | in 196 | Bytes.set_uint8 out d_off p1; 197 | Bytes.set_uint8 out (d_off + 1) p2; 198 | Bytes.set_uint8 out (d_off + 2) p3; 199 | Ok (3, 2) 200 | else if v8 = pad_int then 201 | let* b1 = c ~off:s_off v1 in 202 | let* b2 = c ~off:(s_off + 1) v2 in 203 | let* b3 = c ~off:(s_off + 2) v3 in 204 | let* b4 = c ~off:(s_off + 3) v4 in 205 | let* b5 = c ~off:(s_off + 4) v5 in 206 | let* b6 = c ~off:(s_off + 5) v6 in 207 | let* b7 = c ~off:(s_off + 6) v7 in 208 | let p1 = o1 b1 b2 209 | and p2 = o2 b2 b3 b4 210 | and p3 = o3 b4 b5 211 | and p4 = o4 b5 b6 b7 212 | in 213 | Bytes.set_uint8 out d_off p1; 214 | Bytes.set_uint8 out (d_off + 1) p2; 215 | Bytes.set_uint8 out (d_off + 2) p3; 216 | Bytes.set_uint8 out (d_off + 3) p4; 217 | Ok (1, 1) 218 | else 219 | let* () = emit s_off v1 v2 v3 v4 v5 v6 v7 v8 d_off in 220 | dec (s_off + 8) (d_off + 5) 221 | in 222 | let* (pad_bytes, to_remove) = dec 0 0 in 223 | let rec check_pad = function 224 | | 0 -> Ok () 225 | | n -> 226 | if Bytes.get_uint8 str (len - n) = pad_int then 227 | check_pad (n - 1) 228 | else 229 | Error (`Msg ("expected pad character at " ^ (string_of_int (len - n)))) 230 | in 231 | let* () = check_pad pad_bytes in 232 | let out_str = Bytes.unsafe_to_string out in 233 | if to_remove > 0 then 234 | Ok (String.sub out_str 0 (out_len - to_remove)) 235 | else 236 | Ok out_str 237 | -------------------------------------------------------------------------------- /dnssec/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dnssec) 3 | (public_name dnssec) 4 | (wrapped false) 5 | (libraries mirage-crypto mirage-crypto-pk mirage-crypto-ec dns logs domain-name)) 6 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name dns) 3 | (formatting disabled) 4 | -------------------------------------------------------------------------------- /lwt/client/dns_client_lwt.mli: -------------------------------------------------------------------------------- 1 | (** {!Lwt_unix} helper module for {!Dns_client}. 2 | For more information see the {!Dns_client.Make} functor. 3 | 4 | The {!Dns_client} is available as Dns_client_lwt after 5 | linking to dns-client.lwt in your dune file. 6 | 7 | It initializes the RNG (using Mirage_crypto_rng_lwt.initialize ()). 8 | *) 9 | 10 | 11 | (** A flow module based on non-blocking I/O on top of the 12 | Lwt_unix socket API. *) 13 | module Transport : Dns_client.S 14 | with type io_addr = [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ] 15 | and type +'a io = 'a Lwt.t 16 | and type stack = Happy_eyeballs_lwt.t 17 | 18 | include module type of Dns_client.Make(Transport) 19 | -------------------------------------------------------------------------------- /lwt/client/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_client_lwt) 3 | (modules dns_client_lwt) 4 | (public_name dns-client-lwt) 5 | (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) 6 | (wrapped false)) 7 | -------------------------------------------------------------------------------- /miou/client/dns_client_miou_unix.ml: -------------------------------------------------------------------------------- 1 | let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt 2 | 3 | let src = Logs.Src.create "dns-client-miou-unix" 4 | 5 | module Log = (val Logs.src_log src : Logs.LOG) 6 | 7 | module Transport = struct 8 | open Happy_eyeballs_miou_unix 9 | 10 | type +'a io = 'a 11 | 12 | type io_addr = 13 | [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ] 14 | 15 | type t = { 16 | nameservers: io_addr list 17 | ; proto: Dns.proto 18 | ; timeout: float 19 | ; happy: stack 20 | } 21 | and stack = Happy_eyeballs_miou_unix.t 22 | 23 | type context = 24 | { fd : [ `Udp of Miou_unix.file_descr 25 | | `Tcp of Miou_unix.file_descr 26 | | `Tls of Tls_miou_unix.t ] 27 | ; timeout : float } 28 | 29 | let clock = Mtime_clock.elapsed_ns 30 | 31 | let same_address ipaddr' port' = function 32 | | `Plaintext (ipaddr, port) -> Ipaddr.compare ipaddr ipaddr' = 0 && port = port' 33 | | `Tls (_, ipaddr, port) -> Ipaddr.compare ipaddr ipaddr' = 0 && port = port' 34 | 35 | exception Timeout 36 | 37 | let with_timeout ~timeout:ts fn = 38 | let timeout () = Miou_unix.sleep ts; raise Timeout in 39 | let prm1 = Miou.async timeout in 40 | let prm0 = Miou.async fn in 41 | Miou.await_first [ prm0; prm1 ] 42 | 43 | let connect_to_nameservers t = 44 | let ( let* ) = Result.bind in 45 | match t.proto with 46 | | `Tcp -> 47 | let ip_of_nameserver = function 48 | | `Plaintext (ipaddr, port) -> (ipaddr, port) 49 | | `Tls (_, ipaddr, port) -> (ipaddr, port) in 50 | let ips = List.map ip_of_nameserver t.nameservers in 51 | let* ((ipaddr, port) as addr), fd = connect_ip t.happy ips in 52 | begin match List.find (same_address ipaddr port) t.nameservers with 53 | | `Plaintext _ -> Ok (addr, `Tcp fd) 54 | | `Tls (config, _, _) -> 55 | try let fd = Tls_miou_unix.client_of_fd config fd in 56 | Ok (addr, `Tls fd) 57 | with End_of_file -> 58 | Miou_unix.close fd; 59 | error_msgf "Connection to nameservers (via TLS) impossible" end 60 | | `Udp -> 61 | let is_plaintext = function `Plaintext v -> Either.Left v | _ -> Either.Right () in 62 | let[@warning "-8"] (ipaddr, port) :: _, _ = List.partition_map is_plaintext t.nameservers in 63 | let proto_number, socket_type = Unix.((getprotobyname "udp").p_proto, SOCK_DGRAM) in 64 | let domain = match ipaddr with 65 | | Ipaddr.V4 _ -> Unix.PF_INET 66 | | Ipaddr.V6 _ -> Unix.PF_INET6 in 67 | let fd = Unix.socket domain socket_type proto_number in 68 | let addr = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ipaddr, port) in 69 | let connect () = 70 | Unix.connect fd addr; 71 | ((ipaddr, port), `Udp (Miou_unix.of_file_descr fd)) in 72 | match with_timeout ~timeout:t.timeout connect with 73 | | Ok value -> Ok value 74 | | Error Timeout -> 75 | Unix.close fd; 76 | error_msgf "Connection to nameservers (via UDP) timeout" 77 | | Error exn -> 78 | Unix.close fd; 79 | error_msgf "Unexpected error: %S" (Printexc.to_string exn) 80 | 81 | let nameservers { nameservers; proto; _ } = (proto, nameservers) 82 | let bind x f = f x 83 | let lift = Fun.id 84 | let rng = Mirage_crypto_rng.generate ?g:None 85 | 86 | let connect t = 87 | let ( let* ) = Result.bind in 88 | let* ((addr, port), fd) = connect_to_nameservers t in 89 | Log.debug (fun m -> m "Connected to a nameserver %a:%d" Ipaddr.pp addr port); 90 | match fd with 91 | | `Tcp _ | `Tls _ -> Ok (`Tcp, { fd; timeout= t.timeout }) 92 | | `Udp _ -> Ok (`Udp, { fd; timeout= t.timeout }) 93 | 94 | let send_recv_tls ~timeout ~id fd str = 95 | let send () = Tls_miou_unix.write fd str in 96 | let recv () = 97 | let rec go buf rx_len = 98 | let expected_len = 99 | if rx_len >= 2 then Some (Bytes.get_uint16_be buf 0) else None in 100 | match expected_len with 101 | | None -> 102 | let len = Tls_miou_unix.read fd buf ~off:rx_len in 103 | if rx_len + len >= 2 && len > 0 then go buf (rx_len + len) 104 | else failwith "TLS connection closed by nameserver" 105 | | Some expected_len when rx_len >= expected_len + 2 -> 106 | let id' = Bytes.get_uint16_be buf 2 in 107 | if id = id' 108 | then Bytes.sub_string buf 0 (expected_len + 2) 109 | else 110 | let buf' = Bytes.make 2048 '\000' in 111 | let rx_len' = rx_len - (expected_len + 2) in 112 | Bytes.blit buf (expected_len + 2) buf' 0 rx_len'; 113 | go buf' rx_len' 114 | | Some expected_len when Bytes.length buf >= expected_len + 2 -> 115 | let len = (expected_len + 2) - rx_len in 116 | Tls_miou_unix.really_read fd buf ~off:rx_len ~len; 117 | go buf (rx_len + len) 118 | | Some expected_len -> 119 | (* NOTE(dinosaure): in this branch, [buf] is not large enough to store 120 | the DNS packet. We allocate a new buffer which can store the actual 121 | DNS packet and use it for the next [go] iteration. *) 122 | let buf' = Bytes.make (expected_len + 2) '\000' in 123 | Bytes.blit buf 0 buf' 0 rx_len; 124 | go buf' rx_len in 125 | go (Bytes.make 2048 '\000') 0 in 126 | let ( >>= ) = Result.bind in 127 | match with_timeout ~timeout send >>= fun () -> 128 | with_timeout ~timeout recv with 129 | | Ok _ as rx -> rx 130 | | Error Timeout -> error_msgf "DNS request timeout" 131 | | Error (Failure msg) -> Error (`Msg msg) 132 | | Error (End_of_file | Tls_miou_unix.Closed_by_peer) -> 133 | error_msgf "End of file reading from nameserver" 134 | | Error exn -> 135 | error_msgf "Got an unexpected exception: %s" 136 | (Printexc.to_string exn) 137 | 138 | let send_recv { fd; timeout } str = 139 | if String.length str > 4 then begin 140 | match fd with 141 | | `Tls fd -> 142 | let id = String.get_uint16_be str 2 in 143 | send_recv_tls ~timeout ~id fd str 144 | | `Udp fd | `Tcp fd -> 145 | let fd = Miou_unix.to_file_descr fd in 146 | Unix.clear_nonblock fd; 147 | let send () = 148 | Log.debug (fun m -> m "sending a dns packet to resolver"); 149 | Unix.setsockopt_float fd Unix.SO_SNDTIMEO timeout; 150 | let len = Unix.send_substring fd str 0 (String.length str) [] in 151 | if len <> String.length str 152 | then failwith "Broken write to upstream nameserver" in 153 | let recv () = 154 | let buffer = Bytes.make 2048 '\000' in 155 | Unix.setsockopt_float fd Unix.SO_RCVTIMEO timeout; 156 | let len = Unix.recv fd buffer 0 (Bytes.length buffer) [] in 157 | (* TODO(dinosaure): should we check rx_len and continue until we got 158 | the full packet (only for tcp/ip)? *) 159 | if len > 0 && len <= Bytes.length buffer 160 | then Bytes.sub_string buffer 0 len 161 | else failwith "Reading from nameserver socket failed" in 162 | let ( >>= ) = Result.bind in 163 | match with_timeout ~timeout send >>= fun () -> 164 | with_timeout ~timeout recv with 165 | | Ok _ as rx -> rx 166 | | Error Timeout -> error_msgf "DNS request timeout" 167 | | Error (Failure msg) -> Error (`Msg msg) 168 | | Error exn -> 169 | error_msgf "Got an unexpected exception: %s" 170 | (Printexc.to_string exn) 171 | end 172 | else error_msgf "Invalid context (data length <= 4)" 173 | 174 | let close { fd; _ } = match fd with 175 | | `Tcp fd | `Udp fd -> Miou_unix.close fd 176 | | `Tls fd -> Tls_miou_unix.close fd 177 | 178 | let of_ns ns = Int64.to_float ns /. 1_000_000_000. 179 | 180 | let create ?nameservers ~timeout happy = 181 | let proto, nameservers = 182 | match nameservers with 183 | | None -> (`Udp, [ `Plaintext (Ipaddr.of_string_exn "8.8.8.8", 53) ]) 184 | | Some (a, nss) -> (a, nss) 185 | in 186 | { nameservers; proto; timeout= of_ns timeout; happy } 187 | end 188 | 189 | include Dns_client.Make (Transport) 190 | -------------------------------------------------------------------------------- /miou/client/dns_client_miou_unix.mli: -------------------------------------------------------------------------------- 1 | module Transport : Dns_client.S 2 | with type io_addr = [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ] 3 | and type +'a io = 'a 4 | and type stack = Happy_eyeballs_miou_unix.t 5 | 6 | include module type of Dns_client.Make (Transport) 7 | -------------------------------------------------------------------------------- /miou/client/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_client_miou_unix) 3 | (modules dns_client_miou_unix) 4 | (public_name dns-client-miou-unix) 5 | (libraries dns-client tls-miou-unix happy-eyeballs-miou-unix)) 6 | -------------------------------------------------------------------------------- /mirage/certify/dns_certify_mirage.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Lwt.Infix 4 | 5 | let src = Logs.Src.create "dns_certify_mirage" ~doc:"effectful DNS certify" 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | module Make (S : Tcpip.Stack.V4V6) = struct 9 | 10 | module D = Dns_mirage.Make(S) 11 | 12 | let nsupdate_csr flow host keyname zone dnskey csr = 13 | match 14 | Dns_certify.nsupdate Mirage_crypto_rng.generate Mirage_ptime.now 15 | ~host ~keyname ~zone dnskey csr 16 | with 17 | | Error s -> Lwt.return (Error s) 18 | | Ok (out, cb) -> 19 | D.send_tcp (D.flow flow) (Cstruct.of_string out) >>= function 20 | | Error () -> Lwt.return (Error (`Msg "tcp sending error")) 21 | | Ok () -> D.read_tcp flow >|= function 22 | | Error () -> Error (`Msg "tcp receive err") 23 | | Ok data -> match cb (Cstruct.to_string data) with 24 | | Error e -> Error (`Msg (Fmt.str "nsupdate reply error %a" Dns_certify.pp_u_err e)) 25 | | Ok () -> Ok () 26 | 27 | let query_certificate flow name csr = 28 | match Dns_certify.query Mirage_crypto_rng.generate (Mirage_ptime.now ()) name csr with 29 | | Error e -> Lwt.return (Error e) 30 | | Ok (out, cb) -> 31 | D.send_tcp (D.flow flow) (Cstruct.of_string out) >>= function 32 | | Error () -> Lwt.return (Error (`Msg "couldn't send tcp")) 33 | | Ok () -> 34 | D.read_tcp flow >|= function 35 | | Error () -> Error (`Msg "error while reading answer") 36 | | Ok data -> match cb (Cstruct.to_string data) with 37 | | Error e -> Error e 38 | | Ok cert -> Ok cert 39 | 40 | let query_certificate_or_csr flow hostname keyname zone dnskey csr = 41 | query_certificate flow hostname csr >>= function 42 | | Ok certificate -> 43 | Log.info (fun m -> m "found certificate in DNS") ; 44 | Lwt.return (Ok certificate) 45 | | Error (`Msg msg) -> 46 | Log.err (fun m -> m "error %s" msg) ; 47 | Lwt.return (Error (`Msg msg)) 48 | | Error ((`Decode _ | `Bad_reply _ | `Unexpected_reply _) as e) -> 49 | Log.err (fun m -> m "query error %a, giving up" Dns_certify.pp_q_err e); 50 | Lwt.return (Error (`Msg "query error")) 51 | | Error `No_tlsa -> 52 | Log.info (fun m -> m "no certificate in DNS, need to transmit the CSR") ; 53 | nsupdate_csr flow hostname keyname zone dnskey csr >>= function 54 | | Error (`Msg msg) -> 55 | Log.err (fun m -> m "failed to nsupdate TLSA %s" msg) ; 56 | Lwt.fail_with "nsupdate issue" 57 | | Ok () -> 58 | let rec wait_for_cert ?(retry = 10) () = 59 | if retry = 0 then 60 | Lwt.return (Error (`Msg "too many retries, giving up")) 61 | else 62 | query_certificate flow hostname csr >>= function 63 | | Ok certificate -> 64 | Log.info (fun m -> m "finally found a certificate") ; 65 | Lwt.return (Ok certificate) 66 | | Error (`Msg msg) -> 67 | Log.err (fun m -> m "error while querying certificate %s" msg) ; 68 | Lwt.return (Error (`Msg msg)) 69 | | Error (#Dns_certify.q_err as q) -> 70 | Log.info (fun m -> m "still waiting for certificate, got error %a" Dns_certify.pp_q_err q) ; 71 | Mirage_sleep.ns (Duration.of_sec 2) >>= fun () -> 72 | wait_for_cert ~retry:(pred retry) () 73 | in 74 | wait_for_cert () 75 | 76 | let retrieve_certificate stack (dns_key_name, dns_key) ~hostname ?(additional_hostnames = []) ?(key_type = `RSA) ?key_data ?key_seed ?bits dns port = 77 | let zone = Domain_name.(host_exn (drop_label_exn ~amount:2 dns_key_name)) in 78 | let not_sub subdomain = not (Domain_name.is_subdomain ~subdomain ~domain:zone) in 79 | if not_sub hostname then 80 | invalid_arg "hostname not a subdomain of zone provided by dns_key" 81 | else 82 | let key = 83 | let seed_or_data, data = match key_data, key_seed with 84 | | None, None -> invalid_arg "neither key_data nor key_seed is supplied" 85 | | Some data, _ -> Some `Data, data 86 | | None, Some seed -> Some `Seed, seed 87 | in 88 | Result.fold 89 | ~ok:Fun.id 90 | ~error:(function `Msg msg -> invalid_arg ("key generation failed: " ^ msg)) 91 | (X509.Private_key.of_string ?seed_or_data ?bits key_type data) 92 | in 93 | match 94 | let more_hostnames = additional_hostnames in 95 | Dns_certify.signing_request hostname ~more_hostnames key 96 | with 97 | | Error (`Msg m) -> invalid_arg ("create signing request failed: " ^ m) 98 | | Ok csr -> 99 | S.TCP.create_connection (S.tcp stack) (dns, port) >>= function 100 | | Error e -> 101 | Log.err (fun m -> m "error %a while connecting to name server" 102 | S.TCP.pp_error e); 103 | Lwt.return (Error (`Msg "couldn't connect to name server")) 104 | | Ok flow -> 105 | let flow = D.of_flow flow in 106 | query_certificate_or_csr flow hostname dns_key_name zone dns_key csr >>= fun certificate -> 107 | S.TCP.close (D.flow flow) >|= fun () -> 108 | match certificate with 109 | | Error e -> Error e 110 | | Ok (cert, chain) -> Ok (cert :: chain, key) 111 | end 112 | -------------------------------------------------------------------------------- /mirage/certify/dns_certify_mirage.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | module Make (S : Tcpip.Stack.V4V6) : sig 3 | 4 | val retrieve_certificate : 5 | S.t -> ([`raw ] Domain_name.t * Dns.Dnskey.t) -> 6 | hostname:[ `host ] Domain_name.t -> 7 | ?additional_hostnames:[ `raw ] Domain_name.t list -> 8 | ?key_type:X509.Key_type.t -> ?key_data:string -> ?key_seed:string -> 9 | ?bits:int -> S.TCP.ipaddr -> int -> 10 | (X509.Certificate.t list * X509.Private_key.t, [ `Msg of string ]) result Lwt.t 11 | (** [retrieve_certificate stack dns_key ~hostname ~key_type ~key_data ~key_seed ~bits server_ip port] 12 | generates a private key (using [key_type], [key_data], [key_seed], and 13 | [bits]), a certificate signing request for the given [hostname] and 14 | [additional_hostnames], and sends [server_ip] an nsupdate (DNS-TSIG with 15 | [dns_key]) with the csr as TLSA record, awaiting for a matching 16 | certificate as TLSA record. Requires a service that interacts with let's 17 | encrypt to transform the CSR into a signed certificate. If something 18 | fails, an exception (via [Lwt.fail]) is raised. This is meant for 19 | unikernels that require a valid TLS certificate before they can start 20 | their service (i.e. most web servers, mail servers). *) 21 | end 22 | -------------------------------------------------------------------------------- /mirage/certify/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_certify_mirage) 3 | (public_name dns-certify.mirage) 4 | (wrapped false) 5 | (libraries dns dns-mirage dns-certify mirage-crypto-rng mirage-crypto-pk lwt duration mirage-sleep mirage-ptime tcpip)) 6 | -------------------------------------------------------------------------------- /mirage/client/dns_client_mirage.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type happy_eyeballs 3 | 4 | module Transport : 5 | sig 6 | include Dns_client.S 7 | with type +'a io = 'a Lwt.t 8 | and type io_addr = [ 9 | | `Plaintext of Ipaddr.t * int 10 | | `Tls of Tls.Config.client * Ipaddr.t * int 11 | ] 12 | val happy_eyeballs : t -> happy_eyeballs 13 | end 14 | 15 | include module type of Dns_client.Make(Transport) 16 | 17 | val nameserver_of_string : string -> 18 | (Dns.proto * Transport.io_addr, [> `Msg of string ]) result 19 | (** [nameserver_of_string authenticators str] returns a {!Transport.io_addr} 20 | from the given string. The format is: 21 | - [udp:(:port)?] for a plain nameserver and we will communicate 22 | with it {i via} the UDP protocol 23 | - [tcp:(:port)?] for a plain nameserver and we will communicate 24 | with it {i via} the TCP protocol 25 | - [tls:(:port)?((!hostname)?!authenticator)?] for a nameserver and 26 | we will communicate with it {i via} the TCP protocol plus the TLS 27 | encrypted layer. The user can verify the nameserver {i via} an 28 | {i authenticator} (see {!X509.Authenticator.of_string} for the format 29 | of it). The {i hostname} can be provided to be used as peer name by the 30 | authenticator. By default, {!Ca_certs_nss.authenticator} is used. 31 | *) 32 | 33 | val connect : 34 | ?cache_size:int -> 35 | ?edns:[ `None | `Auto | `Manual of Dns.Edns.t ] -> 36 | ?nameservers:string list -> 37 | ?timeout:int64 -> 38 | Transport.stack -> t Lwt.t 39 | (** [connect ?cache_size ?edns ?nameservers ?timeout (stack, happy_eyeballs)] 40 | creates a DNS entity which is able to resolve domain-name. It expects 41 | few optional arguments: 42 | - [cache_size] the size of the LRU cache, 43 | - [edns] the behaviour of whether or not to send edns in queries, 44 | - [nameservers] a list of {i nameservers} used to resolve domain-names, 45 | - [timeout] (in nanoseconds), passed to {create}. 46 | 47 | The provided [happy_eyeballs] will use [t] for resolving hostnames. 48 | 49 | @raise [Invalid_argument] if given strings don't respect formats explained 50 | by {!nameserver_of_string}. 51 | *) 52 | end 53 | 54 | module Make 55 | (S : Tcpip.Stack.V4V6) 56 | (H : Happy_eyeballs_mirage.S with type stack = S.t 57 | and type flow = S.TCP.flow) 58 | : S with type Transport.stack = S.t * H.t 59 | and type happy_eyeballs = H.t 60 | -------------------------------------------------------------------------------- /mirage/client/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_client_mirage) 3 | (public_name dns-client-mirage) 4 | (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) 5 | (wrapped false)) 6 | -------------------------------------------------------------------------------- /mirage/dns_mirage.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Lwt.Infix 4 | 5 | let src = Logs.Src.create "dns_mirage" ~doc:"effectful DNS layer" 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | module Make (S : Tcpip.Stack.V4V6) = struct 9 | 10 | module IPM = struct 11 | include Map.Make(struct 12 | type t = Ipaddr.t * int 13 | let compare (ip, p) (ip', p') = match Ipaddr.compare ip ip' with 14 | | 0 -> compare p p' 15 | | x -> x 16 | end) 17 | let find k t = try Some (find k t) with Not_found -> None 18 | end 19 | 20 | module U = S.UDP 21 | module T = S.TCP 22 | 23 | type f = { 24 | flow : T.flow ; 25 | mutable linger : Cstruct.t ; 26 | } 27 | 28 | let of_flow flow = { flow ; linger = Cstruct.empty } 29 | 30 | let flow { flow ; _ } = flow 31 | 32 | let rec read_exactly f length = 33 | let dst_ip, dst_port = T.dst f.flow in 34 | if Cstruct.length f.linger >= length then 35 | let a, b = Cstruct.split f.linger length in 36 | f.linger <- b ; 37 | Lwt.return (Ok a) 38 | else 39 | T.read f.flow >>= function 40 | | Ok `Eof -> 41 | Log.debug (fun m -> m "end of file on flow %a:%d" Ipaddr.pp dst_ip dst_port) ; 42 | T.close f.flow >>= fun () -> 43 | Lwt.return (Error ()) 44 | | Error e -> 45 | Log.err (fun m -> m "error %a reading flow %a:%d" T.pp_error e Ipaddr.pp dst_ip dst_port) ; 46 | T.close f.flow >>= fun () -> 47 | Lwt.return (Error ()) 48 | | Ok (`Data b) -> 49 | f.linger <- Cstruct.append f.linger b ; 50 | read_exactly f length 51 | 52 | let send_udp stack src_port dst dst_port data = 53 | Log.debug (fun m -> m "udp: sending %d bytes from %d to %a:%d" 54 | (Cstruct.length data) src_port Ipaddr.pp dst dst_port) ; 55 | U.write ~src_port ~dst ~dst_port (S.udp stack) data >|= function 56 | | Error e -> Log.warn (fun m -> m "udp: failure %a while sending from %d to %a:%d" 57 | U.pp_error e src_port Ipaddr.pp dst dst_port) 58 | | Ok () -> () 59 | 60 | let send_tcp flow answer = 61 | let dst_ip, dst_port = T.dst flow in 62 | Log.debug (fun m -> m "tcp: sending %d bytes to %a:%d" (Cstruct.length answer) Ipaddr.pp dst_ip dst_port) ; 63 | let len = Cstruct.create 2 in 64 | Cstruct.BE.set_uint16 len 0 (Cstruct.length answer) ; 65 | T.write flow (Cstruct.append len answer) >>= function 66 | | Ok () -> Lwt.return (Ok ()) 67 | | Error e -> 68 | Log.err (fun m -> m "tcp: error %a while writing to %a:%d" T.pp_write_error e Ipaddr.pp dst_ip dst_port) ; 69 | T.close flow >|= fun () -> 70 | Error () 71 | 72 | let send_tcp_multiple flow datas = 73 | Lwt_list.fold_left_s (fun acc d -> 74 | match acc with 75 | | Error () -> Lwt.return (Error ()) 76 | | Ok () -> send_tcp flow d) 77 | (Ok ()) datas 78 | 79 | let read_tcp flow = 80 | read_exactly flow 2 >>= function 81 | | Error () -> Lwt.return (Error ()) 82 | | Ok l -> 83 | let len = Cstruct.BE.get_uint16 l 0 in 84 | read_exactly flow len 85 | end 86 | -------------------------------------------------------------------------------- /mirage/dns_mirage.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | module Make (S : Tcpip.Stack.V4V6) : sig 4 | 5 | module IPM : sig 6 | include Map.S with type key = Ipaddr.t * int 7 | val find : Ipaddr.t * int -> 'a t -> 'a option 8 | end 9 | (** [IPM] is a map using [ip * port] as key. *) 10 | 11 | type f 12 | (** A 2byte-length per message flow abstraction, the embedding of DNS frames 13 | via TCP. *) 14 | 15 | val of_flow : S.TCP.flow -> f 16 | (** [of_flow flow] is [f]. *) 17 | 18 | val flow : f -> S.TCP.flow 19 | (** [flow f] is the underlying flow. *) 20 | 21 | val read_tcp : f -> (Cstruct.t, unit) result Lwt.t 22 | (** [read_tcp f] returns either a buffer or an error (logs actual error). *) 23 | 24 | val send_tcp : S.TCP.flow -> Cstruct.t -> (unit, unit) result Lwt.t 25 | (** [send_tcp flow buf] sends the buffer, either succeeds or fails (logs 26 | actual error). *) 27 | 28 | val send_tcp_multiple : S.TCP.flow -> Cstruct.t list -> 29 | (unit, unit) result Lwt.t 30 | (** [send_tcp_multiple flow bufs] sends the buffers, either succeeds or fails 31 | (logs actual error). *) 32 | 33 | val send_udp : S.t -> int -> Ipaddr.t -> int -> Cstruct.t -> unit Lwt.t 34 | (** [send_udp stack source_port dst dst_port buf] sends the [buf] as UDP 35 | packet to [dst] on [dst_port]. *) 36 | end 37 | -------------------------------------------------------------------------------- /mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_mirage) 3 | (public_name dns-mirage) 4 | (wrapped false) 5 | (libraries dns tcpip ipaddr lwt)) 6 | -------------------------------------------------------------------------------- /mirage/resolver/dns_resolver_mirage.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Lwt.Infix 4 | 5 | let src = Logs.Src.create "dns_resolver_mirage" ~doc:"effectful DNS resolver" 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | module Make (S : Tcpip.Stack.V4V6) = struct 9 | 10 | module Dns = Dns_mirage.Make(S) 11 | 12 | module T = S.TCP 13 | 14 | module TLS = Tls_mirage.Make(T) 15 | 16 | type t = (Ipaddr.t * int * string * (int32 * string) Lwt.u) option -> unit 17 | 18 | type tls_flow = { tls_flow : TLS.flow ; mutable linger : Cstruct.t } 19 | 20 | module FM = Map.Make(struct 21 | type t = Ipaddr.t * int 22 | let compare (ip, p) (ip', p') = 23 | match Ipaddr.compare ip ip' with 24 | | 0 -> compare p p' 25 | | x -> x 26 | end) 27 | 28 | let resolver stack ?(root = false) ?(timer = 500) ?(udp = true) ?(tcp = true) ?tls ?(port = 53) ?(tls_port = 853) t = 29 | let server_port = 53 in 30 | let state = ref t in 31 | (* according to RFC5452 4.5, we can chose source port between 1024-49152 *) 32 | let sport () = 1024 + Randomconv.int ~bound:48128 Mirage_crypto_rng.generate in 33 | let tcp_in = ref FM.empty in 34 | let ocaml_in = ref FM.empty in 35 | let tcp_out = ref Ipaddr.Map.empty in 36 | let stream, push = Lwt_stream.create () in 37 | 38 | let send_tls flow data = 39 | let len = Cstruct.create 2 in 40 | Cstruct.BE.set_uint16 len 0 (Cstruct.length data); 41 | TLS.writev flow [len; data] >>= function 42 | | Ok () -> Lwt.return (Ok ()) 43 | | Error e -> 44 | Log.err (fun m -> m "tls error %a while writing" TLS.pp_write_error e); 45 | TLS.close flow >|= fun () -> 46 | Error () 47 | in 48 | 49 | let rec client_out dst port = 50 | T.create_connection (S.tcp stack) (dst, port) >|= function 51 | | Error e -> 52 | (* do i need to report this back into the resolver? what are their options then? *) 53 | Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d" 54 | T.pp_error e Ipaddr.pp dst port) ; 55 | Error () 56 | | Ok flow -> 57 | Log.debug (fun m -> m "established new outgoing TCP connection to %a:%d" 58 | Ipaddr.pp dst port); 59 | tcp_out := Ipaddr.Map.add dst flow !tcp_out ; 60 | Lwt.async (fun () -> 61 | let f = Dns.of_flow flow in 62 | let rec loop () = 63 | Dns.read_tcp f >>= function 64 | | Error () -> 65 | Log.debug (fun m -> m "removing %a from tcp_out" Ipaddr.pp dst) ; 66 | tcp_out := Ipaddr.Map.remove dst !tcp_out ; 67 | Lwt.return_unit 68 | | Ok data -> 69 | let now = Mirage_ptime.now () in 70 | let ts = Mirage_mtime.elapsed_ns () in 71 | let new_state, answers, queries = 72 | let data = Cstruct.to_string data in 73 | Dns_resolver.handle_buf !state now ts false `Tcp dst port data 74 | in 75 | state := new_state ; 76 | Lwt_list.iter_p handle_answer answers >>= fun () -> 77 | Lwt_list.iter_p handle_query queries >>= fun () -> 78 | loop () 79 | in 80 | loop ()) ; 81 | Ok () 82 | and client_tcp dst port data = 83 | match Ipaddr.Map.find_opt dst !tcp_out with 84 | | None -> 85 | begin 86 | client_out dst port >>= function 87 | | Error () -> 88 | let sport = sport () in 89 | S.UDP.listen (S.udp stack) ~port:sport (udp_cb sport false) ; 90 | Dns.send_udp stack sport dst port (Cstruct.of_string data) 91 | | Ok () -> client_tcp dst port data 92 | end 93 | | Some x -> 94 | Dns.send_tcp x (Cstruct.of_string data) >>= function 95 | | Ok () -> Lwt.return_unit 96 | | Error () -> 97 | tcp_out := Ipaddr.Map.remove dst !tcp_out ; 98 | client_tcp dst port data 99 | and maybe_tcp dst port data = 100 | (match Ipaddr.Map.find_opt dst !tcp_out with 101 | | Some flow -> Dns.send_tcp flow (Cstruct.of_string data) 102 | | None -> Lwt.return (Error ())) >>= function 103 | | Ok () -> Lwt.return_unit 104 | | Error () -> 105 | let sport = sport () in 106 | S.UDP.listen (S.udp stack) ~port:sport (udp_cb sport false) ; 107 | Dns.send_udp stack sport dst port (Cstruct.of_string data) 108 | and handle_query (proto, dst, data) = match proto with 109 | | `Udp -> maybe_tcp dst server_port data 110 | | `Tcp -> client_tcp dst server_port data 111 | and handle_answer (proto, dst, dst_port, ttl, data) = match proto with 112 | | `Udp -> Dns.send_udp stack port dst dst_port (Cstruct.of_string data) 113 | | `Tcp -> 114 | let from_tcp = FM.find_opt (dst, dst_port) !tcp_in in 115 | let from_ocaml = FM.find_opt (dst, dst_port) !ocaml_in in 116 | 117 | match from_tcp, from_ocaml with 118 | | None, None -> 119 | Log.err (fun m -> m "wanted to answer %a:%d via TCP, but couldn't find a flow" 120 | Ipaddr.pp dst dst_port) ; 121 | Lwt.return_unit 122 | | Some (`Tcp flow), None -> 123 | (Dns.send_tcp flow (Cstruct.of_string data) >|= function 124 | | Ok () -> () 125 | | Error () -> tcp_in := FM.remove (dst, dst_port) !tcp_in) 126 | | Some (`Tls flow), None -> 127 | (send_tls flow (Cstruct.of_string data) >|= function 128 | | Ok () -> () 129 | | Error () -> tcp_in := FM.remove (dst, dst_port) !tcp_in) 130 | | None, Some wk -> begin 131 | ocaml_in := FM.remove (dst, dst_port) !ocaml_in; 132 | Lwt.wakeup wk (ttl, data); 133 | Lwt.return_unit end 134 | | Some _, Some _ -> assert false 135 | 136 | and udp_cb lport req ~src ~dst:_ ~src_port buf = 137 | let buf = Cstruct.to_string buf in 138 | let now = Mirage_ptime.now () 139 | and ts = Mirage_mtime.elapsed_ns () 140 | in 141 | let new_state, answers, queries = 142 | Dns_resolver.handle_buf !state now ts req `Udp src src_port buf 143 | in 144 | if not req then 145 | S.UDP.unlisten (S.udp stack) ~port:lport; 146 | state := new_state ; 147 | Lwt_list.iter_p handle_answer answers >>= fun () -> 148 | Lwt_list.iter_p handle_query queries 149 | in 150 | if udp then begin 151 | S.UDP.listen (S.udp stack) ~port (udp_cb port true); 152 | Log.info (fun f -> f "DNS resolver listening on UDP port %d" port); 153 | end; 154 | 155 | let rec ocaml_cb () = 156 | Lwt_stream.get stream >>= function 157 | | Some (dst_ip, dst_port, data, wk) -> 158 | ocaml_in := FM.add (dst_ip, dst_port) wk !ocaml_in; 159 | let now = Mirage_ptime.now () in 160 | let ts = Mirage_mtime.elapsed_ns () in 161 | let new_state, answers, queries = 162 | Dns_resolver.handle_buf !state now ts true `Tcp dst_ip dst_port data in 163 | state := new_state ; 164 | Lwt_list.iter_p handle_answer answers >>= fun () -> 165 | Lwt_list.iter_p handle_query queries >>= fun () -> 166 | ocaml_cb () 167 | | None -> Lwt.return_unit in 168 | Lwt.async ocaml_cb; 169 | 170 | let tcp_cb query flow = 171 | let dst_ip, dst_port = T.dst flow in 172 | Log.debug (fun m -> m "tcp connection from %a:%d" Ipaddr.pp dst_ip dst_port) ; 173 | tcp_in := FM.add (dst_ip, dst_port) (`Tcp flow) !tcp_in ; 174 | let f = Dns.of_flow flow in 175 | let rec loop () = 176 | Dns.read_tcp f >>= function 177 | | Error () -> 178 | tcp_in := FM.remove (dst_ip, dst_port) !tcp_in ; 179 | Lwt.return_unit 180 | | Ok data -> 181 | let data = Cstruct.to_string data in 182 | let now = Mirage_ptime.now () in 183 | let ts = Mirage_mtime.elapsed_ns () in 184 | let new_state, answers, queries = 185 | Dns_resolver.handle_buf !state now ts query `Tcp dst_ip dst_port data 186 | in 187 | state := new_state ; 188 | Lwt_list.iter_p handle_answer answers >>= fun () -> 189 | Lwt_list.iter_p handle_query queries >>= fun () -> 190 | loop () 191 | in 192 | loop () 193 | in 194 | if tcp then begin 195 | S.TCP.listen (S.tcp stack) ~port (tcp_cb true); 196 | Log.info (fun m -> m "DNS resolver listening on TCP port %d" port); 197 | end; 198 | 199 | let rec read_tls ({ tls_flow ; linger } as f) length = 200 | if Cstruct.length linger >= length then 201 | let a, b = Cstruct.split linger length in 202 | f.linger <- b; 203 | Lwt.return (Ok a) 204 | else 205 | TLS.read tls_flow >>= function 206 | | Ok `Eof -> Log.debug (fun m -> m "end of file while reading"); TLS.close tls_flow >|= fun () -> Error () 207 | | Error e -> Log.warn (fun m -> m "error reading TLS: %a" TLS.pp_error e); TLS.close tls_flow >|= fun () -> Error () 208 | | Ok (`Data d) -> 209 | f.linger <- Cstruct.append linger d; 210 | read_tls f length 211 | in 212 | let read_tls_packet f = 213 | read_tls f 2 >>= function 214 | | Error () -> Lwt.return (Error ()) 215 | | Ok k -> 216 | let len = Cstruct.BE.get_uint16 k 0 in 217 | read_tls f len 218 | in 219 | 220 | let tls_cb cfg flow = 221 | let dst_ip, dst_port = T.dst flow in 222 | TLS.server_of_flow cfg flow >>= function 223 | | Error e -> 224 | Log.warn (fun m -> m "TLS error (from %a:%d): %a" Ipaddr.pp dst_ip dst_port 225 | TLS.pp_write_error e); 226 | Lwt.return_unit 227 | | Ok tls -> 228 | Log.debug (fun m -> m "tls connection from %a:%d" Ipaddr.pp dst_ip dst_port); 229 | tcp_in := FM.add (dst_ip, dst_port) (`Tls tls) !tcp_in ; 230 | let tls_and_linger = { tls_flow = tls ; linger = Cstruct.empty } in 231 | let rec loop () = 232 | read_tls_packet tls_and_linger >>= function 233 | | Error () -> 234 | tcp_in := FM.remove (dst_ip, dst_port) !tcp_in ; 235 | Lwt.return_unit 236 | | Ok data -> 237 | let data = Cstruct.to_string data in 238 | let now = Mirage_ptime.now () in 239 | let ts = Mirage_mtime.elapsed_ns () in 240 | let new_state, answers, queries = 241 | Dns_resolver.handle_buf !state now ts true `Tcp dst_ip dst_port data 242 | in 243 | state := new_state ; 244 | Lwt_list.iter_p handle_answer answers >>= fun () -> 245 | Lwt_list.iter_p handle_query queries >>= fun () -> 246 | loop () 247 | in 248 | loop () 249 | in 250 | (match tls with 251 | | None -> () 252 | | Some cfg -> 253 | S.TCP.listen (S.tcp stack) ~port:tls_port (tls_cb cfg); 254 | Log.info (fun m -> m "DNS resolver listening on TLS port %d" tls_port)); 255 | 256 | let rec time () = 257 | let new_state, answers, queries = 258 | Dns_resolver.timer !state (Mirage_mtime.elapsed_ns ()) 259 | in 260 | state := new_state ; 261 | Lwt_list.iter_p handle_answer answers >>= fun () -> 262 | Lwt_list.iter_p handle_query queries >>= fun () -> 263 | Mirage_sleep.ns (Duration.of_ms timer) >>= fun () -> 264 | time () 265 | in 266 | Lwt.async time ; 267 | 268 | if root then begin 269 | let rec root () = 270 | let new_state, q = Dns_resolver.query_root !state (Mirage_mtime.elapsed_ns ()) `Tcp in 271 | state := new_state ; 272 | handle_query q >>= fun () -> 273 | Mirage_sleep.ns (Duration.of_day 6) >>= fun () -> 274 | root () 275 | in 276 | Lwt.async root end ; 277 | push 278 | 279 | let resolve_external push (dst_ip, dst_port) data = 280 | let th, wk = Lwt.wait () in 281 | push (Some (dst_ip, dst_port, data, wk)); 282 | th 283 | end 284 | -------------------------------------------------------------------------------- /mirage/resolver/dns_resolver_mirage.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | module Make (S : Tcpip.Stack.V4V6) : sig 4 | type t 5 | 6 | val resolver 7 | : S.t -> ?root:bool -> ?timer:int -> ?udp:bool -> ?tcp:bool -> ?tls:Tls.Config.server -> ?port:int -> ?tls_port:int 8 | -> Dns_resolver.t -> t 9 | (** [resolver stack ~root ~timer ~udp ~tcp ~tls ~port ~tls_port resolver] 10 | registers a caching resolver on the provided protocols [udp], [tcp], [tls] 11 | using [port] for udp and tcp (defaults to 53), [tls_port] for tls (defaults 12 | to 853) using the [resolver] configuration. The [timer] is in milliseconds 13 | and defaults to 500 milliseconds.*) 14 | 15 | val resolve_external : t -> Ipaddr.t * int -> string -> (int32 * string) Lwt.t 16 | (** [resolve_external t (ip, port) data] resolves for [(ip, port)] the query 17 | [data] and returns a pair of the minimum TTL and a response. *) 18 | end 19 | -------------------------------------------------------------------------------- /mirage/resolver/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_resolver_mirage) 3 | (public_name dns-resolver.mirage) 4 | (wrapped false) 5 | (libraries dns dns-resolver dns-server dns-mirage lwt duration mirage-sleep mirage-ptime mirage-mtime tcpip mirage-crypto-rng tls tls-mirage)) 6 | -------------------------------------------------------------------------------- /mirage/server/dns_server_mirage.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | module Make (S : Tcpip.Stack.V4V6) : sig 4 | 5 | val primary : 6 | ?on_update:(old:Dns_trie.t -> authenticated_key:[`raw] Domain_name.t option -> update_source:Ipaddr.t -> Dns_server.Primary.s -> unit Lwt.t) -> 7 | ?on_notify:([ `Notify of Dns.Soa.t option | `Signed_notify of Dns.Soa.t option ] -> 8 | Dns_server.Primary.s -> 9 | (Dns_trie.t * ([ `raw ] Domain_name.t * Dns.Dnskey.t) list) option Lwt.t) -> 10 | ?timer:int -> ?port:int -> S.t -> Dns_server.Primary.s -> unit 11 | (** [primary ~on_update ~timer ~port stack primary] starts a primary server on 12 | [port] (default 53, both TCP and UDP) with the given [primary] 13 | configuration. [timer] is the DNS notify timer in seconds, and defaults to 14 | 2 seconds. [on_update ~old ~authenticated_key ~update_source s] is a 15 | callback if the data served by the primary server [s] got updated by a 16 | potentially authenticated nsupdate packet, the used [authenticated_key] 17 | and source [update_source] are passed to the callback. The 18 | [on_notify notify s] callback is executed when a notify request is received 19 | by the primary DNS server (may be used for signaling of a (hidden) DNS 20 | secondary server). *) 21 | 22 | val secondary : 23 | ?on_update:(old:Dns_trie.t -> Dns_server.Secondary.s -> unit Lwt.t) -> 24 | ?timer:int -> ?port:int -> S.t -> Dns_server.Secondary.s -> 25 | unit 26 | (** [secondary ~on_update ~timer ~port stack secondary] starts a secondary 27 | server on [port] (default 53). The [on_update] callback is executed when 28 | the zone changes. The [timer] (in seconds, defaults to 5 seconds) is used 29 | for refreshing zones. *) 30 | end 31 | -------------------------------------------------------------------------------- /mirage/server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_server_mirage) 3 | (public_name dns-server.mirage) 4 | (wrapped false) 5 | (libraries dns dns-server dns-mirage lwt duration randomconv mirage-sleep mirage-ptime mirage-mtime tcpip metrics)) 6 | -------------------------------------------------------------------------------- /mirage/stub/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_stub_mirage) 3 | (public_name dns-stub.mirage) 4 | (wrapped false) 5 | (libraries dns dns-server dns-tsig metrics dns-resolver dns-mirage dns-client-mirage lwt mirage-ptime tcpip mirage-crypto-rng)) 6 | -------------------------------------------------------------------------------- /resolvconf/dns_resolvconf.ml: -------------------------------------------------------------------------------- 1 | let parse buf = 2 | try 3 | Resolvconf_state.reset (); 4 | let buf = 5 | if String.(get buf (pred (length buf))) = '\n' then buf else buf ^ "\n" 6 | in 7 | let lexbuf = Lexing.from_string buf in 8 | Ok (Resolvconf_parser.resolvconf Resolvconf_lexer.lex lexbuf) 9 | with 10 | | Parsing.Parse_error -> 11 | Error (`Msg (Fmt.str "parse error at line %d" Resolvconf_state.(state.lineno))) 12 | | exn -> 13 | Error (`Msg (Fmt.str "error at line %d: %s" Resolvconf_state.(state.lineno) 14 | (Printexc.to_string exn))) 15 | -------------------------------------------------------------------------------- /resolvconf/dns_resolvconf.mli: -------------------------------------------------------------------------------- 1 | val parse : string -> ([ `Nameserver of Ipaddr.t ] list, [> `Msg of string ]) result 2 | -------------------------------------------------------------------------------- /resolvconf/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_resolvconv) 3 | (public_name dns-client.resolvconf) 4 | (private_modules resolvconf_lexer resolvconf_parser resolvconf_state) 5 | (libraries ipaddr fmt) 6 | (wrapped false)) 7 | 8 | (ocamlyacc resolvconf_parser) 9 | (ocamllex resolvconf_lexer) 10 | -------------------------------------------------------------------------------- /resolvconf/resolvconf_lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Resolvconf_state 3 | open Resolvconf_parser 4 | } 5 | 6 | let ipv4 = (['0'-'9']+ '.' ['0'-'9']+ '.' ['0'-'9']+ '.' ['0'-'9']+) as contents 7 | let ipv6 = (['0'-'9' 'a'-'f' 'A'-'F' ':']+) as contents 8 | 9 | let zone_id = (['0'-'9' 'a'-'z' 'A'-'Z' '.' ]+) as contents 10 | 11 | (* inspired by https://github.com/tailhook/resolv-conf/blob/master/src/grammar.rs *) 12 | 13 | rule lex = parse 14 | | "nameserver" { SNAMESERVER } 15 | | "options" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL } 16 | | "search" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL } 17 | | "domain" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL } 18 | | "sortlist" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL } 19 | | "lookup" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL } 20 | | "family" ([^'\n']*) '\n' { state.lineno <- state.lineno + 1 ; EOL } 21 | | [' ' '\t']+ { SPACE } 22 | | ipv4 { IPV4 contents } 23 | | ipv6 { IPV6 contents } 24 | | '.' { DOT } 25 | | ':' { COLON } 26 | | '%' { PERCENT } 27 | | [' ' '\t']* ('#' [^'\n']*)? '\n' { state.lineno <- state.lineno + 1 ; EOL } 28 | | [' ' '\t']* (';' [^'\n']*)? '\n' { state.lineno <- state.lineno + 1 ; EOL } 29 | | zone_id { ZONE_ID contents } 30 | | eof { EOF } 31 | -------------------------------------------------------------------------------- /resolvconf/resolvconf_parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | %} 3 | 4 | %token EOF 5 | %token EOL 6 | %token SPACE 7 | %token SNAMESERVER 8 | %token DOT 9 | %token COLON 10 | %token PERCENT 11 | %token IPV4 12 | %token IPV6 13 | %token ZONE_ID 14 | 15 | %start resolvconf 16 | %type <[ `Nameserver of Ipaddr.t ] list> resolvconf 17 | 18 | %% 19 | 20 | resolvconf: lines EOF { List.rev $1 } 21 | 22 | lines: 23 | /* nothing */ { [] } 24 | | lines EOL { $1 } 25 | | lines nameserver EOL { $2 :: $1 } 26 | 27 | s: SPACE {} | s SPACE {} 28 | 29 | ipv4: IPV4 { Ipaddr.V4.of_string_exn $1 } 30 | 31 | ipv6: 32 | IPV6 { Ipaddr.V6.of_string_exn $1 } 33 | | IPV6 PERCENT ZONE_ID { Ipaddr.V6.of_string_exn $1 } 34 | 35 | nameserver: 36 | SNAMESERVER s ipv4 { `Nameserver (Ipaddr.V4 $3) } 37 | | SNAMESERVER s ipv6 { `Nameserver (Ipaddr.V6 $3) } 38 | -------------------------------------------------------------------------------- /resolvconf/resolvconf_state.ml: -------------------------------------------------------------------------------- 1 | (* State variables for the parser & lexer *) 2 | type parserstate = { 3 | mutable lineno : int ; 4 | } 5 | 6 | let state = { 7 | lineno = 1 ; 8 | } 9 | 10 | let reset () = 11 | state.lineno <- 1 12 | -------------------------------------------------------------------------------- /resolver/dns_resolver.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | type t 4 | (** The type of a DNS resolver. *) 5 | 6 | val create : ?cache_size:int -> 7 | ?ip_protocol:[ `Both | `Ipv4_only | `Ipv6_only ] -> 8 | ?dnssec:bool -> 9 | int64 -> (int -> string) -> Dns_server.Primary.s -> t 10 | (** [create ~cache_size ~ip_protocol ~dnssec now rng primary] creates the value 11 | of a resolver, pre-filled with root NS and their IP addresses. If 12 | [ip_protocol] is provided, and set to [`V4_only], only IPv4 packets will be 13 | emitted. If [`V6_only] is set, only IPv6 packets will be emitted. If [`Both] 14 | (the default), either IPv4 and IPv6 packets are emitted. If [dnssec] is 15 | provided and [false] (defaults to [true]), DNSSec validation will be 16 | disabled. *) 17 | 18 | val handle_buf : t -> Ptime.t -> int64 -> bool -> Dns.proto -> Ipaddr.t -> 19 | int -> string -> 20 | t * (Dns.proto * Ipaddr.t * int * int32 * string) list 21 | * (Dns.proto * Ipaddr.t * string) list 22 | (** [handle_buf t now ts query_or_reply proto sender source-port buf] handles 23 | resolution of [buf], which leads to a new [t], a list of answers to be 24 | transmitted (quintuuple of protocol, ip address, port, minimum ttl, buffer), 25 | and a list of queries (triple of protocol, ip address, buffer). *) 26 | 27 | val query_root : t -> int64 -> Dns.proto -> 28 | t * (Dns.proto * Ipaddr.t * string) 29 | (** [query_root t now proto] potentially requests an update of the root 30 | zone. Best invoked by a regular timer. *) 31 | 32 | val timer : t -> int64 -> 33 | t * (Dns.proto * Ipaddr.t * int * int32 * string) list 34 | * (Dns.proto * Ipaddr.t * string) list 35 | (** [timer t now] potentially retransmits DNS requests and/or sends NXDomain 36 | answers. *) 37 | -------------------------------------------------------------------------------- /resolver/dns_resolver_cache.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | open Dns 3 | 4 | val pp_question : ([ `raw ] Domain_name.t * Packet.Question.qtype) Fmt.t 5 | 6 | val follow_cname : Dns_cache.t -> int64 -> 'a Rr_map.key -> name:[ `raw ] Domain_name.t -> int32 -> 7 | alias:[ `raw ] Domain_name.t -> 8 | [ `Out of Rcode.t * Rrsig.t option * Name_rr_map.t * Name_rr_map.t 9 | | `Query of [ `raw ] Domain_name.t ] * Dns_cache.t 10 | 11 | val answer : dnssec:bool -> dnssec_ok:bool -> Dns_cache.t -> int64 -> [ `raw ] Domain_name.t -> Packet.Question.qtype -> 12 | [ `Query of [ `raw ] Domain_name.t 13 | | `Packet of Packet.Flags.t * Packet.reply * Name_rr_map.t option ] * Dns_cache.t 14 | 15 | val resolve : Dns_cache.t -> dnssec:bool -> 16 | rng:(int -> string) -> [`Both | `Ipv4_only | `Ipv6_only] -> int64 -> [ `raw ] Domain_name.t -> 17 | Packet.Question.qtype -> 18 | [ `raw ] Domain_name.t * [ `raw ] Domain_name.t * Packet.Question.qtype list * Ipaddr.t * Dns_cache.t 19 | 20 | val handle_query : Dns_cache.t -> dnssec:bool -> dnssec_ok:bool -> 21 | rng:(int -> string) -> [`Both | `Ipv4_only | `Ipv6_only ] -> 22 | int64 -> 23 | [ `raw ] Domain_name.t * Packet.Question.qtype -> 24 | [ `Reply of Packet.Flags.t * Packet.reply * Name_rr_map.t option 25 | | `Query of [ `raw ] Domain_name.t * ([ `raw ] Domain_name.t * Packet.Question.qtype list) * Ipaddr.t ] * Dns_cache.t 26 | -------------------------------------------------------------------------------- /resolver/dns_resolver_root.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | open Dns 3 | 4 | let root_servers = 5 | List.map (fun (n, ip4, ip6) -> 6 | Domain_name.(host_exn (of_string_exn n)), 7 | Ipaddr.V4.of_string_exn ip4, 8 | Ipaddr.V6.of_string_exn ip6) 9 | [ 10 | "a.root-servers.net", "198.41.0.4", "2001:503:ba3e::2:30" ; (* VeriSign, Inc. *) 11 | "b.root-servers.net", "170.247.170.2", "2801:1b8:10::b" ; (* University of Southern California (ISI) *) 12 | "c.root-servers.net", "192.33.4.12", "2001:500:2::c" ; (* Cogent Communications *) 13 | "d.root-servers.net", "199.7.91.13", "2001:500:2d::d" ; (* University of Maryland *) 14 | "e.root-servers.net", "192.203.230.10", "2001:500:a8::e" ; (* NASA (Ames Research Center) *) 15 | "f.root-servers.net", "192.5.5.241", "2001:500:2f::f" ; (* Internet Systems Consortium, Inc. *) 16 | "g.root-servers.net", "192.112.36.4", "2001:500:12::d0d" ; (* US Department of Defense (NIC) *) 17 | "h.root-servers.net", "198.97.190.53", "2001:500:1::53" ; (* US Army (Research Lab) *) 18 | "i.root-servers.net", "192.36.148.17", "2001:7fe::53" ; (* Netnod *) 19 | "j.root-servers.net", "192.58.128.30", "2001:503:c27::2:30" ; (* VeriSign, Inc. *) 20 | "k.root-servers.net", "193.0.14.129", "2001:7fd::1" ; (* RIPE NCC *) 21 | "l.root-servers.net", "199.7.83.42", "2001:500:9f::42" ; (* ICANN *) 22 | "m.root-servers.net", "202.12.27.33", "2001:dc3::35" ; (* WIDE Project *) 23 | ] 24 | 25 | let a_ttl = 3600000l 26 | let ns_ttl = 518400l 27 | 28 | let ns_records = 29 | let ns = 30 | let add_to_set set (name, _, _) = Domain_name.Host_set.add name set in 31 | List.fold_left add_to_set Domain_name.Host_set.empty root_servers 32 | in 33 | (ns_ttl, ns) 34 | 35 | let a_records = 36 | List.map (fun (name, ip, _) -> 37 | Domain_name.raw name, (a_ttl, Ipaddr.V4.Set.singleton ip)) 38 | root_servers 39 | 40 | let aaaa_records = 41 | List.map (fun (name, _, ip) -> 42 | Domain_name.raw name, (a_ttl, Ipaddr.V6.Set.singleton ip)) 43 | root_servers 44 | 45 | let ips protocol = 46 | List.fold_left (fun acc (_, ip4, ip6) -> 47 | match protocol with 48 | | `Both -> Ipaddr.V4 ip4 :: Ipaddr.V6 ip6 :: acc 49 | | `Ipv4_only -> Ipaddr.V4 ip4 :: acc 50 | | `Ipv6_only -> Ipaddr.V6 ip6 :: acc) 51 | [] root_servers 52 | 53 | let reserved_zone_records = 54 | let n = Domain_name.of_string_exn in 55 | (* RFC 6761, avoid them to get out of here + multicast DNS 6762 *) 56 | let zones = 57 | Domain_name.Set.(add (n "local") (* multicast dns, RFC 6762 *) 58 | (add (n "test") (add (n "invalid") (* RFC 6761 *) 59 | (add (n "localhost") (* RFC 6761, draft let-localhost-be-localhost *) 60 | empty)))) 61 | in 62 | let local_net_name = "127.in-addr.arpa" in 63 | Domain_name.Set.add (n local_net_name) zones 64 | 65 | let stub_soa s = 66 | let nameserver = Domain_name.prepend_label_exn s "ns" 67 | and hostmaster = Domain_name.prepend_label_exn s "hostmaster" 68 | in 69 | { Soa.nameserver ; hostmaster ; serial = 0l ; refresh = 300l ; retry = 300l ; 70 | expiry = 300l ; minimum = 300l } 71 | 72 | let reserved_zones = 73 | let inv s = Rr_map.(B (Soa, stub_soa s)) in 74 | Domain_name.Set.fold (fun n acc -> (n, inv n) :: acc) reserved_zone_records [] 75 | 76 | let reserved = 77 | Domain_name.Set.fold (fun name trie -> 78 | Dns_trie.insert name Rr_map.Soa (stub_soa name) trie) 79 | reserved_zone_records Dns_trie.empty 80 | 81 | let root_servers = 82 | List.map (fun (n, ip4, ip6) -> Domain_name.raw n, ip4, ip6) root_servers 83 | -------------------------------------------------------------------------------- /resolver/dns_resolver_root.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | val root_servers : ([ `raw ] Domain_name.t * Ipaddr.V4.t * Ipaddr.V6.t) list 6 | (** [root_servers] are the root servers. *) 7 | 8 | val ns_records : (int32 * Domain_name.Host_set.t) 9 | (** [ns_records] is the root nameserver binding. *) 10 | 11 | val a_records : ([ `raw ] Domain_name.t * (int32 * Ipaddr.V4.Set.t)) list 12 | (** [a_records] is a list of names and bindings (A records) for the root 13 | servers. *) 14 | 15 | val aaaa_records : ([ `raw ] Domain_name.t * (int32 * Ipaddr.V6.Set.t)) list 16 | (** [aaaa_records] is a list of names and bindings (AAAA records) for the root 17 | servers. *) 18 | 19 | val ips : [ `Both | `Ipv4_only | `Ipv6_only ] -> Ipaddr.t list 20 | (** [ips ip_proto] is a list of ip addresses of the root servers. *) 21 | 22 | val reserved_zones : ([ `raw ] Domain_name.t * Rr_map.b) list 23 | (** [reserved_zones] is a list of names and bindings for reserved zones 24 | specified by RFCs (private network address ranges, private domains) *) 25 | 26 | val reserved : Dns_trie.t 27 | (** [reserved] is a trie with all [reserved_zones]. *) 28 | -------------------------------------------------------------------------------- /resolver/dns_resolver_utils.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | type e = E : 'a Rr_map.key * 'a Dns_cache.entry -> e 6 | 7 | val scrub : [ `raw ] Domain_name.t -> signed:bool -> Packet.Question.qtype -> 8 | Packet.t -> 9 | (([ `raw ] Domain_name.t * e * Dns_cache.rank) list, Rcode.t) result 10 | (** [scrub bailiwick packet] returns a list of entries to-be-added to the 11 | cache. This respects only in-bailiwick resources records, and qualifies the 12 | [packet]. The purpose is to avoid cache poisoning by not accepting all 13 | resource records. *) 14 | 15 | val invalid_soa : [ `raw ] Domain_name.t -> Soa.t 16 | (** [invalid_soa name] returns a stub SOA for [name]. *) 17 | -------------------------------------------------------------------------------- /resolver/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_resolver) 3 | (public_name dns-resolver) 4 | (instrumentation 5 | (backend bisect_ppx)) 6 | (wrapped false) 7 | (libraries dns dns.cache dns-server lru duration randomconv dnssec logs)) 8 | -------------------------------------------------------------------------------- /server/dns_server.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | (** DNS Server implementation *) 6 | 7 | (** Authentication, stored in a Dns_trie with privileges to operations embedded in the name. *) 8 | module Authentication : sig 9 | (** A key is a pair of a [`raw Domain_name.t] and a [Dnskey.t]. In the name, 10 | operation privileges and potentially IP addresses are encoded, e.g. 11 | [foo._transfer.example.com] may do AXFR on [example.com] and any 12 | subdomain, e.g. [foo.example.com]. *) 13 | 14 | type operation = [ 15 | | `Update 16 | | `Transfer 17 | | `Notify 18 | ] 19 | (** The type of operations, sorted by highest ot lowest privileges, an 20 | [`Update] may as well carry out a [`Transfer]. *) 21 | 22 | val operation_to_string : operation -> string 23 | (** [operation_to_string op] is the string representation of [op]. *) 24 | 25 | val all_ops : operation list 26 | (** [all_ops] is a list of all operations. *) 27 | 28 | val access_granted : required:operation -> operation -> bool 29 | (** [access_granted ~required key_operation] is [true] if [key_operation] is 30 | authorised for [required] operation. *) 31 | 32 | val zone_and_operation : 'a Domain_name.t -> ([`host] Domain_name.t * operation) option 33 | (** [zone_and_operation key] is [Some (zone, op)], the [zone] of the [key], 34 | and its operation [op]. If the [key] is not in the expected format, [None] 35 | is returned. *) 36 | 37 | val access : ?key:'a Domain_name.t -> zone:'b Domain_name.t -> operation -> bool 38 | (** [access op ~key ~zone] checks whether [key] is authorised for [op] on 39 | [zone]. *) 40 | 41 | type t 42 | (** Opaque type for storing authentication keys. *) 43 | end 44 | 45 | type t = private { 46 | data : Dns_trie.t ; 47 | auth : Authentication.t ; 48 | unauthenticated_zone_transfer : bool ; 49 | rng : int -> string ; 50 | tsig_verify : Tsig_op.verify ; 51 | tsig_sign : Tsig_op.sign ; 52 | } 53 | (** The state of a DNS server. *) 54 | 55 | val create : ?unauthenticated_zone_transfer:bool -> 56 | ?tsig_verify:Tsig_op.verify -> 57 | ?tsig_sign:Tsig_op.sign -> 58 | ?auth:Authentication.t -> 59 | Dns_trie.t -> 60 | (int -> string) -> 61 | t 62 | (** [create ~unauthenticated_zone_transfer ~tsig_verify ~tsig_sign ~auth data rng] 63 | constructs a [t]. See {!Primary.create} and {!Secondary.create} for the 64 | logic running a primary or secondary server. *) 65 | 66 | val with_data : t -> Dns_trie.t -> t 67 | (** [with_data t data] is [t'] where the [data] field is updated with the 68 | provided value. Be aware that this function breaks the semantics of a 69 | primary server with secondaries, since secondaries won't be notified and 70 | will be out of sync. Use if you know what you do. The data of a secondary 71 | will usually come via zone transfer from the primary name services. *) 72 | 73 | val text : 'a Domain_name.t -> Dns_trie.t -> (string, [> `Msg of string ]) result 74 | (** [text name trie] results in a string representation (zonefile) of the trie. *) 75 | 76 | val handle_question : t -> Packet.Question.t -> 77 | (Packet.Flags.t * Packet.Answer.t * Name_rr_map.t option, 78 | Rcode.t * Packet.Answer.t option) result 79 | (** [handle_question t question] handles the DNS query [question] by looking 80 | it up in the trie of [t]. The result is either an answer or an error. *) 81 | 82 | val update_data : Dns_trie.t -> 'a Domain_name.t -> 83 | Dns.Packet.Update.prereq list Domain_name.Map.t 84 | * Dns.Packet.Update.update list Domain_name.Map.t -> 85 | ( Dns_trie.t * (Domain_name.Set.elt * Dns.Soa.t) list, 86 | Dns.Rcode.t ) 87 | result 88 | (** [update_data data domain update_content] applies the [update_content] to 89 | the [data] for [domain]. This function breaks the semantics of a primary 90 | server with secondaries, since the secondaries won't be notified of the 91 | update and will be out of sync. Use if you know what you are doing. *) 92 | 93 | val handle_update : t -> proto -> [ `raw ] Domain_name.t option -> 94 | Packet.Question.t -> Packet.Update.t -> 95 | (Dns_trie.t * ([`raw] Domain_name.t * Soa.t) list, Rcode.t) result 96 | (** [handle_update t proto keyname question update] authenticates the update 97 | request and processes the update. This function breaks the semantics of a 98 | primary server with secondaries, since the secondaries won't be notified. 99 | Use if you know what you are doing. *) 100 | 101 | val handle_axfr_request : t -> proto -> [ `raw ] Domain_name.t option -> 102 | Packet.Question.t -> (Packet.Axfr.t, Rcode.t) result 103 | (** [handle_axfr_request t proto keyname question] authenticates the zone 104 | transfer request and processes it. If the request is valid, and the zone 105 | available, a zone transfer is returned. *) 106 | 107 | type trie_cache 108 | 109 | val handle_ixfr_request : t -> trie_cache -> proto -> [ `raw ] Domain_name.t option -> 110 | Packet.Question.t -> Soa.t -> (Packet.Ixfr.t, Rcode.t) result 111 | (** [handle_ixfr_request t cache proto keyname question soa] authenticates the 112 | incremental zone transfer request and processes it. If valid, an incremental 113 | zone transfer is returned. *) 114 | 115 | val handle_tsig : ?mac:string -> t -> Ptime.t -> Packet.t -> 116 | string -> (([ `raw ] Domain_name.t * Tsig.t * string * Dnskey.t) option, 117 | Tsig_op.e * string option) result 118 | (** [handle_tsig ~mac t now packet buffer] verifies the tsig 119 | signature if present, returning the keyname, tsig, mac, and used key. *) 120 | 121 | type packet_callback = Packet.Question.t -> Packet.reply option 122 | (** [packet_callback question] either returns a reply to a DNS question [Some reply] or [None]. *) 123 | 124 | module Primary : sig 125 | 126 | type s 127 | (** The state of a primary DNS server. *) 128 | 129 | val server : s -> t 130 | (** [server s] is the server of the primary. *) 131 | 132 | val data : s -> Dns_trie.t 133 | (** [data s] is the data store of [s]. *) 134 | 135 | val with_data : s -> Ptime.t -> int64 -> Dns_trie.t -> 136 | s * (Ipaddr.t * string list) list 137 | (** [with_data s now ts trie] replaces the current data with [trie] in [s]. 138 | The returned notifications should be send out. *) 139 | 140 | val with_keys : s -> Ptime.t -> int64 -> ('a Domain_name.t * Dnskey.t) list -> 141 | s * (Ipaddr.t * string list) list 142 | (** [with_keys s now ts keys] replaces the current keys with [keys] in [s], 143 | and generates notifications. *) 144 | 145 | val trie_cache : s -> trie_cache 146 | (** [trie_cache s] is the trie cache of the server. *) 147 | 148 | val create : ?keys:('a Domain_name.t * Dnskey.t) list -> 149 | ?unauthenticated_zone_transfer:bool -> 150 | ?tsig_verify:Tsig_op.verify -> ?tsig_sign:Tsig_op.sign -> 151 | rng:(int -> string) -> Dns_trie.t -> s 152 | (** [create ~keys ~unauthenticated_zone_transfer ~tsig_verify ~tsig_sign ~rng 153 | data] creates a primary server. If [unauthenticated_zone_transfer] is 154 | provided and [true] (defaults to [false]), anyone can transfer the zones. *) 155 | 156 | val handle_packet : ?packet_callback:packet_callback -> s -> Ptime.t -> int64 157 | -> proto -> Ipaddr.t -> int -> Packet.t -> 'a Domain_name.t option -> 158 | s * Packet.t option * (Ipaddr.t * string list) list * 159 | [> `Notify of Soa.t option | `Keep ] option 160 | (** [handle_packet ~packet_callback s now ts src src_port proto key packet] 161 | handles the given [packet], returning new state, an answer, and 162 | potentially notify packets to secondary name servers. If [packet_callback] 163 | is specified, it is called for each incoming query. If it returns 164 | [Some reply], this reply is used instead of the usual lookup in the 165 | zone data. It can be used for custom query processing, such as for load 166 | balancing or transporting data. *) 167 | 168 | val handle_buf : ?packet_callback:packet_callback -> s -> Ptime.t -> int64 169 | -> proto -> Ipaddr.t -> int -> string -> 170 | s * string list * (Ipaddr.t * string list) list * 171 | [ `Notify of Soa.t option | `Signed_notify of Soa.t option | `Keep ] option * 172 | [ `raw ] Domain_name.t option 173 | (** [handle_buf ~packet_callback s now ts proto src src_port buffer] decodes 174 | the [buffer], processes the DNS frame using {!handle_packet}, and encodes 175 | the reply. The result is a new state, potentially a list of answers to the 176 | requestor, a list of notifications to send out, information whether a 177 | notify (or signed notify) was received, and the hmac key used for 178 | authentication. If [packet_callback] is specified, it is called for each 179 | incoming query. If it returns [Some reply], this reply is used instead of 180 | the usual lookup in the zone data. This can be used for custom query 181 | processing, such as for load balancing or transporting data. *) 182 | 183 | val closed : s -> Ipaddr.t -> s 184 | (** [closed s ip] marks the connection to [ip] closed. *) 185 | 186 | val timer : s -> Ptime.t -> int64 -> 187 | s * (Ipaddr.t * string list) list 188 | (** [timer s now ts] may encode some notifications to secondary name servers 189 | if previous ones were not acknowledged. *) 190 | 191 | val to_be_notified : s -> [ `host ] Domain_name.t -> 192 | (Ipaddr.t * [ `raw ] Domain_name.t option) list 193 | (** [to_be_notified s zone] returns a list of pairs of IP address and optional 194 | tsig key name of the servers to be notified for a zone change. This list 195 | is based on (a) NS entries for the zone, (b) registered TSIG transfer keys, 196 | and (c) active connection (which transmitted a signed SOA). *) 197 | end 198 | 199 | module Secondary : sig 200 | 201 | type s 202 | (** The state of a secondary DNS server. *) 203 | 204 | val data : s -> Dns_trie.t 205 | (** [data s] is the zone data of [s]. *) 206 | 207 | val with_data : s -> Dns_trie.t -> s 208 | (** [with_data s trie] is [s] with its data replaced by [trie]. *) 209 | 210 | val create : ?primary:Ipaddr.t -> 211 | tsig_verify:Tsig_op.verify -> tsig_sign:Tsig_op.sign -> 212 | rng:(int -> string) -> ('a Domain_name.t * Dnskey.t) list -> s 213 | (** [create ~primary ~tsig_verify ~tsig_sign ~rng keys] creates a secondary 214 | DNS server state. *) 215 | 216 | val handle_packet : ?packet_callback:packet_callback -> s -> Ptime.t -> int64 -> 217 | Ipaddr.t -> Packet.t -> 'a Domain_name.t option -> 218 | s * Packet.t option * (Ipaddr.t * string) option 219 | (** [handle_packet s now ts ip proto key t] handles the incoming packet. *) 220 | 221 | val handle_buf : ?packet_callback:packet_callback -> s -> Ptime.t -> int64 -> 222 | proto -> Ipaddr.t -> string -> 223 | s * string option * (Ipaddr.t * string) option 224 | (** [handle_buf ~packet_callback s now ts proto src buf] decodes [buf], processes with 225 | {!handle_packet}, and encodes the results. *) 226 | 227 | val timer : s -> Ptime.t -> int64 -> 228 | s * (Ipaddr.t * string list) list 229 | (** [timer s now ts] may request SOA or retransmit AXFR. *) 230 | 231 | val closed : s -> Ptime.t -> int64 -> Ipaddr.t -> 232 | s * string list 233 | (** [closed s now ts ip] marks [ip] as closed, the returned buffers (SOA 234 | requests) should be sent to [ip]. *) 235 | end 236 | -------------------------------------------------------------------------------- /server/dns_trie.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | (** Prefix tree data structure for domain names 3 | 4 | The key is a {!Domain_name}, whereas the value may be any resource record. 5 | The representation is a tree, where the edges are domain name labels, and 6 | the nodes carry a {{!Dns.Rr_map.t}resource map}. 7 | Some special treatment is applied for zones, which must have a start of 8 | authority entry and a set of name servers. End of authority, also known as 9 | delegation, is supported. Aliases (canonical names, CNAME records) are also 10 | supported. 11 | 12 | The data structure tries to preserve invariants recommended by the domain 13 | name system, such as that for any name there may either be an alias or any 14 | other record, there must be a SOA record, and multiple NS records for an 15 | authoritative zone, a resource type must have entries of the given type (no 16 | NS record for A type, the ttl for all resource records of a rrset is the 17 | same. 18 | *) 19 | 20 | open Dns 21 | 22 | (** {2 Abstract trie type} *) 23 | 24 | type t 25 | (** The type of the trie. *) 26 | 27 | val pp : t Fmt.t 28 | (** [pp ppf t] pretty prints [t] to [ppf]. *) 29 | 30 | val empty : t 31 | (** [empty] is the empty trie. *) 32 | 33 | val equal : t -> t -> bool 34 | (** [equal a b] compares [a] with [b]. *) 35 | 36 | (** {2 Operations to modify the trie} *) 37 | 38 | val insert_map : Rr_map.t Domain_name.Map.t -> t -> t 39 | (** [insert_map m t] inserts all elements of the domain name map [m] into 40 | [t], potentially existing are unioned with {!Dns.Rr_map.unionee}. *) 41 | 42 | val replace_map : Rr_map.t Domain_name.Map.t -> t -> t 43 | (** [replace_map m t] replaces in the trie [t] all existing bindings of the 44 | domain name map [m] with the provided map. *) 45 | 46 | val remove_map : Rr_map.t Domain_name.Map.t -> t -> t 47 | (** [remove_map m t] removes all elements of the domain name map [m] from 48 | [t]. *) 49 | 50 | val insert : 'a Domain_name.t -> 'b Rr_map.key -> 'b -> t -> t 51 | (** [insert n k v t] inserts [k, v] under [n] in [t]. Existing entries are 52 | unioneed with {!Dns.Rr_map.union_rr}. *) 53 | 54 | val replace : 'a Domain_name.t -> 'b Rr_map.key -> 'b -> t -> t 55 | (** [replace n k v t] inserts [k, v] under [n] in [t]. Existing entries are 56 | replaced. *) 57 | 58 | val remove : 'a Domain_name.t -> 'b Rr_map.key -> 'b -> t -> t 59 | (** [remove k ty v t] removes [ty, v] from [t] at [k]. Beware, this may lead 60 | to a [t] where the initially mentioned invariants are violated. *) 61 | 62 | val remove_ty : 'a Domain_name.t -> 'b Rr_map.key -> t -> t 63 | (** [remove_ty k ty t] removes [ty] from [t] at [k]. Beware, this may lead to a 64 | [t] where the initially mentioned invariants are violated. *) 65 | 66 | val remove_all : 'a Domain_name.t -> t -> t 67 | (** [remove_all k t] removes all entries of [k] in [t]. Beware, this may lead to 68 | a [t] where the initially mentioned invariants are violated. *) 69 | 70 | val remove_zone : 'a Domain_name.t -> t -> t 71 | (** [remove_zone name t] remove the zone [name] from [t], retaining subzones 72 | (entries with [Soa] records). This removes as well any delegations. *) 73 | 74 | 75 | (** {2 Checking invariants} *) 76 | 77 | type zone_check = [ `Missing_soa of [ `raw ] Domain_name.t 78 | | `Cname_other of [ `raw ] Domain_name.t 79 | | `Bad_ttl of [ `raw ] Domain_name.t * Rr_map.b 80 | | `Empty of [ `raw ] Domain_name.t * Rr_map.k 81 | | `Missing_address of [ `host ] Domain_name.t 82 | | `Soa_not_a_host of [ `raw ] Domain_name.t * string ] 83 | 84 | val pp_zone_check : zone_check Fmt.t 85 | (** [pp_err ppf err] pretty prints the error [err]. *) 86 | 87 | val check : t -> (unit, zone_check) result 88 | (** [check t] checks all invariants. *) 89 | 90 | 91 | (** {2 Lookup} *) 92 | 93 | type e = [ `Delegation of [ `raw ] Domain_name.t * (int32 * Domain_name.Host_set.t) 94 | | `EmptyNonTerminal of [ `raw ] Domain_name.t * Soa.t 95 | | `NotAuthoritative 96 | | `NotFound of [ `raw ] Domain_name.t * Soa.t ] 97 | (** The type of lookup errors. *) 98 | 99 | val pp_e : e Fmt.t 100 | (** [pp_e ppf e] pretty-prints [e] on [ppf]. *) 101 | 102 | val zone : 'a Domain_name.t -> t -> 103 | ([ `raw ] Domain_name.t * Soa.t, e) result 104 | (** [zone k t] returns either the zone and soa for [k] in [t], or an error. *) 105 | 106 | val lookup_with_cname : 'a Domain_name.t -> 'b Rr_map.key -> t -> 107 | (Rr_map.b * ([ `raw ] Domain_name.t * int32 * Domain_name.Host_set.t), e) result 108 | (** [lookup_with_cname k ty t] finds [k, ty] in [t]. It either returns the found 109 | resource record set and authority information, a cname alias and authority 110 | information, or an error. *) 111 | 112 | val lookup : 'a Domain_name.t -> 'b Rr_map.key -> t -> ('b, e) result 113 | (** [lookup k ty t] finds [k, ty] in [t], which may lead to an error. *) 114 | 115 | val lookup_any : 'a Domain_name.t -> t -> 116 | (Rr_map.t * ([ `raw ] Domain_name.t * int32 * Domain_name.Host_set.t), e) result 117 | (** [lookup_any k t] looks up all resource records of [k] in [t], and returns 118 | that and the authority information. *) 119 | 120 | val lookup_glue : 'a Domain_name.t -> t -> 121 | (int32 * Ipaddr.V4.Set.t) option * (int32 * Ipaddr.V6.Set.t) option 122 | (** [lookup_glue k t] finds glue records (A, AAAA) for [k] in [t]. It ignores 123 | potential DNS invariants, e.g. that there is no surrounding zone. *) 124 | 125 | val entries : 'a Domain_name.t -> t -> 126 | (Dns.Soa.t * Rr_map.t Domain_name.Map.t, e) result 127 | (** [entries name t] returns either the SOA and all entries for the requested 128 | [name], or an error. *) 129 | 130 | val fold : 'a Rr_map.key -> t -> ([ `raw ] Domain_name.t -> 'a -> 'b -> 'b) -> 'b -> 'b 131 | (** [fold key t f acc] calls [f] with [dname value acc] element in [t]. *) 132 | 133 | val diff : 'a Domain_name.t -> Soa.t -> old:t -> t -> 134 | (Soa.t * [ `Empty | `Full of Name_rr_map.t | `Difference of Soa.t * Name_rr_map.t * Name_rr_map.t ], 135 | [> `Msg of string ]) result 136 | (** [diff zone soa ~old trie] computes the difference of [zone] in [old] and 137 | [trie], and returns either [`Empty] if [soa] is equal or newer than the one 138 | in [trie], [`Full] (the same as [entries]) if [zone] is not present in [old], 139 | or [`Difference (old_soa, deleted, added)]. Best used with IXFR. An error 140 | occurs if [zone] is not present in [trie]. *) 141 | -------------------------------------------------------------------------------- /server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_server) 3 | (public_name dns-server) 4 | (wrapped false) 5 | (libraries dns randomconv duration metrics)) 6 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns) 3 | (public_name dns) 4 | (wrapped false) 5 | (libraries fmt ipaddr logs ptime gmap domain-name metrics base64 ohex) 6 | ; (preprocess (pps ppx_expect)) ; once https://github.com/ocaml/dune/issues/897 is resolved 7 | ; (inline_tests) 8 | ) 9 | -------------------------------------------------------------------------------- /test/cache.ml: -------------------------------------------------------------------------------- 1 | open Dns 2 | 3 | let ip = Ipaddr.V4.of_string_exn 4 | let name = Domain_name.of_string_exn 5 | 6 | let invalid_soa name = 7 | let p pre = 8 | Domain_name.(prepend_label_exn name "invalid" |> fun n -> prepend_label_exn n pre) 9 | in 10 | { 11 | Soa.nameserver = p "ns" ; hostmaster = p "hostmaster" ; 12 | serial = 1l ; refresh = 16384l ; retry = 2048l ; 13 | expiry = 1048576l ; minimum = 300l 14 | } 15 | 16 | let cached_err = 17 | let module M = struct 18 | type t = [ `Cache_miss | `Cache_drop ] 19 | let pp ppf = function 20 | | `Cache_miss -> Fmt.string ppf "cache miss" 21 | | `Cache_drop -> Fmt.string ppf "cache drop" 22 | let equal a b = match a, b with 23 | | `Cache_miss, `Cache_miss -> true 24 | | `Cache_drop, `Cache_drop -> true 25 | | _ -> false 26 | end in 27 | (module M: Alcotest.TESTABLE with type t = M.t) 28 | 29 | let entry_eq t a b = 30 | match a, b with 31 | | `Entry b, `Entry b' -> Rr_map.equal_rr t b b' 32 | | `No_data (name, soa), `No_data (name', soa') -> Domain_name.equal name name' && Dns.Soa.compare soa soa' = 0 33 | | `No_domain (name, soa), `No_domain (name', soa') -> Domain_name.equal name name' && Dns.Soa.compare soa soa' = 0 34 | | `Serv_fail (name, soa), `Serv_fail (name', soa') -> Domain_name.equal name name' && Dns.Soa.compare soa soa' = 0 35 | | _, _ -> false 36 | 37 | let cached_ok (t : 'a Rr_map.key) = 38 | let pp ppf res = Dns_cache.pp_entry t ppf (fst res) 39 | and equal (r, rank) (r', rank') = 40 | entry_eq t r r' && Dns_cache.compare_rank rank rank' = 0 41 | in 42 | Alcotest.testable pp equal 43 | 44 | let cached_r t = Alcotest.(result (cached_ok t) cached_err) 45 | 46 | let empty_cache () = 47 | let cache = Dns_cache.empty 100 in 48 | Alcotest.check (cached_r Rr_map.A) "empty cache results in Cache_miss" 49 | (Error `Cache_miss) 50 | (snd (Dns_cache.get cache 0L (name "an-actual-website.com") A)) 51 | 52 | let cache_a () = 53 | let cache = Dns_cache.empty 100 in 54 | let name = name "an-actual-website.com" in 55 | let a = 250l, Ipaddr.V4.Set.singleton (ip "1.2.3.4") in 56 | let cache = Dns_cache.set cache 0L name A (AuthoritativeAnswer None) (`Entry a) in 57 | Alcotest.check (cached_r Rr_map.A) "cache with A results in res" 58 | (Ok (`Entry a, AuthoritativeAnswer None)) 59 | (snd (Dns_cache.get cache 0L name A)) ; 60 | Alcotest.check (cached_r Rr_map.Cname) "cache with A results in CacheMiss" 61 | (Error `Cache_miss) (snd (Dns_cache.get cache 0L name Cname)) 62 | 63 | let cache_nodata () = 64 | let cache = Dns_cache.empty 100 in 65 | let name = name "an-alias.com" 66 | and subname = name "another-domain.an-alias.com" 67 | in 68 | let soa = invalid_soa name in 69 | let nodata = `No_data (subname, soa) in 70 | let a = 250l, Ipaddr.V4.Set.singleton (ip "1.2.3.4") in 71 | let cache = Dns_cache.set cache 0L name A (AuthoritativeAnswer None) (`Entry a) in 72 | let cache = Dns_cache.set cache 0L subname A (AuthoritativeAnswer None) nodata in 73 | Alcotest.check (cached_r Rr_map.A) "cache with A nodata results in nodata" 74 | (Ok (nodata, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L subname A)) ; 75 | Alcotest.check (cached_r Rr_map.Ns) "cache with A nodata results in cache miss for NS" 76 | (Error `Cache_miss) (snd (Dns_cache.get cache 0L subname Ns)) ; 77 | Alcotest.check (cached_r Rr_map.A) "cache with A nodata results in a record" 78 | (Ok (`Entry a, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L name A)) ; 79 | Alcotest.check (cached_r Rr_map.Ns) "cache with A nodata results in cache miss for NS'" 80 | (Error `Cache_miss) (snd (Dns_cache.get cache 0L name Ns)) ; 81 | let cache = Dns_cache.set cache 0L subname A (AuthoritativeAnswer None) (`Entry a) in 82 | Alcotest.check (cached_r Rr_map.A) "cache with A nodata results in nodata" 83 | (Ok (`Entry a, AuthoritativeAnswer None)) (snd (Dns_cache.get cache 0L subname A)) 84 | 85 | let cache_tests = [ 86 | "empty cache", `Quick, empty_cache ; 87 | "cache with A", `Quick, cache_a ; 88 | "cache nodata", `Quick, cache_nodata ; 89 | ] 90 | 91 | let entry_or_cname t a b = match a, b with 92 | | (`Alias (ttl, name), r), 93 | (`Alias (ttl', name'), r') -> 94 | ttl = ttl' && Domain_name.equal name name' && Dns_cache.compare_rank r r' = 0 95 | | (#Dns_cache.entry as e1, r1), (#Dns_cache.entry as e2, r2) -> 96 | entry_eq t e1 e2 && Dns_cache.compare_rank r1 r2 = 0 97 | | _ -> false 98 | 99 | let pp_or_cname t ppf = function 100 | | `Alias (ttl, name), _ -> Fmt.pf ppf "alias %lu %a" ttl Domain_name.pp name 101 | | #Dns_cache.entry as e, _ -> Dns_cache.pp_entry t ppf e 102 | 103 | let cname_or_cached t = 104 | Alcotest.testable (pp_or_cname t) (entry_or_cname t) 105 | 106 | let cached_cname_r t = Alcotest.result (cname_or_cached t) cached_err 107 | 108 | let empty = Dns_cache.empty 100 109 | 110 | let cname_empty_cache () = 111 | Alcotest.check (cached_cname_r Rr_map.A) "empty cache results in Cache_miss" 112 | (Error `Cache_miss) 113 | (snd (Dns_cache.get_or_cname empty 0L (name "foo.com") A)) 114 | 115 | let cname_cache_a () = 116 | let name = name "foo.com" in 117 | let a = 250l, Ipaddr.V4.Set.singleton (ip "1.2.3.4") in 118 | let cache = Dns_cache.set empty 0L name A (AuthoritativeAnswer None) (`Entry a) in 119 | Alcotest.check (cached_cname_r Rr_map.A) "cache with A results in res" 120 | (Ok (`Entry a, AuthoritativeAnswer None)) 121 | (snd (Dns_cache.get_or_cname cache 0L name A)) ; 122 | Alcotest.check (cached_cname_r Rr_map.Cname) "cache with A results in CacheMiss" 123 | (Error `Cache_miss) 124 | (snd (Dns_cache.get_or_cname cache 0L name Cname)) 125 | 126 | let cname_cache_cname () = 127 | let rel = name "bar.com" in 128 | let name = name "foo.com" in 129 | let cname = 250l, rel in 130 | let cache = Dns_cache.set empty 0L name Cname (AuthoritativeAnswer None) (`Entry cname) in 131 | Alcotest.check (cached_cname_r Rr_map.Cname) "cache with CNAME results in res" 132 | (Ok (`Alias cname, AuthoritativeAnswer None)) 133 | (snd (Dns_cache.get_or_cname cache 0L name Cname)) ; 134 | Alcotest.check (cached_cname_r Rr_map.A) "cache with CNAME results in res for A" 135 | (Ok (`Alias cname, AuthoritativeAnswer None)) 136 | (snd (Dns_cache.get_or_cname cache 0L name A)) ; 137 | Alcotest.check (cached_cname_r Rr_map.Ns) "cache with CNAME results in res for NS" 138 | (Ok (`Alias cname, AuthoritativeAnswer None)) 139 | (snd (Dns_cache.get_or_cname cache 0L name Ns)) 140 | 141 | let cname_cache_cname_nodata () = 142 | let rel = name "bar.com" in 143 | let name = name "foo.com" in 144 | let cname = 250l, rel in 145 | let bad_soa = invalid_soa name in 146 | let cache = 147 | Dns_cache.set 148 | (Dns_cache.set empty 0L name Cname (AuthoritativeAnswer None) (`Entry cname)) 149 | 0L name Ns (AuthoritativeAnswer None) (`No_data (name, bad_soa)) 150 | in 151 | Alcotest.check (cached_cname_r Rr_map.Cname) "cache with CNAME results in res" 152 | (Ok (`Alias cname, AuthoritativeAnswer None)) 153 | (snd (Dns_cache.get_or_cname cache 0L name Cname)) ; 154 | Alcotest.check (cached_cname_r Rr_map.Ns) "cache with CNAME results in res for NS" 155 | (Ok (`Alias cname, AuthoritativeAnswer None)) 156 | (snd (Dns_cache.get_or_cname cache 0L name Ns)) ; 157 | Alcotest.check (cached_cname_r Rr_map.A) "cache with CNAME results in res for A" 158 | (Ok (`Alias cname, AuthoritativeAnswer None)) 159 | (snd (Dns_cache.get_or_cname cache 0L name A)) 160 | 161 | let cname_cache_tests = [ 162 | "empty cache", `Quick, cname_empty_cache ; 163 | "cache with A", `Quick, cname_cache_a ; 164 | "cache with CNAME", `Quick, cname_cache_cname ; 165 | "cache with another cname", `Quick, cname_cache_cname_nodata ; 166 | ] 167 | 168 | let tests = [ 169 | "cache tests", cache_tests; 170 | "cname cache tests", cname_cache_tests; 171 | ] 172 | 173 | let () = Alcotest.run "DNS cache tests" tests 174 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name tests) 3 | (package dns) 4 | (libraries dns alcotest) 5 | (modules tests)) 6 | 7 | (test 8 | (name server) 9 | (package dns-server) 10 | (libraries base64 dns-server dns-server.zone dns-tsig alcotest mirage-crypto-rng.unix) 11 | (modules server)) 12 | 13 | (test 14 | (name tsig) 15 | (package dns-tsig) 16 | (libraries dns-tsig alcotest) 17 | (modules tsig)) 18 | 19 | (test 20 | (name resolver) 21 | (package dns-resolver) 22 | (libraries dns-resolver alcotest logs.fmt) 23 | (modules resolver)) 24 | 25 | (test 26 | (name client) 27 | (package dns-client) 28 | (libraries dns-client alcotest) 29 | (modules client)) 30 | 31 | (test 32 | (name cache) 33 | (package dns) 34 | (libraries dns.cache alcotest) 35 | (modules cache)) 36 | 37 | (test 38 | (name resolvconf) 39 | (package dns-client) 40 | (libraries dns-client.resolvconf ipaddr alcotest) 41 | (modules resolvconf)) 42 | 43 | (test 44 | (name test_dnssec) 45 | (package dnssec) 46 | (libraries dns dnssec mirage-crypto-pk base64 logs.fmt alcotest) 47 | (modules test_dnssec)) 48 | 49 | (test 50 | (name test_rfc9460) 51 | (package dns-server) 52 | (libraries dns-server dns-server.zone logs.fmt alcotest) 53 | (modules test_rfc9460)) 54 | -------------------------------------------------------------------------------- /test/resolvconf.ml: -------------------------------------------------------------------------------- 1 | 2 | let ok = 3 | let module M = struct 4 | type t = [ `Nameserver of Ipaddr.t ] list 5 | let pp = 6 | let pp_one ppf = function 7 | | `Nameserver ip -> Fmt.pf ppf "nameserver %a" Ipaddr.pp ip 8 | in 9 | Fmt.(list ~sep:(any "\n") pp_one) 10 | let equal a b = compare a b = 0 (* TODO polymorphic equality *) 11 | end in 12 | (module M: Alcotest.TESTABLE with type t = M.t) 13 | 14 | let err = 15 | let module M = struct 16 | type t = [ `Msg of string ] 17 | let pp ppf = function 18 | | `Msg m -> Fmt.string ppf m 19 | let equal _ _ = true 20 | end in 21 | (module M: Alcotest.TESTABLE with type t = M.t) 22 | 23 | let test_one test_name (data, expected) () = 24 | Alcotest.(check (result ok err) 25 | ("resolvconf " ^ test_name) expected (Dns_resolvconf.parse data)) 26 | 27 | let v4_ns = [ "8.8.8.8" ; "8.8.4.4" ] 28 | 29 | and v6_ns = [ "2001:4860:4860::8888" ; "2001:4860:4860::8844" ] 30 | 31 | let ok_result ns = 32 | Ok (List.map (fun s -> `Nameserver (Ipaddr.of_string_exn s)) ns) 33 | 34 | let linux = 35 | {| 36 | # Not all of these are supported by TRust-DNS 37 | # They are testing that they don't break parsing 38 | options ndots:8 timeout:8 attempts:8 39 | 40 | domain example.com 41 | search example.com sub.example.com 42 | 43 | nameserver 2001:4860:4860::8888 44 | nameserver 2001:4860:4860::8844 45 | nameserver 8.8.8.8 46 | nameserver 8.8.4.4 47 | 48 | # some options not supported by TRust-DNS 49 | options rotate 50 | options inet6 no-tld-query 51 | 52 | # A basic option not supported 53 | sortlist 130.155.160.0/255.255.240.0 130.155.0.0 54 | |} 55 | 56 | let macos = 57 | {| 58 | # 59 | # Mac OS X Notice 60 | # 61 | # This file is not used by the host name and address resolution 62 | # or the DNS query routing mechanisms used by most processes on 63 | # this Mac OS X system. 64 | # 65 | # This file is automatically generated. 66 | # 67 | options ndots:8 timeout:8 attempts:8 68 | domain example.com. 69 | search example.com. sub.example.com. 70 | nameserver 2001:4860:4860::8888 71 | nameserver 2001:4860:4860::8844 72 | nameserver 8.8.8.8 73 | nameserver 8.8.4.4 74 | |} 75 | 76 | let openbsd = 77 | {| 78 | # Generated by em0 dhclient 79 | nameserver 8.8.8.8 80 | nameserver 8.8.4.4 81 | lookup file bind 82 | |} 83 | 84 | let simple = 85 | {| 86 | nameserver 8.8.8.8 87 | nameserver 8.8.4.4 88 | |} 89 | 90 | let nixos = 91 | {| 92 | nameserver fe80::c2d7:aaff:fe96:8d82%wlp3s0 93 | |} 94 | 95 | let nixos2 = 96 | {| 97 | nameserver 8.8.8.8 98 | nameserver 8.8.4.4 99 | nameserver fe80::c2d7:aaff:fe96:8d82%wlp3s0 100 | nameserver 8.8.8.8 101 | nameserver 8.8.4.4 102 | |} 103 | 104 | let local_ns = [ "fe80::c2d7:aaff:fe96:8d82" ] 105 | 106 | let tests = [ 107 | "linux", `Quick, test_one "linux" (linux, ok_result (v6_ns @ v4_ns)) ; 108 | "macos", `Quick, test_one "macos" (macos, ok_result (v6_ns @ v4_ns)) ; 109 | "openbsd", `Quick, test_one "openbsd" (openbsd, ok_result v4_ns) ; 110 | "simple", `Quick, test_one "simple" (simple, ok_result v4_ns) ; 111 | "nixos", `Quick, test_one "nixos (with zone index)" 112 | (nixos, ok_result local_ns) ; 113 | "nixos 2", `Quick, test_one "nixos 2 (with zone index)" 114 | (nixos2, ok_result (v4_ns @ local_ns @ v4_ns)) ; 115 | ] 116 | 117 | let () = Alcotest.run "DNS resolvconf tests" [ "resolvconf tests", tests ] 118 | 119 | -------------------------------------------------------------------------------- /test/tsig.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017 Hannes Mehnert, all rights reserved *) 2 | 3 | let cs = 4 | let module M = struct 5 | type t = string 6 | let pp = Ohex.pp 7 | let equal = String.equal 8 | end in 9 | (module M: Alcotest.TESTABLE with type t = M.t) 10 | 11 | let msg = 12 | let module M = struct 13 | type t = [ `Msg of string ] 14 | let pp ppf = function `Msg str -> Fmt.string ppf str 15 | let equal _ _ = true 16 | end in 17 | (module M: Alcotest.TESTABLE with type t = M.t) 18 | 19 | let key = 20 | match Base64.decode "GSnQJ+fHuzwj5yKzCOkXdISyGQXBUxMrjEjL4Kr1WIs=" with 21 | | Error _ -> assert false 22 | | Ok x -> x 23 | 24 | let key_name = Domain_name.of_string_exn "mykey.bla.example" 25 | 26 | let of_h = Ohex.decode 27 | 28 | let tsig ?(fudge = 300) algorithm signed = 29 | let fudge = Ptime.Span.of_int_s fudge in 30 | let signed = 31 | match Ptime.of_float_s signed with 32 | | None -> assert false 33 | | Some x -> x 34 | in 35 | match Dns.Tsig.tsig ~algorithm ~signed ~fudge () with 36 | | None -> assert false 37 | | Some x -> x 38 | 39 | let example0 () = 40 | let buf = of_h {__|62 d7 28 00 00 01 00 00 00 02 00 00 07 65 78 61 41 | 6d 70 6c 65 03 63 6f 6d 00 00 06 00 01 03 66 6f 42 | 6f c0 0c 00 ff 00 ff 00 00 00 00 00 00 03 62 61 43 | 72 c0 0c 00 01 00 01 00 00 01 2c 00 04 01 02 03 44 | 04|__} 45 | and now = 1506887417. 46 | and mac = of_h {__|bf 5d 77 ba 97 ba 7b 95 9e 1b 0d 95 64 a7 5b a6 47 | 95 bf 24 15 3b 9d a2 1b bf 6f ae 61 9d 0f 28 a1|__} 48 | in 49 | Alcotest.(check cs "tsig is the same" mac 50 | (Dns_tsig.compute_tsig key_name (tsig Dns.Tsig.SHA256 now) ~key buf)) 51 | 52 | let example1 () = 53 | let buf = of_h {__|4c 56 28 00 00 01 00 00 00 01 00 00 07 45 78 41 54 | 6d 50 6c 45 03 63 6f 6d 00 00 06 00 01 03 66 6f 55 | 6f 07 65 78 61 6d 70 6c 65 c0 14 00 ff 00 ff 00 56 | 00 00 00 00 00|__} 57 | and now = 1506887742. 58 | and mac = of_h {__|70 67 ae 70 9e fd 22 9e ce d9 65 25 8a db 8c 96 59 | 10 95 80 89 a7 ee 4f bb 13 81 e7 38 e3 a0 78 80|__} 60 | in 61 | Alcotest.(check cs "tsig is the same" mac 62 | (Dns_tsig.compute_tsig key_name (tsig Dns.Tsig.SHA256 now) ~key buf)) 63 | 64 | let example2 () = 65 | let buf = of_h {__|76 8a 28 00 00 01 00 00 00 01 00 00 07 65 78 61 66 | 6d 70 6c 65 00 00 06 00 01 03 66 6f 6f c0 0c 00 67 | ff 00 ff 00 00 00 00 00 00|__} 68 | and now = 1506888104. 69 | and mac = of_h {__|e7 76 e6 df 4e 73 14 c8 eb ba 4c c7 a5 39 b3 93 70 | a7 df 6d de 47 b6 fa cc 81 c8 47 29 20 77 40 44|__} 71 | in 72 | Alcotest.(check cs "tsig is the same" mac 73 | (Dns_tsig.compute_tsig key_name (tsig Dns.Tsig.SHA256 now) ~key buf)) 74 | 75 | 76 | let tsig_tests = [ 77 | "example0", `Quick, example0 ; 78 | "example1", `Quick, example1 ; 79 | "example2", `Quick, example2 ; 80 | ] 81 | 82 | 83 | let tests = [ 84 | "Tsig example", tsig_tests ; 85 | ] 86 | 87 | let () = Alcotest.run "DNS name tests" tests 88 | -------------------------------------------------------------------------------- /tsig/dns_tsig.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | let src = Logs.Src.create "dns_tsig" ~doc:"DNS tsig" 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | let algorithm_to_nc = function 9 | | Tsig.SHA1 -> `SHA1 10 | | Tsig.SHA224 -> `SHA224 11 | | Tsig.SHA256 -> `SHA256 12 | | Tsig.SHA384 -> `SHA384 13 | | Tsig.SHA512 -> `SHA512 14 | 15 | let compute_tsig name tsig ~key buf = 16 | let raw_name = Domain_name.raw name in 17 | let h = (algorithm_to_nc tsig.Tsig.algorithm :> Digestif.hash') 18 | and data = Tsig.encode_raw raw_name tsig 19 | in 20 | let module H = (val (Digestif.module_of_hash' h)) in 21 | H.hmac_string ~key (buf ^ data) |> H.to_raw_string 22 | 23 | let ( let* ) = Result.bind 24 | 25 | let guard p err = if p then Ok () else Error err 26 | 27 | (* TODO: should name compression be done? atm it's convenient not to do it *) 28 | let add_tsig ?max_size name tsig str = 29 | let buf = Bytes.of_string str in 30 | Bytes.set_uint16_be buf 10 (succ (Bytes.get_uint16_be buf 10)) ; 31 | let tsig = Tsig.encode_full name tsig in 32 | match max_size with 33 | | Some x when x - Bytes.length buf < String.length tsig -> None 34 | | _ -> Some (Bytes.unsafe_to_string buf ^ tsig) 35 | 36 | let mac_to_prep = function 37 | | None -> "" 38 | | Some mac -> 39 | let l = Bytes.create 2 in 40 | Bytes.set_uint16_be l 0 (String.length mac) ; 41 | Bytes.unsafe_to_string l ^ mac 42 | 43 | let sign ?mac ?max_size name tsig ~key p str = 44 | match Base64.decode key.Dnskey.key with 45 | | Error _ -> None 46 | | Ok key -> 47 | let prep = mac_to_prep mac in 48 | let mac = compute_tsig name tsig ~key (prep ^ str) in 49 | let tsig = Tsig.with_mac tsig mac in 50 | (* RFC2845 Sec 3.1: if TSIG leads to truncation, alter message: 51 | - header stays (truncated = true)! 52 | - only question is preserved 53 | - _one_ additional, the TSIG itself *) 54 | match add_tsig ?max_size name tsig str with 55 | | Some out -> Some (out, mac) 56 | | None -> 57 | match p.Packet.data with 58 | | #Packet.request -> 59 | Log.err (fun m -> m "dns_tsig sign: truncated, is a request, not doing anything") ; 60 | None 61 | | #Packet.reply as r -> 62 | Log.err (fun m -> m "dns_tsig sign: truncated reply %a, sending tsig error" 63 | Packet.pp_reply r) ; 64 | let header = 65 | fst p.header, Packet.Flags.add `Truncation (snd p.header) 66 | in 67 | let rc = Packet.rcode_data r 68 | and op = Packet.opcode_data r 69 | in 70 | let p' = Packet.create header p.question (`Rcode_error (rc, op, None)) in 71 | let new_buf, off = Packet.encode `Udp p' in 72 | let tbs = String.sub new_buf 0 off in 73 | let mac = compute_tsig name tsig ~key (prep ^ tbs) in 74 | let tsig = Tsig.with_mac tsig mac in 75 | match add_tsig name tsig new_buf with 76 | | None -> 77 | Log.err (fun m -> m "dns_tsig sign failed query %a with tsig %a too big (max_size %a) truncated packet %a:@.%a" 78 | Packet.pp p Tsig.pp tsig Packet.pp p' 79 | Fmt.(option ~none:(any "none") int) max_size 80 | Ohex.pp new_buf) ; 81 | None 82 | | Some out -> Some (out, mac) 83 | 84 | let verify_raw ?mac now name ~key tsig tbs = 85 | let name = Domain_name.raw name in 86 | let* priv = 87 | Result.map_error 88 | (fun _ -> `Bad_key (name, tsig)) 89 | (Base64.decode key.Dnskey.key) 90 | in 91 | let ac = String.get_int16_be tbs 10 in 92 | let tbs = Bytes.of_string tbs in 93 | Bytes.set_int16_be tbs 10 (pred ac) ; 94 | let tbs = Bytes.unsafe_to_string tbs in 95 | let prep = mac_to_prep mac in 96 | let computed = compute_tsig name tsig ~key:priv (prep ^ tbs) in 97 | let mac = tsig.Tsig.mac in 98 | let* () = guard (String.length mac = String.length computed) (`Bad_truncation (name, tsig)) in 99 | let* () = guard (String.equal computed mac) (* Eqaf? *) (`Invalid_mac (name, tsig)) in 100 | let* () = guard (Tsig.valid_time now tsig) (`Bad_timestamp (name, tsig, key)) in 101 | let* tsig = 102 | Option.to_result ~none:(`Bad_timestamp (name, tsig, key)) 103 | (Tsig.with_signed tsig now) 104 | in 105 | Ok (tsig, mac) 106 | 107 | let verify ?mac now p name ?key tsig tbs = 108 | let raw_name = Domain_name.raw name in 109 | match 110 | let* key = 111 | Option.to_result ~none:(`Bad_key (raw_name, tsig)) key 112 | in 113 | let* tsig, mac = verify_raw ?mac now raw_name ~key tsig tbs in 114 | Ok (tsig, mac, key) 115 | with 116 | | Ok x -> Ok x 117 | | Error e -> 118 | Log.err (fun m -> m "error %a while verifying %a" Tsig_op.pp_e e Packet.pp p); 119 | let answer : string option = match p.Packet.data with 120 | | #Packet.reply -> None 121 | | #Packet.request as r -> 122 | (* now we prepare a reply for the request! *) 123 | (* TODO not clear which flags to preserve *) 124 | let header = fst p.Packet.header, Packet.Flags.empty 125 | and opcode = Packet.opcode_data r 126 | in 127 | (* TODO: edns *) 128 | let answer = Packet.create header p.question (`Rcode_error (Rcode.NotAuth, opcode, None)) in 129 | let err, max_size = Packet.encode `Udp answer in 130 | let or_err f err = match f err with None -> Some err | Some x -> Some x in 131 | match e with 132 | | `Bad_key (name, tsig) -> 133 | let tsig = Tsig.with_error (Tsig.with_mac tsig String.empty) Rcode.BadKey in 134 | or_err (add_tsig ~max_size name tsig) err 135 | | `Invalid_mac (name, tsig) -> 136 | let tsig = Tsig.with_error (Tsig.with_mac tsig String.empty) Rcode.BadVersOrSig in 137 | or_err (add_tsig ~max_size name tsig) err 138 | | `Bad_truncation (name, tsig) -> 139 | let tsig = Tsig.with_error (Tsig.with_mac tsig String.empty) Rcode.BadTrunc in 140 | or_err (add_tsig ~max_size name tsig) err 141 | | `Bad_timestamp (name, tsig, key) -> 142 | let tsig = Tsig.with_error tsig Rcode.BadTime in 143 | match Tsig.with_other tsig (Some now) with 144 | | None -> Some err 145 | | Some tsig -> 146 | match sign ~max_size ~mac:tsig.Tsig.mac name tsig ~key answer err with 147 | | None -> Some err 148 | | Some (buf, _) -> Some buf 149 | in 150 | Error (e, answer) 151 | 152 | type s = [ `Key_algorithm of Dnskey.t | `Tsig_creation | `Sign ] 153 | 154 | let pp_s ppf = function 155 | | `Key_algorithm key -> Fmt.pf ppf "algorithm %a not supported for tsig" Dnskey.pp key 156 | | `Tsig_creation -> Fmt.pf ppf "failed to create tsig" 157 | | `Sign -> Fmt.pf ppf "failed to sign" 158 | 159 | let encode_and_sign ?(proto = `Udp) ?mac p now key keyname = 160 | let b, _ = Packet.encode proto p in 161 | match Tsig.dnskey_to_tsig_algo key with 162 | | Error _ -> Error (`Key_algorithm key) 163 | | Ok algorithm -> match Tsig.tsig ~algorithm ~signed:now () with 164 | | None -> Error `Tsig_creation 165 | | Some tsig -> match sign ?mac (Domain_name.raw keyname) ~key tsig p b with 166 | | None -> Error `Sign 167 | | Some r -> Ok r 168 | 169 | type e = [ 170 | | `Decode of Packet.err 171 | | `Unsigned of Packet.t 172 | | `Crypto of Tsig_op.e 173 | | `Invalid_key of [ `raw ] Domain_name.t * [ `raw ] Domain_name.t 174 | ] 175 | 176 | let pp_e ppf = function 177 | | `Decode err -> Fmt.pf ppf "decode %a" Packet.pp_err err 178 | | `Unsigned res -> Fmt.pf ppf "unsigned %a" Packet.pp res 179 | | `Crypto c -> Fmt.pf ppf "crypto %a" Tsig_op.pp_e c 180 | | `Invalid_key (key, used) -> 181 | Fmt.pf ppf "invalid key, expected %a, but %a was used" 182 | Domain_name.pp key Domain_name.pp used 183 | 184 | let decode_and_verify now key keyname ?mac buf = 185 | let raw_keyname = Domain_name.raw keyname in 186 | match Packet.decode buf with 187 | | Error e -> Error (`Decode e) 188 | | Ok ({ Packet.tsig = None ; _ } as res) -> Error (`Unsigned res) 189 | | Ok ({ Packet.tsig = Some (name, tsig, tsig_off) ; _ } as res) when Domain_name.equal keyname name -> 190 | begin match verify_raw ?mac now raw_keyname ~key tsig (String.sub buf 0 tsig_off) with 191 | | Ok (_, mac) -> Ok (res, tsig, mac) 192 | | Error e -> Error (`Crypto e) 193 | end 194 | | Ok { Packet.tsig = Some (name, _, _) ; _ } -> Error (`Invalid_key (raw_keyname, name)) 195 | -------------------------------------------------------------------------------- /tsig/dns_tsig.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | (** DNS TSIG signatures *) 6 | 7 | (** As specified by {{:https://tools.ietf.org/html/rfc2845}RFC 2845} *) 8 | 9 | val sign : Tsig_op.sign 10 | (** [sign ~mac ~max_size name tsig ~key packet buffer] signs the given 11 | [buffer] with the provided [key], its [name], the [tsig]. The [mac] 12 | argument is expected when a reply to a signed DNS packet should be signed. 13 | If signing fails, an error may be produced. The result is a buffer and a 14 | mac. *) 15 | 16 | val verify : Tsig_op.verify 17 | (** [verify ~mac now packet name ~key tsig buffer] verifies the [buffer] 18 | using the provided [tsig], [key] and [name].*) 19 | 20 | type s = [ `Key_algorithm of Dnskey.t | `Tsig_creation | `Sign ] 21 | (** The type for signing errors. *) 22 | 23 | val pp_s : s Fmt.t 24 | (** [pp_s ppf s] pretty-prints [s] on [ppf]. *) 25 | 26 | val encode_and_sign : ?proto:proto -> ?mac:string -> Packet.t -> Ptime.t -> 27 | Dns.Dnskey.t -> 'a Domain_name.t -> (string * string, s) result 28 | (** [encode_and_sign ~proto ~mac t now dnskey name] signs and encodes the DNS 29 | packet. If a reply to a request is signed, the [mac] argument should be the 30 | message authentication code from the request (needed to sign the reply). 31 | The returned value is the encoded byte buffer and the mac of the packet 32 | (useful for passing into {!decode_and_verify} when receiving a reply to the 33 | signed request). *) 34 | 35 | type e = [ 36 | | `Decode of Packet.err 37 | | `Unsigned of Packet.t 38 | | `Crypto of Tsig_op.e 39 | | `Invalid_key of [ `raw ] Domain_name.t * [ `raw ] Domain_name.t 40 | ] 41 | (** The type for decode and verify errors. *) 42 | 43 | val pp_e : e Fmt.t 44 | (** [pp_e ppf e] prety-prints [e] on [ppf]. *) 45 | 46 | val decode_and_verify : Ptime.t -> Dnskey.t -> 'a Domain_name.t -> 47 | ?mac:string -> string -> 48 | (Packet.t * Tsig.t * string, e) result 49 | (** [decode_and_verify now dnskey name ~mac buffer] decodes and verifies the 50 | given buffer using the key material, resulting in a DNS packet, a signature, 51 | and the [mac], or a failure. The optional [mac] argument should be provided 52 | if an answer to a signed DNS packet is to be decoded. *) 53 | 54 | (**/**) 55 | val compute_tsig : 'a Domain_name.t -> Tsig.t -> key:string -> 56 | string -> string 57 | (** [compute_tsig name tsig ~key buffer] computes the mac over [buffer] 58 | and [tsig], using the provided [key] and [name]. *) 59 | -------------------------------------------------------------------------------- /tsig/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_tsig) 3 | (public_name dns-tsig) 4 | (wrapped false) 5 | (libraries dns digestif base64)) 6 | -------------------------------------------------------------------------------- /unix/client/dns_client_unix.ml: -------------------------------------------------------------------------------- 1 | (* {!Transport} provides the implementation of the underlying flow 2 | that is in turn used by {!Dns_client.Make} to provide the 3 | blocking Unix convenience module: 4 | *) 5 | 6 | module Transport : Dns_client.S 7 | with type io_addr = Ipaddr.t * int 8 | and type stack = unit 9 | and type +'a io = 'a 10 | = struct 11 | type io_addr = Ipaddr.t * int 12 | type stack = unit 13 | type nameservers = 14 | | Static of io_addr list 15 | | Resolv_conf of { 16 | mutable nameservers : io_addr list; 17 | mutable digest : Digest.t option 18 | } 19 | type t = { 20 | protocol : Dns.proto ; 21 | nameservers : nameservers ; 22 | timeout_ns : int64 ; 23 | } 24 | type context = { 25 | t : t ; 26 | fd : Unix.file_descr ; 27 | mutable timeout_ns : int64 28 | } 29 | type +'a io = 'a 30 | 31 | let read_file file = 32 | try 33 | let fh = open_in file in 34 | try 35 | let content = really_input_string fh (in_channel_length fh) in 36 | close_in_noerr fh ; 37 | Ok content 38 | with _ -> 39 | close_in_noerr fh; 40 | Error (`Msg ("Error reading file: " ^ file)) 41 | with _ -> Error (`Msg ("Error opening file " ^ file)) 42 | 43 | let decode_resolv_conf data = 44 | match Dns_resolvconf.parse data with 45 | | Ok [] -> Error (`Msg "empty nameservers from resolv.conf") 46 | | Ok ips -> Ok ips 47 | | Error _ as e -> e 48 | 49 | let default_resolvers () = [ Ipaddr.of_string_exn "1.1.1.1", 53 ] 50 | 51 | let maybe_resolv_conf t = 52 | match t.nameservers with 53 | | Static _ -> () 54 | | Resolv_conf resolv_conf -> 55 | let decode_update data dgst = 56 | match decode_resolv_conf data with 57 | | Ok ips -> 58 | resolv_conf.digest <- Some dgst; 59 | resolv_conf.nameservers <- List.map (function `Nameserver ip -> (ip, 53)) ips 60 | | Error _ -> 61 | resolv_conf.digest <- None; 62 | resolv_conf.nameservers <- default_resolvers () 63 | in 64 | match read_file "/etc/resolv.conf", resolv_conf.digest with 65 | | Ok data, Some d -> 66 | let digest = Digest.string data in 67 | if Digest.equal digest d then () else decode_update data digest 68 | | Ok data, None -> decode_update data (Digest.string data) 69 | | Error _, None -> () 70 | | Error _, Some _ -> 71 | resolv_conf.digest <- None; 72 | resolv_conf.nameservers <- default_resolvers () 73 | 74 | let create ?nameservers ~timeout () = 75 | let protocol, nameservers = 76 | match nameservers with 77 | | Some (proto, ns) -> (proto, Static ns) 78 | | None -> 79 | let ips, digest = 80 | match 81 | let ( let* ) = Result.bind in 82 | let* data = read_file "/etc/resolv.conf" in 83 | let* ips = decode_resolv_conf data in 84 | Ok (ips, Digest.string data) 85 | with 86 | | Error _ -> default_resolvers (), None 87 | | Ok (ips, digest) -> 88 | List.map (function `Nameserver ip -> (ip, 53)) ips, Some digest 89 | in 90 | (`Tcp, Resolv_conf { nameservers = ips; digest }) 91 | in 92 | { protocol ; nameservers ; timeout_ns = timeout } 93 | 94 | let nameservers { protocol ; nameservers = Static nameservers | Resolv_conf { nameservers; _ } ; _ } = 95 | protocol, nameservers 96 | let clock = Mtime_clock.elapsed_ns 97 | let rng = Mirage_crypto_rng.generate ?g:None 98 | 99 | let bind a b = b a 100 | let lift v = v 101 | 102 | let close { fd ; _ } = try Unix.close fd with _ -> () 103 | 104 | let with_timeout ctx f = 105 | let start = clock () in 106 | (* TODO cancel execution of f when time_left is 0 *) 107 | let r = f ctx.fd in 108 | let stop = clock () in 109 | ctx.timeout_ns <- Int64.sub (ctx.timeout_ns) (Int64.sub stop start); 110 | if ctx.timeout_ns <= 0L then 111 | Error (`Msg "DNS resolution timed out.") 112 | else 113 | r 114 | 115 | (* there is no connect timeouts, just a request timeout (unix: receive timeout) *) 116 | let connect t = 117 | maybe_resolv_conf t; 118 | match nameservers t with 119 | | _, [] -> Error (`Msg "empty nameserver list") 120 | | proto, (server, port) :: _ -> 121 | try 122 | Result.bind 123 | (match proto with 124 | | `Udp -> Ok Unix.((getprotobyname "udp").p_proto, SOCK_DGRAM) 125 | | `Tcp -> Ok Unix.((getprotobyname "tcp").p_proto, SOCK_STREAM)) 126 | (fun (proto_number, sock_typ) -> 127 | let fam = match server with Ipaddr.V4 _ -> Unix.PF_INET | Ipaddr.V6 _ -> Unix.PF_INET6 in 128 | let socket = Unix.socket fam sock_typ proto_number in 129 | let addr = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr server, port) in 130 | let ctx = { t ; fd = socket ; timeout_ns = t.timeout_ns } in 131 | try 132 | with_timeout ctx (fun fd -> 133 | Unix.connect fd addr; 134 | Ok (proto, ctx)) 135 | with e -> 136 | close ctx; 137 | Error (`Msg (Printexc.to_string e))) 138 | with e -> 139 | Error (`Msg (Printexc.to_string e)) 140 | 141 | let send_recv ctx (str : string) = 142 | try 143 | begin match 144 | with_timeout ctx (fun fd -> 145 | Unix.setsockopt_float fd Unix.SO_SNDTIMEO (Duration.to_f ctx.timeout_ns); 146 | let res = Unix.send_substring fd str 0 (String.length str) [] in 147 | if res <> String.length str then 148 | Error (`Msg ("Broken write to upstream NS" ^ (string_of_int res))) 149 | else 150 | Ok ()) 151 | with 152 | | Error _ as e -> e 153 | | Ok () -> 154 | let buffer = Bytes.make 2048 '\000' in 155 | with_timeout ctx (fun fd -> 156 | Unix.setsockopt_float fd Unix.SO_RCVTIMEO (Duration.to_f ctx.timeout_ns); 157 | let x = Unix.recv fd buffer 0 (Bytes.length buffer) [] in 158 | if x > 0 && x <= Bytes.length buffer then 159 | Ok (String.sub (Bytes.unsafe_to_string buffer) 0 x) 160 | else 161 | Error (`Msg "Reading from NS socket failed")) 162 | end 163 | with e -> 164 | Error (`Msg (Printexc.to_string e)) 165 | end 166 | 167 | (* Now that we have our {!Transport} implementation we can include the logic 168 | that goes on top of it: *) 169 | include Dns_client.Make(Transport) 170 | 171 | (* initialize the RNG *) 172 | let () = Mirage_crypto_rng_unix.use_default () 173 | -------------------------------------------------------------------------------- /unix/client/dns_client_unix.mli: -------------------------------------------------------------------------------- 1 | (** [Unix] helper module for {!Dns_client}. 2 | For more information see the {!Dns_client.Make} functor. 3 | 4 | It initializes the RNG (using 5 | [Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna)]). 6 | *) 7 | 8 | 9 | (** A flow module based on blocking I/O on top of the Unix socket API. 10 | 11 | TODO: Implement the connect timeout. 12 | *) 13 | module Transport : Dns_client.S 14 | with type io_addr = Ipaddr.t * int 15 | and type stack = unit 16 | and type +'a io = 'a 17 | 18 | include module type of Dns_client.Make(Transport) 19 | -------------------------------------------------------------------------------- /unix/client/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_client_unix) 3 | (modules dns_client_unix) 4 | (public_name dns-client.unix) 5 | (libraries domain-name ipaddr ipaddr.unix dns-client dns-client.resolvconf unix mtime.clock.os mirage-crypto-rng.unix) 6 | (wrapped false)) 7 | 8 | (executable 9 | (name ohost) 10 | (modules ohost) 11 | (package dns-client) 12 | (public_name dns-client.unix) 13 | (libraries fmt dns-client.unix mtime.clock.os)) 14 | -------------------------------------------------------------------------------- /unix/client/ohost.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Mirage_crypto_rng_unix.use_default (); 3 | let t = Dns_client_unix.create () in 4 | let domain = Domain_name.(host_exn (of_string_exn Sys.argv.(1))) in 5 | let ipv4 = 6 | match Dns_client_unix.gethostbyname t domain with 7 | | Ok addr -> Fmt.pr "%a has address %a\n" 8 | Domain_name.pp domain Ipaddr.V4.pp addr ; Ok () 9 | | Error _ as err -> err 10 | in 11 | let ipv6 = 12 | match Dns_client_unix.gethostbyname6 t domain with 13 | | Ok addr -> Fmt.pr "%a has IPv6 address %a\n" 14 | Domain_name.pp domain Ipaddr.V6.pp addr ; Ok () 15 | | Error _ as err -> err 16 | in 17 | let mx = 18 | match Dns_client_unix.getaddrinfo t Mx domain with 19 | | Ok (_ttl, resp) -> 20 | Fmt.pr "%a\n" 21 | (Fmt.list (fun ppf -> Fmt.pf ppf "%a mail is handled by %a" 22 | Domain_name.pp domain 23 | Dns.Mx.pp)) (Dns.Rr_map.Mx_set.elements resp) ; 24 | Ok () 25 | | Error _ as err -> err 26 | in 27 | let results = [ ipv4 ; ipv6 ; mx ] in 28 | let is_error = (function Error _ -> true | Ok _ -> false) in 29 | match List.find_opt is_error results with 30 | | None | Some Ok _ -> () (* no errors *) 31 | | Some (Error `Msg msg) -> (* at least one error *) 32 | if List.for_all is_error results then 33 | (* Everything failed; print an error message *) 34 | ( Fmt.epr "Host %a not found: @[%s@]\n" 35 | Domain_name.pp domain msg ; 36 | exit 1) 37 | -------------------------------------------------------------------------------- /zone/dns_zone.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2005-2006 Tim Deegan 3 | * Copyright (c) 2017 Hannes Mehnert 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | * dnsserver.ml -- an authoritative DNS server 18 | * 19 | *) 20 | 21 | let parse buf = 22 | Dns_zone_state.reset (); 23 | try 24 | let buf = 25 | if String.(get buf (pred (length buf))) = '\n' then buf else buf ^ "\n" 26 | in 27 | let lexbuf = Lexing.from_string buf in 28 | Ok (Dns_zone_parser.zfile Dns_zone_lexer.token lexbuf) 29 | with 30 | | Parsing.Parse_error -> Error (`Msg (Fmt.str "zone parse error at line %d" Dns_zone_state.(state.lineno))) 31 | | Dns_zone_state.Zone_parse_problem s -> Error (`Msg (Fmt.str "zone parse problem at line %d: %s" Dns_zone_state.(state.lineno) s)) 32 | | exn -> Error (`Msg (Printexc.to_string exn)) 33 | 34 | let src = Logs.Src.create "dns_zone" ~doc:"DNS zone parse" 35 | module Log = (val Logs.src_log src : Logs.LOG) 36 | 37 | let decode_zone trie zone data = 38 | match parse data with 39 | | Error `Msg msg -> 40 | Log.warn (fun m -> m "ignoring zone %a: %s (data %s)" 41 | Domain_name.pp zone msg data); 42 | trie, Dns.Name_rr_map.empty 43 | | Ok rrs -> 44 | (* we take all resource records within the zone *) 45 | (* TODO should we add RR one by one, and avoid to add RRs where we have 46 | delegations? (e.g. a NS ? ; a TXT foo <- the TXT should be discarded) *) 47 | let in_zone subdomain = Domain_name.is_subdomain ~domain:zone ~subdomain in 48 | let zone_rrs, other_rrs = 49 | Domain_name.Map.partition (fun name _ -> in_zone name) rrs 50 | in 51 | let trie' = Dns_trie.insert_map zone_rrs trie in 52 | match Dns_trie.lookup zone Dns.Rr_map.Soa trie', Dns_trie.check trie' with 53 | | Error _, _ -> 54 | Log.warn (fun m -> m "ignoring %a: no SOA" Domain_name.pp zone); 55 | trie, Dns.Name_rr_map.empty 56 | | _, Error ze -> 57 | Log.warn (fun m -> m "ignoring %a: zone check failed %a" 58 | Domain_name.pp zone Dns_trie.pp_zone_check ze); 59 | trie, Dns.Name_rr_map.empty 60 | | Ok _, Ok () -> trie', other_rrs 61 | 62 | let add_additional_glue trie (zone, other_rrs) = 63 | (* collect potential glue: 64 | - find NS entries for zone 65 | - find A and AAAA records for name servers in other rrs 66 | (Dns_trie.check ensures that the NS in zone have an address record) 67 | - only if the other names are not in zones, they are picked from 68 | this zone file *) 69 | match Dns_trie.lookup zone Dns.Rr_map.Ns trie with 70 | | Error _ -> 71 | Log.warn (fun m -> m "no NS entries for %a" Domain_name.pp zone); 72 | trie 73 | | Ok (_, name_servers) -> 74 | let not_authoritative nameserver = 75 | match Dns_trie.lookup nameserver Dns.Rr_map.A trie with 76 | | Error (`NotAuthoritative | `Delegation _) -> true 77 | | _ -> false 78 | in 79 | let need_glue = 80 | Domain_name.Host_set.filter not_authoritative name_servers 81 | in 82 | let raw_need_glue = 83 | Domain_name.Host_set.fold (fun ns acc -> 84 | Domain_name.Set.add (Domain_name.raw ns) acc) 85 | need_glue Domain_name.Set.empty 86 | in 87 | let trie = 88 | Domain_name.Host_set.fold (fun ns trie -> 89 | let dn = Domain_name.raw ns in 90 | match 91 | Dns.Name_rr_map.find dn Dns.Rr_map.A other_rrs, 92 | Dns.Name_rr_map.find dn Dns.Rr_map.Aaaa other_rrs 93 | with 94 | | Some v4, Some v6 -> 95 | let trie = Dns_trie.insert ns Dns.Rr_map.A v4 trie in 96 | Dns_trie.insert ns Dns.Rr_map.Aaaa v6 trie 97 | | Some v4, None -> Dns_trie.insert ns Dns.Rr_map.A v4 trie 98 | | None, Some v6 -> Dns_trie.insert ns Dns.Rr_map.Aaaa v6 trie 99 | | None, None -> 100 | Log.info (fun m -> m "unknown IP for NS %a (used in zone %a)" 101 | Domain_name.pp ns Domain_name.pp zone); 102 | trie) 103 | need_glue trie 104 | in 105 | Domain_name.Map.iter (fun name value -> 106 | let leftover = 107 | if Domain_name.Set.mem name raw_need_glue then 108 | Dns.Rr_map.remove A (Dns.Rr_map.remove Aaaa value) 109 | else 110 | value 111 | in 112 | if Dns.Rr_map.is_empty leftover then 113 | () 114 | else begin 115 | Log.warn (fun m -> m "ignoring %d entries in zone file %a" 116 | (Dns.Rr_map.cardinal leftover) Domain_name.pp zone); 117 | Dns.Rr_map.iter (fun b -> 118 | Log.warn (fun m -> m "%s" (Dns.Rr_map.text_b name b))) 119 | leftover 120 | end) 121 | other_rrs; 122 | trie 123 | 124 | let decode_keys zone keys = 125 | match parse keys with 126 | | Error `Msg msg -> 127 | Log.warn (fun m -> m "ignoring keys for %a: %s (data: %s)" 128 | Domain_name.pp zone msg keys); 129 | Domain_name.Map.empty 130 | | Ok rrs -> 131 | let tst subdomain = Domain_name.is_subdomain ~domain:zone ~subdomain in 132 | Domain_name.Map.fold (fun n data acc -> 133 | if not (tst n) then begin 134 | Log.warn (fun m -> m "ignoring key %a (not in zone %a)" 135 | Domain_name.pp n Domain_name.pp zone); 136 | acc 137 | end else 138 | match Dns.Rr_map.(find Dnskey data) with 139 | | None -> 140 | Log.warn (fun m -> m "no dnskey found %a" Domain_name.pp n); 141 | acc 142 | | Some (_, keys) -> 143 | match Dns.Rr_map.Dnskey_set.elements keys with 144 | | [ x ] -> Domain_name.Map.add n x acc 145 | | xs -> 146 | Log.warn (fun m -> m "ignoring %d dnskeys for %a (only one supported)" 147 | (List.length xs) Domain_name.pp n); 148 | acc) 149 | rrs Domain_name.Map.empty 150 | 151 | let decode_zones bindings = 152 | let trie, zones, glue = 153 | List.fold_left (fun (trie, zones, glues) (name, data) -> 154 | match Domain_name.of_string name with 155 | | Error `Msg msg -> 156 | Log.warn (fun m -> m "ignoring %s, not a domain name %s" name msg); 157 | trie, zones, glues 158 | | Ok name -> 159 | let trie, glue = decode_zone trie name data in 160 | trie, Domain_name.Set.add name zones, (name, glue) :: glues) 161 | (Dns_trie.empty, Domain_name.Set.empty, []) 162 | bindings 163 | in 164 | let trie = List.fold_left add_additional_glue trie glue in 165 | zones, trie 166 | 167 | let decode_zones_keys bindings = 168 | let key_domain = Domain_name.of_string_exn "_keys" in 169 | let trie, keys, zones, glue = 170 | List.fold_left (fun (trie, keys, zones, glues) (name, data) -> 171 | match Domain_name.of_string name with 172 | | Error `Msg msg -> 173 | Log.warn (fun m -> m "ignoring %s, not a domain name %s" name msg); 174 | trie, keys, zones, glues 175 | | Ok name -> 176 | if Domain_name.is_subdomain ~domain:key_domain ~subdomain:name then 177 | let domain = Domain_name.drop_label_exn ~rev:true name in 178 | let keys' = decode_keys domain data in 179 | let f key a _b = 180 | Log.warn (fun m -> m "encountered key %a also in %a" 181 | Domain_name.pp key Domain_name.pp domain); 182 | Some a 183 | in 184 | trie, Domain_name.Map.union f keys keys', zones, glues 185 | else 186 | let trie, glue = decode_zone trie name data in 187 | trie, keys, Domain_name.Set.add name zones, (name, glue) :: glues) 188 | (Dns_trie.empty, Domain_name.Map.empty, Domain_name.Set.empty, []) 189 | bindings 190 | in 191 | let trie = List.fold_left add_additional_glue trie glue in 192 | zones, trie, Domain_name.Map.bindings keys 193 | -------------------------------------------------------------------------------- /zone/dns_zone.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2005-2006 Tim Deegan 3 | * Copyright (c) 2017 Hannes Mehnert 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | *) 18 | 19 | val parse : string -> (Dns.Name_rr_map.t, [> `Msg of string ]) result 20 | (** [parse data] attempts to parse the [data], given in [zone file format]. 21 | It either returns the content as a map, or an error. *) 22 | 23 | val decode_keys : 'a Domain_name.t -> string -> Dns.Dnskey.t Domain_name.Map.t 24 | (** [decode_keys zone data] decodes DNSKEY in [data], and ensure that all are 25 | within [zone]. Errors are logged via the logs library. *) 26 | 27 | val decode_zones : (string * string) list -> Domain_name.Set.t * Dns_trie.t 28 | (** [decode_zones (name, data)] parses the zones [data] with the names 29 | [name], and constructs a trie that has been checked for consistency. 30 | The set of zones are returned, together with the constructed trie. 31 | Errors and inconsistencies are logged via the logs library, and the 32 | respective zone data is ignored. *) 33 | 34 | val decode_zones_keys : (string * string) list -> 35 | Domain_name.Set.t * Dns_trie.t * ([`raw] Domain_name.t * Dns.Dnskey.t) list 36 | (** [decode_zones_keys (name, data)] is [decode_zones], but also if a [name] 37 | ends with "_keys", the Dnskey records are decoded (using [decode_keys] and 38 | are added to the last part of the return value. *) 39 | -------------------------------------------------------------------------------- /zone/dns_zone_lexer.mll: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2006 Tim Deegan 3 | * Copyright (c) 2010-12 Anil Madhavapeddy 4 | * Copyright (c) 2017, 2018 Hannes Mehnert 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | * 18 | * dnslexer.mll -- ocamllex lexer for DNS "Master zone file" format 19 | * 20 | * DNS master zonefile format is defined in RFC 1035, section 5. 21 | * Escapes and octets are clarified in RFC 4343 22 | *) 23 | 24 | { 25 | 26 | open Dns_zone_state 27 | open Dns_zone_parser 28 | open Lexing 29 | 30 | (* Disambiguate keywords and generic character strings -- when updating this, 31 | please ensure to update the keyword_or_number rule in dns_zone_parser.mly 32 | and add it to the testuite in test/server.ml *) 33 | let kw_or_cs s = match (String.uppercase_ascii s) with 34 | "A" -> TYPE_A s 35 | | "NS" -> TYPE_NS s 36 | | "CNAME" -> TYPE_CNAME s 37 | | "SOA" -> TYPE_SOA s 38 | | "PTR" -> TYPE_PTR s 39 | | "MX" -> TYPE_MX s 40 | | "TXT" -> TYPE_TXT s 41 | | "AAAA" -> TYPE_AAAA s 42 | | "SRV" -> TYPE_SRV s 43 | | "SVCB" -> TYPE_SVCB s 44 | | "HTTPS" -> TYPE_HTTPS s 45 | | "DNSKEY" -> TYPE_DNSKEY s 46 | | "CAA" -> TYPE_CAA s 47 | | "TLSA" -> TYPE_TLSA s 48 | | "SSHFP" -> TYPE_SSHFP s 49 | | "DS" -> TYPE_DS s 50 | | "LOC" -> TYPE_LOC s 51 | | "IN" -> CLASS_IN s 52 | | "CS" -> CLASS_CS s 53 | | "CH" -> CLASS_CH s 54 | | "HS" -> CLASS_HS s 55 | | "N" -> LAT_DIR s 56 | | "S" -> LAT_DIR s 57 | | "E" -> LONG_DIR s 58 | | "W" -> LONG_DIR s 59 | | _ -> CHARSTRING s 60 | 61 | (* Scan an accepted token for linebreaks *) 62 | let count_linebreaks s = 63 | String.iter (function '\n' -> state.lineno <- state.lineno + 1 | _ -> ()) s 64 | 65 | } 66 | 67 | let eol = [' ''\t']* (';' [^'\n']*)? '\n' 68 | let octet = '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] 69 | let escape = '\\' _ (* Strictly \0 is not an escape, but be liberal *) 70 | let qstring = '"' ((([^'\\''"']|octet|escape)*) as contents) '"' 71 | let label = (([^'\\'' ''\t''\n''.''('')']|octet|escape)*) as contents 72 | let number = (['0'-'9']+) as contents 73 | let neg_number = ('-' ['0'-'9']+) as contents 74 | let meters = ('-'? ['0'-'9']+ ('.' ['0'-'9']? ['0'-'9']?)? as contents) 'm' 75 | let openpar = [' ''\t']* '(' ([' ''\t''\n'] | eol)* 76 | let closepar = (eol | [' ''\t''\n'])* ')' [' ''\t']* 77 | let typefoo = (['T''t']['Y''y']['P''p']['E''e'] number) as contents 78 | 79 | (* Rfc9460 Appendix A *) 80 | let svcb_non_special = '!' | ['#'-'\''] | ['*'-':'] | ['<'-'['] | [']'-'~'] 81 | let svcb_non_digit = ['!'-'/'] | [':'-'~'] 82 | let svcb_dec_octet = (('0' | '1') ['0'-'9'] ['0'-'9']) | ('2' ((['0'-'4'] ['0'-'9']) ('5' ['0'-'5']))) 83 | let svcb_escaped = '\\' (svcb_non_digit | svcb_dec_octet) 84 | let svcb_contigious = (svcb_non_special | svcb_escaped)+ 85 | let svcb_quoted = '"' (svcb_contigious | (['\\']? ' ')) '"' 86 | let svcb_char_string = svcb_contigious | svcb_quoted 87 | 88 | (* Rfc9460 2.1 *) 89 | let svcbkey = (['a'-'z']|['0'-'9']|'-')* 90 | let svcbval = svcb_char_string 91 | let svcbvalq = '"' svcbval '"' 92 | let svcbparam = (svcbkey '=' (svcbval | svcbvalq)) as contents 93 | 94 | rule token = parse 95 | eol { state.lineno <- state.lineno + 1; 96 | if state.paren > 0 then SPACE else EOL } 97 | | openpar { state.paren <- state.paren + 1; 98 | count_linebreaks (lexeme lexbuf); SPACE } 99 | | closepar { if state.paren > 0 then state.paren <- state.paren - 1; 100 | count_linebreaks (lexeme lexbuf); SPACE } 101 | | closepar eol { if state.paren > 0 then state.paren <- state.paren - 1; 102 | count_linebreaks (lexeme lexbuf); EOL } 103 | | "\\#" { GENERIC } 104 | | "$ORIGIN" { SORIGIN } 105 | | "$TTL" { STTL } 106 | | '.' { DOT } 107 | | '@' { AT } 108 | | number { NUMBER contents } 109 | | neg_number { NEG_NUMBER contents } 110 | | meters { METERS contents } 111 | | typefoo { TYPE_GENERIC contents } 112 | | qstring { count_linebreaks contents; CHARSTRING contents } 113 | | svcbparam { count_linebreaks contents; SVCBPARAM contents } 114 | | label { count_linebreaks contents; kw_or_cs contents } 115 | | [' ''\t']+ { SPACE } 116 | | eof { EOF } 117 | -------------------------------------------------------------------------------- /zone/dns_zone_state.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2005-2006 Tim Deegan 3 | * Copyright (c) 2017 Hannes Mehnert 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | * dnsloader.ml -- how to build up a DNS trie from separate RRs 18 | * 19 | *) 20 | 21 | (* State variables for the parser & lexer *) 22 | type parserstate = { 23 | mutable paren : int ; 24 | mutable lineno : int ; 25 | mutable origin : [ `raw ] Domain_name.t ; 26 | mutable ttl : int32 ; 27 | mutable owner : [ `raw ] Domain_name.t ; 28 | mutable zone : Dns.Name_rr_map.t ; 29 | } 30 | 31 | let state = { 32 | paren = 0 ; 33 | lineno = 1 ; 34 | ttl = Int32.of_int 3600 ; 35 | origin = Domain_name.root ; 36 | owner = Domain_name.root ; 37 | zone = Domain_name.Map.empty ; 38 | } 39 | 40 | let reset () = 41 | state.paren <- 0 ; 42 | state.lineno <- 1 ; 43 | state.ttl <- Int32.of_int 3600 ; 44 | state.origin <- Domain_name.root ; 45 | state.owner <- Domain_name.root ; 46 | state.zone <- Dns.Name_rr_map.empty 47 | 48 | exception Zone_parse_problem of string 49 | 50 | -------------------------------------------------------------------------------- /zone/dns_zone_state.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2005-2006 Tim Deegan 3 | * Copyright (c) 2017 Hannes Mehnert 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | *) 18 | 19 | type parserstate = { 20 | mutable paren : int; 21 | mutable lineno : int; 22 | mutable origin : [ `raw ] Domain_name.t; 23 | mutable ttl : int32; 24 | mutable owner : [ `raw ] Domain_name.t; 25 | mutable zone : Dns.Name_rr_map.t ; 26 | } 27 | 28 | val state : parserstate 29 | 30 | val reset : unit -> unit 31 | 32 | exception Zone_parse_problem of string 33 | -------------------------------------------------------------------------------- /zone/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_zone) 3 | (public_name dns-server.zone) 4 | (private_modules dns_zone_state dns_zone_parser dns_zone_lexer) 5 | (libraries dns dns-server logs) 6 | (wrapped false)) 7 | 8 | (ocamlyacc dns_zone_parser) 9 | (ocamllex dns_zone_lexer) 10 | --------------------------------------------------------------------------------