├── CHANGES.md ├── dune-project ├── .gitignore ├── tsig ├── dune ├── dns_tsig.mli └── dns_tsig.ml ├── mirage ├── client │ ├── dune │ ├── dns_mirage_client.mli │ └── dns_mirage_client.ml ├── dune ├── server │ ├── dune │ ├── dns_mirage_server.mli │ └── dns_mirage_server.ml ├── certify │ ├── dune │ ├── dns_mirage_certify.mli │ └── dns_mirage_certify.ml ├── resolver │ ├── dune │ ├── dns_mirage_resolver.mli │ └── dns_mirage_resolver.ml ├── dns_mirage.mli └── dns_mirage.ml ├── server ├── dune ├── dns_server.mli ├── dns_trie.mli └── dns_trie.ml ├── lwt └── client │ ├── dune │ ├── dns_client_lwt.mli │ └── dns_client_lwt.ml ├── certify ├── dune ├── dns_certify.mli └── dns_certify.ml ├── client ├── dune ├── dns_client.mli ├── dns_client_flow.ml ├── dns_client.ml └── dns_client_flow.mli ├── resolver ├── dune ├── dns_resolver_utils.mli ├── dns_resolver_root.mli ├── dns_resolver.mli ├── dns_resolver_cache.mli ├── dns_resolver_root.ml └── dns_resolver_utils.ml ├── zone ├── dune ├── dns_zone.mli ├── dns_zone_state.mli ├── dns_zone.ml ├── dns_zone_state.ml ├── dns_zone_lexer.mll └── dns_zone_parser.mly ├── src └── dune ├── unix └── client │ ├── dune │ ├── dns_client_unix.mli │ ├── ohost.ml │ └── dns_client_unix.ml ├── test ├── dune └── tsig.ml ├── dns-client-lwt.opam ├── dns-mirage-client.opam ├── dns-zone.opam ├── dns-client.opam ├── dns-tsig.opam ├── dns-client-unix.opam ├── dns-server.opam ├── dns-resolver.opam ├── dns-certify.opam ├── dns-mirage-resolver.opam ├── dns-mirage-server.opam ├── dns-mirage-certify.opam ├── app ├── dune ├── ozone.ml ├── dns_cli.ml ├── oupdate.ml ├── onotify.ml ├── ocertify.ml └── odns.ml ├── LICENSE.md ├── dns-cli.opam ├── .travis.yml ├── dns-mirage.opam ├── dns.opam └── README.md /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### v0.1.0 (now) 2 | 3 | * Initial release -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.2) 2 | (name dns) 3 | (using menhir 2.0) 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.install 3 | .merlin 4 | 5 | *pcap 6 | *out 7 | coverage/ 8 | *req 9 | *key 10 | *private 11 | *pem 12 | -------------------------------------------------------------------------------- /tsig/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_tsig) 3 | (synopsis "A Domain Name system (DNS) library, TSIG (HMAC) part") 4 | (public_name dns-tsig) 5 | (wrapped false) 6 | (libraries dns nocrypto)) 7 | -------------------------------------------------------------------------------- /mirage/client/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_mirage_client) 3 | (public_name dns-mirage-client) 4 | (libraries domain-name ipaddr mirage-stack-lwt dns-client) 5 | (wrapped false) 6 | ) -------------------------------------------------------------------------------- /server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_server) 3 | (synopsis "A Domain Name system (DNS) server library") 4 | (public_name dns-server) 5 | (wrapped false) 6 | (libraries dns randomconv duration)) 7 | -------------------------------------------------------------------------------- /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) 6 | (wrapped false)) 7 | -------------------------------------------------------------------------------- /mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_mirage) 3 | (synopsis "A Domain Name system (DNS) library, MirageOS integration") 4 | (public_name dns-mirage) 5 | (wrapped false) 6 | (libraries dns mirage-stack-lwt ipaddr lwt)) 7 | -------------------------------------------------------------------------------- /certify/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_certify) 3 | (synopsis "A Domain Name system (DNS) library, certificate integration") 4 | (public_name dns-certify) 5 | (wrapped false) 6 | (libraries dns dns-tsig x509 randomconv)) 7 | -------------------------------------------------------------------------------- /client/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_client) 3 | (public_name dns-client) 4 | (modules dns_client dns_client_flow) 5 | (libraries domain-name mirage-flow dns randomconv rresult) 6 | (wrapped false)) 7 | -------------------------------------------------------------------------------- /resolver/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_resolver) 3 | (synopsis "A tiny Domain Name system (DNS) library, resolver part") 4 | (public_name dns-resolver) 5 | (wrapped false) 6 | (libraries dns dns-server lru duration randomconv)) 7 | -------------------------------------------------------------------------------- /mirage/server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_mirage_server) 3 | (synopsis "A Domain Name system (DNS) library, MirageOS server integration") 4 | (public_name dns-mirage-server) 5 | (wrapped false) 6 | (libraries dns dns-server dns-mirage lwt duration randomconv mirage-time-lwt mirage-clock-lwt mirage-stack-lwt)) 7 | -------------------------------------------------------------------------------- /mirage/certify/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_mirage_certify) 3 | (synopsis "A Domain Name system (DNS) library, MirageOS let's encrypt integration") 4 | (public_name dns-mirage-certify) 5 | (wrapped false) 6 | (libraries dns dns-mirage dns-certify tls lwt duration mirage-random mirage-time-lwt mirage-clock-lwt mirage-stack-lwt)) 7 | -------------------------------------------------------------------------------- /mirage/resolver/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_mirage_resolver) 3 | (synopsis "A Domain Name system (DNS) library, MirageOS resolver integration") 4 | (public_name dns-mirage-resolver) 5 | (wrapped false) 6 | (libraries dns dns-resolver dns-server dns-mirage lwt duration mirage-time-lwt mirage-clock-lwt mirage-stack-lwt mirage-random)) 7 | -------------------------------------------------------------------------------- /zone/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_zone) 3 | (synopsis "A tiny Domain Name system (DNS) library, zone format parser") 4 | (public_name dns-zone) 5 | (private_modules dns_zone_state dns_zone_parser dns_zone_lexer) 6 | (libraries dns) 7 | (wrapped false)) 8 | 9 | (ocamlyacc dns_zone_parser) 10 | (ocamllex dns_zone_lexer) 11 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns) 3 | (synopsis "A tiny Domain Name system (DNS) library") 4 | (public_name dns) 5 | (wrapped false) 6 | (libraries rresult cstruct astring fmt ipaddr logs ptime gmap domain-name) 7 | ; (preprocess (pps ppx_expect)) ; once https://github.com/ocaml/dune/issues/897 is resolved 8 | ; (inline_tests) 9 | ) 10 | -------------------------------------------------------------------------------- /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 dns-client rresult unix) 6 | (wrapped false) 7 | ) 8 | 9 | (executable 10 | (name ohost) 11 | (modules ohost) 12 | (package dns-client-unix) 13 | (public_name dns-client-unix) 14 | (libraries fmt dns-client-unix) 15 | ) 16 | -------------------------------------------------------------------------------- /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 dns-server alcotest nocrypto.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) 23 | (modules resolver)) 24 | -------------------------------------------------------------------------------- /unix/client/dns_client_unix.mli: -------------------------------------------------------------------------------- 1 | (** [Unix] helper module for {!Dns_client}. 2 | For more information see the {!Dns_client_flow.Make} functor. 3 | *) 4 | 5 | 6 | (** A flow module based on blocking I/O on top of the Unix socket API. *) 7 | module Uflow : Dns_client_flow.S 8 | with type flow = Unix.file_descr 9 | and type io_addr = Unix.inet_addr * int 10 | and type stack = unit 11 | and type (+'a,+'b) io = ('a,'b) result 12 | 13 | include module type of Dns_client_flow.Make(Uflow) 14 | -------------------------------------------------------------------------------- /lwt/client/dns_client_lwt.mli: -------------------------------------------------------------------------------- 1 | (** {!Lwt_unix} helper module for {!Dns_client}. 2 | For more information see the {!Dns_client_flow.Make} functor. 3 | *) 4 | 5 | 6 | (** A flow module based on non-blocking I/O on top of the 7 | Lwt_unix socket API. *) 8 | module Uflow : Dns_client_flow.S 9 | with type flow = Lwt_unix.file_descr 10 | and type io_addr = Lwt_unix.inet_addr * int 11 | and type (+'a,+'b) io = ('a,'b) Lwt_result.t 12 | and type stack = unit 13 | 14 | include module type of Dns_client_flow.Make(Uflow) 15 | -------------------------------------------------------------------------------- /mirage/client/dns_mirage_client.mli: -------------------------------------------------------------------------------- 1 | 2 | module Make (S : Mirage_stack_lwt.V4) : sig 3 | module Uflow : Dns_client_flow.S 4 | with type flow = S.TCPV4.flow 5 | and type io_addr = Ipaddr.V4.t * int 6 | and type (+'a, +'b) io = ('a, 'b) Lwt_result.t 7 | and type stack = S.t 8 | 9 | include module type of Dns_client_flow.Make(Uflow) 10 | end 11 | 12 | (* 13 | type dns_ty 14 | 15 | val config : dns_ty Mirage.impl 16 | (** [config] is the *) 17 | 18 | module Make : 19 | functor (Time:Mirage_time_lwt.S) -> 20 | functor (IPv4:Mirage_stack_lwt.V4) -> 21 | S 22 | 23 | *) 24 | -------------------------------------------------------------------------------- /mirage/resolver/dns_mirage_resolver.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | module Make (R : Mirage_random.C) (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (T : Mirage_time_lwt.S) (S : Mirage_stack_lwt.V4) : sig 4 | 5 | val resolver : S.t -> ?root:bool -> ?timer:int -> ?port:int -> Dns_resolver.t -> unit 6 | (** [resolver stack ~root ~timer ~port resolver] registers a caching resolver 7 | on the provided [port] (both udp and tcp) using the [resolver] 8 | configuration. The [timer] is in milliseconds and defaults to 500 9 | milliseconds.*) 10 | end 11 | -------------------------------------------------------------------------------- /dns-client-lwt.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Joe Hill"] 4 | homepage: "https://github.com/roburio/udns" 5 | bug-reports: "https://github.com/roburio/udns/issues" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | license: "BSD2" 8 | 9 | build: [ 10 | [ "dune" "subst"] {pinned} 11 | [ "dune" "build" "-p" name "-j" jobs ] 12 | ] 13 | 14 | depends: [ 15 | "dune" {build & >="1.5.1"} 16 | "ocaml" { >= "4.07.0"} 17 | "lwt" 18 | "dns" {= version} 19 | "dns-client" {= version} 20 | ] 21 | synopsis: "DNS client library, using lwt for IO" 22 | description: """ 23 | A DNS client library providing resolve that uses lwt for IO. 24 | """ 25 | -------------------------------------------------------------------------------- /resolver/dns_resolver_utils.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | val scrub : ?mode:[ `Recursive | `Stub ] -> [ `raw ] Domain_name.t -> Packet.Question.qtype -> Packet.t -> 6 | ((Rr_map.k * [ `raw ] Domain_name.t * Dns_resolver_cache.rank * Dns_resolver_cache.res) list, 7 | Rcode.t) result 8 | (** [scrub ~mode bailiwick packet] returns a list of entries to-be-added to the 9 | cache. This respects only in-bailiwick resources records, and qualifies the 10 | [packet]. The purpose is to avoid cache poisoning by not accepting all 11 | resource records. *) 12 | 13 | val invalid_soa : [ `raw ] Domain_name.t -> Soa.t (** [invalid_soa name] returns a stub 14 | SOA for [name]. *) 15 | -------------------------------------------------------------------------------- /dns-mirage-client.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | homepage: "https://github.com/roburio/udns" 4 | bug-reports: "https://github.com/roburio/udns/issues" 5 | dev-repo: "git+https://github.com/roburio/udns.git" 6 | license: "BSD2" 7 | authors: [ "Hannes Mehnert" ] 8 | tags: "org:mirage" 9 | 10 | build: [ 11 | ["dune" "subst"] {pinned} 12 | ["dune" "build" "-p" name "-j" jobs] 13 | ] 14 | 15 | depends: [ 16 | "dune" { build & >= "1.5.1"} 17 | "ocaml" {>= "4.07.0" } 18 | "domain-name" {>= "0.2.0"} 19 | "ipaddr" {>= "3.0.0"} 20 | "mirage-stack-lwt" 21 | "dns-client" {= version} 22 | ] 23 | synopsis: "DNS client library for MirageOS" 24 | description: """ 25 | A DNS client library for MirageOS. Based on uDNS. 26 | """ 27 | -------------------------------------------------------------------------------- /dns-zone.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | ] 15 | 16 | build: [ 17 | ["dune" "subst"] {pinned} 18 | ["dune" "build" "-p" name "-j" jobs] 19 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 20 | ] 21 | 22 | synopsis: "Zonefile parser for uDNS" 23 | description: """ 24 | An ocamllex and ocamlyacc based zonefile parser to be used with udns. 25 | """ 26 | -------------------------------------------------------------------------------- /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) list 6 | (** [root_servers] are the root servers. *) 7 | 8 | val ns_records : Rr_map.b 9 | (** [ns_records] is the root nameserver binding. *) 10 | 11 | val a_records : ([ `raw ] Domain_name.t * Rr_map.b) list 12 | (** [a_records] is a list of names and bindings (A records) for the root 13 | servers. *) 14 | 15 | val reserved_zones : ([ `raw ] Domain_name.t * Rr_map.b) list 16 | (** [reserved_zones] is a list of names and bindings for reserved zones 17 | specified by RFCs (private network address ranges, private domains) *) 18 | 19 | val reserved : Dns_trie.t 20 | (** [reserved] is a trie with all [reserved_zones]. *) 21 | -------------------------------------------------------------------------------- /dns-client.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Joe Hill"] 4 | homepage: "https://github.com/roburio/udns" 5 | bug-reports: "https://github.com/roburio/udns-client/issues" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | license: "BSD2" 8 | 9 | build: [ 10 | [ "dune" "subst"] {pinned} 11 | [ "dune" "build" "-p" name "-j" jobs ] 12 | ] 13 | 14 | depends: [ 15 | "dune" {build & >="1.5.1"} 16 | "ocaml" {>= "4.07.0"} 17 | "cstruct" {>= "3.1.1"} 18 | "fmt" {>= "0.8.4"} 19 | "logs" {>= "0.6.2"} 20 | "dns" {= version} 21 | "rresult" {>= "0.6.0"} 22 | "mirage-flow" 23 | "randomconv" 24 | "domain-name" {>= "0.2.0"} 25 | ] 26 | synopsis: "Pure DNS resolver API" 27 | description: """ 28 | A pure resolver implementation using uDNS. 29 | """ 30 | -------------------------------------------------------------------------------- /dns-tsig.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & > "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | "nocrypto" 15 | "alcotest" {with-test} 16 | ] 17 | 18 | build: [ 19 | ["dune" "subst"] {pinned} 20 | ["dune" "build" "-p" name "-j" jobs] 21 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 22 | ] 23 | 24 | synopsis: "TSIG support for DNS" 25 | description: """ 26 | TSIG is used to authenticate nsupdate frames using a HMAC. 27 | """ 28 | -------------------------------------------------------------------------------- /dns-client-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Joe Hill"] 4 | homepage: "https://github.com/roburio/udns" 5 | bug-reports: "https://github.com/roburio/udns/issues" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | license: "BSD2" 8 | 9 | build: [ 10 | [ "dune" "subst"] {pinned} 11 | [ "dune" "build" "-p" name "-j" jobs ] 12 | ] 13 | 14 | depends: [ 15 | "dune" {build & >="1.5.1"} 16 | "ocaml" {>= "4.07.0"} 17 | "domain-name" {>= "0.2.0"} 18 | "fmt" {>= "0.8.4"} 19 | "ipaddr" {>= "3.0.0"} 20 | "dns-client" {= version} 21 | "fmt" {>= "0.8.4"} 22 | "rresult" {>= "0.6.0"} 23 | ] 24 | synopsis: "Unix DNS resolver, providing resolve" 25 | description: """ 26 | An effectful layer for udns-client, that uses the Unix module from OCaml stdlib. 27 | """ 28 | -------------------------------------------------------------------------------- /dns-server.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | "randomconv" 15 | "duration" 16 | "alcotest" {with-test} 17 | "nocrypto" {with-test} 18 | ] 19 | 20 | build: [ 21 | ["dune" "subst"] {pinned} 22 | ["dune" "build" "-p" name "-j" jobs] 23 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 24 | ] 25 | 26 | synopsis: "DNS server, primary and secondary" 27 | description: """ 28 | Primary and secondary DNS server implemented in value-passing style. Needs an 29 | effectful layer to be useful. 30 | """ 31 | -------------------------------------------------------------------------------- /dns-resolver.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | "dns-server" {= version} 15 | "lru" {>= "0.3.0"} 16 | "duration" 17 | "randomconv" 18 | "alcotest" {with-test} 19 | ] 20 | 21 | build: [ 22 | ["dune" "subst"] {pinned} 23 | ["dune" "build" "-p" name "-j" jobs] 24 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 25 | ] 26 | 27 | synopsis: "DNS resolver business logic" 28 | description: """ 29 | Forwarding and recursive resolvers as value-passing functions. To be used with 30 | an effectful layer. 31 | """ 32 | -------------------------------------------------------------------------------- /dns-certify.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | "dns-tsig" {= version} 15 | "randomconv" 16 | "duration" 17 | "x509" 18 | ] 19 | 20 | build: [ 21 | ["dune" "subst"] {pinned} 22 | ["dune" "build" "-p" name "-j" jobs] 23 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 24 | ] 25 | 26 | synopsis: "MirageOS let's encrypt certificate retrieval" 27 | description: """ 28 | A function to retrieve a certificate when providing a hostname, TSIG key, server 29 | IP, and an optional key seed. Best used with an letsencrypt unikernel. 30 | """ 31 | -------------------------------------------------------------------------------- /dns-mirage-resolver.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | "dns-mirage" {= version} 15 | "dns-server" {= version} 16 | "dns-resolver" {= version} 17 | "mirage-time-lwt" 18 | "mirage-clock-lwt" 19 | "mirage-random" 20 | "lwt" 21 | "randomconv" 22 | "duration" 23 | "mirage-stack-lwt" 24 | ] 25 | 26 | build: [ 27 | ["dune" "subst"] {pinned} 28 | ["dune" "build" "-p" name "-j" jobs] 29 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 30 | ] 31 | 32 | synopsis: "DNS caching resolver for MirageOS" 33 | description: """ 34 | A caching DNS resolver for MirageOS. 35 | """ 36 | -------------------------------------------------------------------------------- /dns-mirage-server.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | "dns-mirage" {= version} 15 | "dns-server" {= version} 16 | "mirage-time-lwt" 17 | "mirage-clock-lwt" {>= "2.0.0"} 18 | "lwt" 19 | "randomconv" 20 | "duration" 21 | "mirage-stack-lwt" 22 | ] 23 | 24 | build: [ 25 | ["dune" "subst"] {pinned} 26 | ["dune" "build" "-p" name "-j" jobs] 27 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 28 | ] 29 | 30 | synopsis: "Primary and secondary DNS server for MirageOS using uDNS" 31 | description: """ 32 | Convenience functions for registering TCP and UDP listeners acting as primary 33 | or seconday DNS server. 34 | """ 35 | -------------------------------------------------------------------------------- /dns-mirage-certify.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | "dns-mirage" {= version} 15 | "dns-certify" {= version} 16 | "mirage-random" 17 | "mirage-time-lwt" 18 | "mirage-clock-lwt" {>= "2.0.0"} 19 | "lwt" 20 | "duration" 21 | "tls" 22 | "mirage-stack-lwt" 23 | ] 24 | 25 | build: [ 26 | ["dune" "subst"] {pinned} 27 | ["dune" "build" "-p" name "-j" jobs] 28 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 29 | ] 30 | 31 | synopsis: "MirageOS let's encrypt certificate retrieval" 32 | description: """ 33 | A function to retrieve a certificate when providing a hostname, TSIG key, server 34 | IP, and an optional key seed. Best used with an letsencrypt unikernel. 35 | """ 36 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /mirage/server/dns_mirage_server.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (T : Mirage_time_lwt.S) (S : Mirage_stack_lwt.V4) : sig 4 | 5 | val primary : ?on_update:(old:Dns_trie.t -> Dns_server.Primary.s -> unit Lwt.t) -> 6 | ?on_notify:([ `Notify of Dns.Soa.t option | `Signed_notify of Dns.Soa.t option ] -> Dns_server.Primary.s -> Dns_trie.t option Lwt.t) -> 7 | ?timer:int -> ?port:int -> S.t -> Dns_server.Primary.s -> unit 8 | (** [primary ~on_update ~timer ~port stack primary] starts a primary server on [port] 9 | (default 53, both TCP and UDP) with the given [primary] configuration. [timer] is the 10 | DNS notify timer in seconds, and defaults to 2 seconds. *) 11 | 12 | val secondary : 13 | ?on_update:(old:Dns_trie.t -> Dns_server.Secondary.s -> unit Lwt.t) -> 14 | ?timer:int -> ?port:int -> S.t -> Dns_server.Secondary.s -> 15 | unit 16 | (** [secondary ~on_update ~timer ~port stack secondary] starts a secondary 17 | server on [port] (default 53). The [on_update] callback is executed when 18 | the zone changes. The [timer] (in seconds, defaults to 5 seconds) is used 19 | for refreshing zones. *) 20 | end 21 | -------------------------------------------------------------------------------- /app/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dns_cli) 3 | (synopsis "A Domain Name system (DNS) library, unix applications") 4 | (public_name dns-cli) 5 | (wrapped false) 6 | (modules dns_cli) 7 | (libraries dns cmdliner ptime.clock.os logs.fmt fmt.cli logs.cli fmt.tty ipaddr.unix)) 8 | 9 | (executable 10 | (name ocertify) 11 | (public_name ocertify) 12 | (package dns-cli) 13 | (modules ocertify) 14 | (libraries dns dns-certify dns-cli bos fpath x509 ptime ptime.clock.os nocrypto nocrypto.unix)) 15 | 16 | (executable 17 | (name oupdate) 18 | (public_name oupdate) 19 | (package dns-cli) 20 | (modules oupdate) 21 | (libraries dns dns-tsig dns-cli ptime ptime.clock.os nocrypto nocrypto.unix)) 22 | 23 | (executable 24 | (name onotify) 25 | (public_name onotify) 26 | (package dns-cli) 27 | (modules onotify) 28 | (libraries dns dns-tsig dns-cli ptime ptime.clock.os nocrypto nocrypto.unix)) 29 | 30 | (executable 31 | (name ozone) 32 | (public_name ozone) 33 | (package dns-cli) 34 | (modules ozone) 35 | (libraries dns dns-cli dns-zone dns-server bos rresult)) 36 | 37 | (executable 38 | (name odns) 39 | (public_name odns) 40 | (modules odns) 41 | (package dns-cli) 42 | (libraries dns dns-client-lwt dns-cli cmdliner lwt.unix hex rresult)) -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /mirage/certify/dns_mirage_certify.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | module Make (R : Mirage_random.C) (P : Mirage_clock_lwt.PCLOCK) (T : Mirage_time_lwt.S) (S : Mirage_stack_lwt.V4) : sig 3 | 4 | val retrieve_certificate : 5 | ?ca:[ `Production | `Staging ] -> 6 | S.t -> dns_key:string -> hostname:[ `host ] Domain_name.t -> 7 | ?additional_hostnames:[` host ] Domain_name.t list -> ?key_seed:string -> 8 | S.TCPV4.ipaddr -> int -> (Tls.Config.own_cert, [ `Msg of string ]) result Lwt.t 9 | (** [retrieve_certificate ~ca stack ~dns_key ~hostname ~key_seed server_ip port] 10 | generates a RSA private key (using the [key_seed]), a certificate 11 | signing request for the given [hostname] and [additional_hostnames], and 12 | sends [server_ip] an nsupdate (DNS-TSIG with [dns_key]) with the csr as 13 | TLSA record, awaiting for a matching certificate as TLSA record. Requires a 14 | service that interacts with let's encrypt to transform the CSR into a 15 | signed certificate. If something fails, an exception (via [Lwt.fail]) is 16 | raised. This is meant for unikernels that require a valid TLS certificate 17 | before they can start their service (i.e. most web servers, mail 18 | servers). Has let's encrypt certificates (expiry March 2021) hardcoded. *) 19 | end 20 | -------------------------------------------------------------------------------- /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 : ?size:int -> ?mode:[ `Recursive | `Stub ] -> int64 -> 7 | (int -> Cstruct.t) -> Dns_server.Primary.s -> t 8 | (** [create ~size ~mode now rng primary] creates the value of a resolver, 9 | pre-filled with root NS and their IP addresses. *) 10 | 11 | val handle_buf : t -> Ptime.t -> int64 -> bool -> Dns.proto -> Ipaddr.V4.t -> 12 | int -> Cstruct.t -> 13 | t * (Dns.proto * Ipaddr.V4.t * int * Cstruct.t) list 14 | * (Dns.proto * Ipaddr.V4.t * Cstruct.t) list 15 | (** [handle_buf t now ts query_or_reply proto sender source-port buf] handles 16 | resolution of [buf], which my involve further outgoing and reply packets. *) 17 | 18 | val query_root : t -> int64 -> Dns.proto -> 19 | t * (Dns.proto * Ipaddr.V4.t * Cstruct.t) 20 | (** [query_root t now proto] potentially requests an update of the root 21 | zone. Best invoked by a regular timer. *) 22 | 23 | val timer : t -> int64 -> 24 | t * (Dns.proto * Ipaddr.V4.t * int * Cstruct.t) list 25 | * (Dns.proto * Ipaddr.V4.t * Cstruct.t) list 26 | (** [timer t now] potentially retransmits DNS requests and/or sends NXDomain 27 | answers. *) 28 | 29 | val stats : t -> unit 30 | (** [stats t] logs some statistics of the cache. *) 31 | -------------------------------------------------------------------------------- /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. -------------------------------------------------------------------------------- /dns-cli.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | "dns-tsig" {= version} 15 | "dns-client-lwt" {= version} 16 | "dns-zone" {= version} 17 | "dns-server" {= version} 18 | "dns-certify" {= version} 19 | "rresult" 20 | "bos" 21 | "cmdliner" {>= "1.0.0"} 22 | "fpath" 23 | "x509" 24 | "nocrypto" 25 | "hex" 26 | "ptime" 27 | "logs" 28 | "fmt" 29 | "ipaddr" {>= "3.0.0"} 30 | "alcotest" {with-test} 31 | ] 32 | 33 | build: [ 34 | ["dune" "subst"] {pinned} 35 | ["dune" "build" "-p" name "-j" jobs] 36 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 37 | ] 38 | 39 | synopsis: "Unix command line utilities using uDNS" 40 | description: """ 41 | 'oupdate' sends a DNS update frome to a DNS server that sets 'hostname A ip'. 42 | For authentication via TSIG, a hmac secret needs to be provided. 43 | 44 | 'ocertify' updates DNS with a certificate signing request, and polls a matching 45 | certificate. Best used with an letsencrypt unikernel. 46 | """ 47 | -------------------------------------------------------------------------------- /mirage/dns_mirage.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | module Make (S : Mirage_stack_lwt.V4) : sig 4 | 5 | module IS : Set.S with type elt = Ipaddr.V4.t 6 | (** [IS] is a set of [ipaddr]. *) 7 | 8 | module IM : sig 9 | include Map.S with type key = Ipaddr.V4.t 10 | val find : Ipaddr.V4.t -> 'a t -> 'a option 11 | end 12 | (** [IM] is a map using [ipaddr] as key. *) 13 | 14 | module IPM : sig 15 | include Map.S with type key = Ipaddr.V4.t * int 16 | val find : Ipaddr.V4.t * int -> 'a t -> 'a option 17 | end 18 | (** [IPM] is a map using [ip * port] as key. *) 19 | 20 | type f 21 | (** A 2byte-length per message flow abstraction, the embedding of DNS frames 22 | via TCP. *) 23 | 24 | val of_flow : S.TCPV4.flow -> f 25 | (** [of_flow flow] is [f]. *) 26 | 27 | val flow : f -> S.TCPV4.flow 28 | (** [flow f] is the underlying flow. *) 29 | 30 | val read_tcp : f -> (Cstruct.t, unit) result Lwt.t 31 | (** [read_tcp f] returns either a buffer or an error (logs actual error). *) 32 | 33 | val send_tcp : S.TCPV4.flow -> Cstruct.t -> (unit, unit) result Lwt.t 34 | (** [send_tcp flow buf] sends the buffer, either succeeds or fails (logs 35 | actual error). *) 36 | 37 | val send_udp : S.t -> int -> Ipaddr.V4.t -> int -> Cstruct.t -> unit Lwt.t 38 | (** [send_udp stack source_port dst dst_port buf] sends the [buf] as UDP 39 | packet to [dst] on [dst_port]. *) 40 | end 41 | -------------------------------------------------------------------------------- /unix/client/ohost.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let t = Dns_client_unix.create () in 3 | let domain = Domain_name.(host_exn (of_string_exn Sys.argv.(1))) in 4 | let ipv4 = 5 | match Dns_client_unix.gethostbyname t domain with 6 | | Ok addr -> Fmt.pr "%a has address %a\n" 7 | Domain_name.pp domain Ipaddr.V4.pp addr ; Ok () 8 | | Error _ as err -> err 9 | in 10 | let ipv6 = 11 | match Dns_client_unix.gethostbyname6 t domain with 12 | | Ok addr -> Fmt.pr "%a has IPv6 address %a\n" 13 | Domain_name.pp domain Ipaddr.V6.pp addr ; Ok () 14 | | Error _ as err -> err 15 | in 16 | let mx = 17 | match Dns_client_unix.getaddrinfo t Mx domain with 18 | | Ok (_ttl, resp) -> 19 | Fmt.pr "%a\n" 20 | (Fmt.list (fun ppf -> Fmt.pf ppf "%a mail is handled by %a" 21 | Domain_name.pp domain 22 | Dns.Mx.pp)) (Dns.Rr_map.Mx_set.elements resp) ; 23 | Ok () 24 | | Error _ as err -> err 25 | in 26 | let results = [ ipv4 ; ipv6 ; mx ] in 27 | let is_error = (function Error _ -> true | Ok _ -> false) in 28 | match List.find_opt is_error results with 29 | | None | Some Ok _ -> () (* no errors *) 30 | | Some (Error `Msg msg) -> (* at least one error *) 31 | if List.for_all is_error results then 32 | (* Everything failed; print an error message *) 33 | ( Fmt.epr "Host %a not found: @[%s@]\n" 34 | Domain_name.pp domain msg ; 35 | exit 1) 36 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | sudo: false 7 | env: 8 | global: 9 | - PINS="dns.dev:. dns-certify.dev:. dns-client.dev:. dns-client-lwt.dev:. dns-mirage-client.dev:. dns-client-unix.dev:. dns-resolver.dev:. dns-server.dev:. dns-tsig.dev:. dns-zone.dev:. dns-cli.dev:. dns-mirage.dev:. dns-mirage-resolver.dev:. dns-mirage-server.dev:. dns-mirage-certify.dev:." 10 | matrix: 11 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns" 12 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-zone" 13 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-resolver" 14 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-mirage" 15 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-mirage-resolver" 16 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-mirage-server" 17 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-certify" 18 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-client" 19 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-server" 20 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-client-lwt" 21 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-tsig" 22 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-mirage-certify" 23 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-cli" 24 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-client-unix" 25 | - DISTRO=alpine OCAML_VERSION=4.07 PACKAGE="dns-mirage-client" 26 | notifications: 27 | email: false 28 | -------------------------------------------------------------------------------- /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 | (* TODO end-of-file handling? insert a newline at the end before lexing? *) 25 | let lexbuf = Lexing.from_string buf in 26 | Ok (Dns_zone_parser.zfile Dns_zone_lexer.token lexbuf) 27 | with 28 | | Parsing.Parse_error -> Error (`Msg (Fmt.strf "zone parse error at line %d" Dns_zone_state.(state.lineno))) 29 | | Dns_zone_state.Zone_parse_problem s -> Error (`Msg (Fmt.strf "zone parse problem at line %d: %s" Dns_zone_state.(state.lineno) s)) 30 | | exn -> Error (`Msg (Printexc.to_string exn)) 31 | -------------------------------------------------------------------------------- /dns-mirage.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "dns" {= version} 14 | "ipaddr" 15 | "lwt" 16 | "mirage-stack-lwt" 17 | ] 18 | 19 | build: [ 20 | ["dune" "subst"] {pinned} 21 | ["dune" "build" "-p" name "-j" jobs] 22 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 23 | ] 24 | 25 | synopsis: "An opinionated Domain Name System (DNS) library" 26 | description: """ 27 | µDNS supports most of the domain name system used in the wild. It adheres to 28 | strict conventions. Failing early and hard. It is mostly implemented in the 29 | pure fragment of OCaml (no mutation, isolated IO, no exceptions). 30 | 31 | Legacy resource record types are not dealt with, and there is no plan to support 32 | `ISDN`, `MAILA`, `MAILB`, `WKS`, `MB`, `NULL`, `HINFO`, ... . `AXFR` is only 33 | handled via TCP connections. The only resource class supported is `IN` (the 34 | Internet). In a similar vein, wildcard records are _not_ supported, and it is 35 | unlikely they'll ever be in this library. Truncated hmac in `TSIG` are not 36 | supported (always the full length of the hash algorithm is used). 37 | 38 | Please read [the blog article](https://hannes.nqsb.io/Posts/DNS) for a more 39 | detailed overview. 40 | """ 41 | -------------------------------------------------------------------------------- /dns.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "team AT robur dot io" 3 | authors: ["Hannes Mehnert "] 4 | homepage: "https://github.com/roburio/udns" 5 | doc: "https://roburio.github.io/udns/doc" 6 | dev-repo: "git+https://github.com/roburio/udns.git" 7 | bug-reports: "https://github.com/roburio/udns/issues" 8 | license: "BSD2" 9 | 10 | depends: [ 11 | "dune" {build & >= "1.2.0"} 12 | "ocaml" {>= "4.07.0"} 13 | "rresult" "astring" "fmt" "logs" "ptime" 14 | "domain-name" {>= "0.2.0"} 15 | "gmap" {>= "0.3.0"} 16 | "cstruct" {>= "3.2.0"} 17 | "ipaddr" {>= "3.0.0"} 18 | "ppx_expect" 19 | "alcotest" {with-test} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {pinned} 23 | ["dune" "build" "-p" name "-j" jobs] 24 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 25 | ] 26 | 27 | synopsis: "An opinionated Domain Name System (DNS) library" 28 | description: """ 29 | µDNS supports most of the domain name system used in the wild. It adheres to 30 | strict conventions. Failing early and hard. It is mostly implemented in the 31 | pure fragment of OCaml (no mutation, isolated IO, no exceptions). 32 | 33 | Legacy resource record types are not dealt with, and there is no plan to support 34 | `ISDN`, `MAILA`, `MAILB`, `WKS`, `MB`, `NULL`, `HINFO`, ... . `AXFR` is only 35 | handled via TCP connections. The only resource class supported is `IN` (the 36 | Internet). In a similar vein, wildcard records are _not_ supported, and it is 37 | unlikely they'll ever be in this library. Truncated hmac in `TSIG` are not 38 | supported (always the full length of the hash algorithm is used). 39 | 40 | Please read [the blog article](https://hannes.nqsb.io/Posts/DNS) for a more 41 | detailed overview. 42 | """ 43 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /tsig/dns_tsig.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | (** DNS TSIG signatures *) 6 | 7 | val sign : Tsig_op.sign 8 | (** [sign ~mac ~max_size name tsig ~key packet buffer] signs the given 9 | [buffer] with the provided [key], its [name], the [tsig]. If signing 10 | fails, an error may be produced. The result is a buffer and a mac. *) 11 | 12 | val verify : Tsig_op.verify 13 | (** [verify ~mac now packet name ~key tsig buffer] verifies the [buffer] 14 | using the provided [tsig], [key] and [name].*) 15 | 16 | type s = [ `Key_algorithm of Dnskey.t | `Tsig_creation | `Sign ] 17 | (** The type for signing errors. *) 18 | 19 | val pp_s : s Fmt.t 20 | (** [pp_s ppf s] pretty-prints [s] on [ppf]. *) 21 | 22 | val encode_and_sign : ?proto:proto -> Packet.t -> Ptime.t -> Dns.Dnskey.t -> 23 | 'a Domain_name.t -> (Cstruct.t * Cstruct.t, s) result 24 | (** [encode_and_sign ~proto t now dnskey name] signs and encodes the DNS 25 | packet. *) 26 | 27 | type e = [ 28 | | `Decode of Packet.err 29 | | `Unsigned of Packet.t 30 | | `Crypto of Tsig_op.e 31 | | `Invalid_key of [ `raw ] Domain_name.t * [ `raw ] Domain_name.t 32 | ] 33 | (** The type for decode and verify errors. *) 34 | 35 | val pp_e : e Fmt.t 36 | (** [pp_e ppf e] prety-prints [e] on [ppf]. *) 37 | 38 | val decode_and_verify : Ptime.t -> Dnskey.t -> 'a Domain_name.t -> 39 | ?mac:Cstruct.t -> Cstruct.t -> 40 | (Packet.t * Tsig.t * Cstruct.t, e) result 41 | (** [decode_and_verify now dnskey name ~mac buffer] decodes and verifies the 42 | given buffer using the key material, resulting in a DNS packet and the mac, 43 | or a failure. *) 44 | 45 | (**/**) 46 | val compute_tsig : 'a Domain_name.t -> Tsig.t -> key:Cstruct.t -> 47 | Cstruct.t -> Cstruct.t 48 | (** [compute_tsig name tsig ~key buffer] computes the mac over [buffer] 49 | and [tsig], using the provided [key] and [name]. *) 50 | -------------------------------------------------------------------------------- /client/dns_client.mli: -------------------------------------------------------------------------------- 1 | (** The pure interface to the client part of uDns. 2 | 3 | Various helper modules to do with side effects are available from 4 | {!Dns_client_lwt}, {!Dns_client_unix} and so forth. 5 | 6 | To learn more about the high-level API, I suggest reading the docstrings 7 | of {!Dns_client_flow}. 8 | *) 9 | 10 | type 'key query_state constraint 'key = 'a Dns.Rr_map.key 11 | (** [query_state] is parameterized over the query type, so the type of 12 | the representation of the answer depends on what the name server 13 | was asked to provide. See {!Dns_map.k} for a list of response types. 14 | The first element (the [int32]) in most of the tuples is the 15 | Time-To-Live (TTL) field returned from the server, which you can use to 16 | calculate when you should request fresh information in case you are writing 17 | a long-running application. 18 | *) 19 | 20 | val make_query : 21 | Dns.proto -> 'a Domain_name.t -> 22 | 'query_type Dns.Rr_map.key -> 23 | Cstruct.t * 'query_type Dns.Rr_map.key query_state 24 | (** [make_query protocol name query_type] is [query, query_state] 25 | where [query] is the serialized DNS query to send to the name server, 26 | and [query_state] is the information required to validate the response. 27 | 28 | NB: When querying for [TLSA] records, it is important to use the optional 29 | [~hostname:false] parameter with the conversion functions within {!Domain_name} 30 | when constructing the {!Domain_name.t} for the search, since these contain 31 | labels prefixed with underscores. 32 | *) 33 | 34 | val parse_response : 'query_type Dns.Rr_map.key query_state -> Cstruct.t -> 35 | ('query_type, [`Msg of string | `Partial]) result 36 | (** [parse_response query_state response] is the information contained in 37 | [response] parsed using [query_state] when the query was successful, or 38 | an [Error _] if the [response] did not match the [query_state] 39 | (or if the query failed). 40 | *) 41 | -------------------------------------------------------------------------------- /certify/dns_certify.mli: -------------------------------------------------------------------------------- 1 | open Dns 2 | 3 | val letsencrypt_name : 'a Domain_name.t -> ([ `raw ] Domain_name.t, [> `Msg of string ]) result 4 | (** [letsencrypt_name host] is the service name at which we store let's encrypt 5 | certificates for the [host]. *) 6 | 7 | type u_err = [ `Tsig of Dns_tsig.e | `Bad_reply of Packet.mismatch * Packet.t | `Unexpected_reply of Packet.reply ] 8 | (** The type of update errors. *) 9 | 10 | val pp_u_err : u_err Fmt.t 11 | (** [pp_u_err ppf u] pretty-prints [u] on [ppf]. *) 12 | 13 | val nsupdate : (int -> Cstruct.t) -> (unit -> Ptime.t) -> host:[ `host ] Domain_name.t -> 14 | keyname:'b Domain_name.t -> zone:[ `host ] Domain_name.t -> Dns.Dnskey.t -> 15 | X509.CA.signing_request -> 16 | (Cstruct.t * (Cstruct.t -> (unit, [> u_err ]) result), 17 | [> `Msg of string ]) result 18 | (** [nsupdate rng now ~host ~keyname ~zone dnskey csr] is a buffer with a DNS 19 | update that removes all TLSA records from the given [host], and adds a single 20 | TLSA record containing the certificate signing request. It also returns a 21 | function which decodes a given answer, checks it to be a valid reply, and 22 | returns either unit or an error. The outgoing packet is signed with the 23 | provided [dnskey], the answer is checked to be signed by the same key. If 24 | the sign operation fails, [nsupdate] returns an error. *) 25 | 26 | type q_err = [ 27 | | `Decode of Packet.err 28 | | `Bad_reply of Packet.mismatch * Packet.t 29 | | `Unexpected_reply of Packet.reply 30 | | `No_tlsa 31 | ] 32 | (** The type for query errors. *) 33 | 34 | val pp_q_err : q_err Fmt.t 35 | (** [pp_q_err ppf q] pretty-prints [q] on [ppf]. *) 36 | 37 | val query : (int -> Cstruct.t) -> X509.public_key -> [ `host ] Domain_name.t -> 38 | (Cstruct.t * (Cstruct.t -> (X509.t, [> q_err ]) result), 39 | [> `Msg of string ]) result 40 | (** [query rng pubkey name] is a [buffer] with a DNS TLSA query for the given 41 | [name], and a function that decodes a given answer, either returning a X.509 42 | certificate or an error. *) 43 | -------------------------------------------------------------------------------- /unix/client/dns_client_unix.ml: -------------------------------------------------------------------------------- 1 | (* {!Uflow} provides the implementation of the underlying flow 2 | that is in turn used by {!Dns_client_flow.Make} to provide the 3 | blocking Unix convenience module: 4 | *) 5 | 6 | module Uflow : Dns_client_flow.S 7 | with type flow = Unix.file_descr 8 | and type io_addr = Unix.inet_addr * int 9 | and type stack = unit 10 | and type (+'a,+'b) io = ('a,[> `Msg of string]as 'b) result 11 | = struct 12 | type io_addr = Unix.inet_addr * int 13 | type ns_addr = [`TCP | `UDP] * io_addr 14 | type stack = unit 15 | type flow = Unix.file_descr 16 | type t = { nameserver : ns_addr } 17 | type (+'a,+'b) io = ('a,'b) result constraint 'b = [> `Msg of string] 18 | 19 | let create ?(nameserver = `TCP, (Unix.inet_addr_of_string "91.239.100.100", 53)) () = 20 | { nameserver } 21 | 22 | let nameserver { nameserver } = nameserver 23 | 24 | let map = Rresult.R.((>>=)) 25 | let resolve = (Rresult.R.(>>=)) 26 | let lift v = v 27 | 28 | open Rresult 29 | 30 | let connect ?nameserver:ns t = 31 | let proto, (server, port) = match ns with None -> nameserver t | Some x -> x in 32 | begin match proto with 33 | | `UDP -> Ok Unix.((getprotobyname "udp").p_proto) 34 | | `TCP -> Ok Unix.((getprotobyname "tcp").p_proto) 35 | end >>= fun proto_number -> 36 | let socket = Unix.socket PF_INET SOCK_STREAM proto_number in 37 | let addr = Unix.ADDR_INET (server, port) in 38 | Unix.connect socket addr ; 39 | Ok socket 40 | 41 | let send (socket:flow) (tx:Cstruct.t) = 42 | let str = Cstruct.to_string tx in 43 | let res = Unix.send_substring socket str 0 (String.length str) [] in 44 | if res <> String.length str 45 | then Error (`Msg ("Broken write to upstream NS" ^ (string_of_int res))) 46 | else Ok () 47 | 48 | let recv (socket:flow) = 49 | let buffer = Bytes.make 2048 '\000' in 50 | let x = Unix.recv socket buffer 0 (Bytes.length buffer) [] in 51 | if x > 0 && x <= Bytes.length buffer then 52 | Ok (Cstruct.of_bytes buffer ~len:x) 53 | else 54 | Error (`Msg "Reading from NS socket failed") 55 | end 56 | 57 | (* Now that we have our {!Uflow} implementation we can include the logic 58 | that goes on top of it: *) 59 | include Dns_client_flow.Make(Uflow) 60 | -------------------------------------------------------------------------------- /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-uesd 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 | open Dns 7 | open Rresult.R.Infix 8 | 9 | let load_zone zone = 10 | Bos.OS.File.read Fpath.(v zone) >>= fun data -> 11 | Dns_zone.parse data >>= fun rrs -> 12 | let domain = Domain_name.of_string_exn Fpath.(basename (v zone)) in 13 | (if not (Domain_name.Map.for_all (fun name _ -> Domain_name.sub ~domain ~subdomain:name) rrs) then 14 | Error (`Msg (Fmt.strf "an entry of %a is not in its zone, won't handle this@.%a" 15 | Domain_name.pp domain Dns.Name_rr_map.pp rrs)) 16 | else 17 | Ok ()) >>| fun () -> 18 | Dns_trie.insert_map rrs Dns_trie.empty 19 | 20 | let jump _ zone old = 21 | load_zone zone >>= fun trie -> 22 | Rresult.R.error_to_msg ~pp_error:Dns_trie.pp_zone_check (Dns_trie.check trie) >>= fun () -> 23 | Logs.app (fun m -> m "successfully checked zone") ; 24 | let zones = 25 | Dns_trie.fold Soa trie 26 | (fun name _ acc -> Domain_name.Set.add name acc) 27 | Domain_name.Set.empty 28 | in 29 | if Domain_name.Set.cardinal zones = 1 then 30 | let zone = Domain_name.Set.choose zones in 31 | Dns_server.text zone trie >>= fun zone_data -> 32 | Logs.debug (fun m -> m "assembled zone data %s" zone_data) ; 33 | (match old with 34 | | None -> Ok () 35 | | Some fn -> 36 | load_zone fn >>= fun old -> 37 | match Dns_trie.lookup zone Soa trie, Dns_trie.lookup zone Soa old with 38 | | Ok fresh, Ok old when Soa.newer ~old fresh -> 39 | Logs.debug (fun m -> m "zone %a newer than old" Domain_name.pp zone) ; 40 | Ok () 41 | | _ -> 42 | Error (`Msg "SOA comparison wrong")) 43 | else 44 | Error (`Msg "expected exactly one zone") 45 | 46 | open Cmdliner 47 | 48 | let newzone = 49 | let doc = "New zone file" in 50 | Arg.(required & pos 0 (some file) None & info [] ~doc ~docv:"ZONE") 51 | 52 | let oldzone = 53 | let doc = "Old zone file" in 54 | Arg.(value & opt (some file) None & info [ "old" ] ~doc ~docv:"ZONE") 55 | 56 | let cmd = 57 | Term.(term_result (const jump $ Dns_cli.setup_log $ newzone $ oldzone)), 58 | Term.info "ozone" ~version:"%%VERSION_NUM%%" 59 | 60 | let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 61 | -------------------------------------------------------------------------------- /resolver/dns_resolver_cache.mli: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | open Dns 3 | 4 | type rank = 5 | | ZoneFile 6 | | ZoneTransfer 7 | | AuthoritativeAnswer 8 | | AuthoritativeAuthority 9 | | ZoneGlue 10 | | NonAuthoritativeAnswer 11 | | Additional 12 | 13 | val pp_rank : rank Fmt.t 14 | 15 | val compare_rank : rank -> rank -> int 16 | 17 | type t 18 | 19 | type stats 20 | 21 | val pp_stats : stats Fmt.t 22 | 23 | val stats : unit -> stats 24 | 25 | val empty : int -> t 26 | 27 | val size : t -> int 28 | 29 | val capacity : t -> int 30 | 31 | val pp : t Fmt.t 32 | 33 | val pp_question : ([ `raw ] Domain_name.t * Packet.Question.qtype) Fmt.t 34 | 35 | type res = [ 36 | | `Alias of int32 * [ `raw ] Domain_name.t 37 | | `Entry of Rr_map.b 38 | | `No_data of [ `raw ] Domain_name.t * Soa.t 39 | | `No_domain of [ `raw ] Domain_name.t * Soa.t 40 | | `Serv_fail of [ `raw ] Domain_name.t * Soa.t 41 | ] 42 | 43 | val pp_res : res Fmt.t 44 | 45 | val cached : t -> int64 -> 'a Rr_map.key -> [ `raw ] Domain_name.t -> 46 | (res * t, [ `Cache_miss | `Cache_drop ]) result 47 | 48 | val maybe_insert : 'a Rr_map.key -> [ `raw ] Domain_name.t -> int64 -> rank -> res -> t -> t 49 | 50 | val follow_cname : t -> int64 -> 'a Rr_map.key -> name:[ `raw ] Domain_name.t -> int32 -> 51 | alias:[ `raw ] Domain_name.t -> 52 | [ `Out of Rcode.t * Name_rr_map.t * Name_rr_map.t * t 53 | | `Query of [ `raw ] Domain_name.t * t 54 | ] 55 | 56 | val answer : t -> int64 -> [ `raw ] Domain_name.t -> Packet.Question.qtype -> 57 | [ `Query of [ `raw ] Domain_name.t * t | `Packet of Packet.Flags.t * Packet.reply * t ] 58 | 59 | (* 60 | val resolve_ns : t -> int64 -> Domain_name.t -> 61 | [ `NeedA of Domain_name.t | `NeedCname of Domain_name.t | `HaveIPS of Rr_map.Ipv4_set.t | `NoDom | `No ] * t 62 | *) 63 | 64 | (*val find_ns : t -> (int -> Cstruct.t) -> int64 -> Domain_name.Set.t -> Domain_name.t -> 65 | [ `Loop | `NeedNS | `NoDom | `No | `Cname of Domain_name.t | `HaveIP of Ipaddr.V4.t | `NeedA of Domain_name.t | `NeedGlue of Domain_name.t ] * t 66 | *) 67 | 68 | val resolve : t -> rng:(int -> Cstruct.t) -> int64 -> [ `raw ] Domain_name.t -> 69 | Rr_map.k -> [ `raw ] Domain_name.t * [ `raw ] Domain_name.t * Rr_map.k * Ipaddr.V4.t * t 70 | 71 | val handle_query : t -> rng:(int -> Cstruct.t) -> int64 -> [ `raw ] Domain_name.t -> 72 | Packet.Question.qtype -> 73 | [ `Reply of Packet.Flags.t * Packet.reply 74 | | `Nothing 75 | | `Query of [ `raw ] Domain_name.t * ([ `raw ] Domain_name.t * Packet.Question.qtype) * Ipaddr.V4.t ] * t 76 | -------------------------------------------------------------------------------- /mirage/client/dns_mirage_client.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let src = Logs.Src.create "dns_mirage_client" ~doc:"effectful DNS client layer" 4 | module Log = (val Logs.src_log src : Logs.LOG) 5 | 6 | module Make (S : Mirage_stack_lwt.V4) = struct 7 | 8 | module Uflow : Dns_client_flow.S 9 | with type flow = S.TCPV4.flow 10 | and type stack = S.t 11 | and type (+'a,+'b) io = ('a, 'b) Lwt_result.t 12 | constraint 'b = [> `Msg of string] 13 | and type io_addr = Ipaddr.V4.t * int = struct 14 | type flow = S.TCPV4.flow 15 | type stack = S.t 16 | type io_addr = Ipaddr.V4.t * int 17 | type ns_addr = [`TCP | `UDP] * io_addr 18 | type (+'a,+'b) io = ('a, 'b) Lwt_result.t 19 | constraint 'b = [> `Msg of string] 20 | type t = { 21 | nameserver : ns_addr ; 22 | stack : stack ; 23 | } 24 | 25 | let create ?(nameserver = `TCP, (Ipaddr.V4.of_string_exn "91.239.100.100", 53)) stack = 26 | { nameserver ; stack } 27 | 28 | let nameserver { nameserver ; _ } = nameserver 29 | 30 | let map = Lwt_result.bind 31 | let resolve = Lwt_result.bind_result 32 | let lift = Lwt_result.lift 33 | 34 | let connect ?nameserver:ns t = 35 | let _proto, addr = match ns with None -> nameserver t | Some x -> x in 36 | S.TCPV4.create_connection (S.tcpv4 t.stack) addr >|= function 37 | | Error e -> 38 | Log.err (fun m -> m "error connecting to nameserver %a" 39 | S.TCPV4.pp_error e) ; 40 | Error (`Msg "connect failure") 41 | | Ok flow -> Ok flow 42 | 43 | let recv flow = 44 | S.TCPV4.read flow >|= function 45 | | Error e -> Error (`Msg (Fmt.to_to_string S.TCPV4.pp_error e)) 46 | | Ok (`Data cs) -> Ok cs 47 | | Ok `Eof -> Ok Cstruct.empty 48 | 49 | let send flow s = 50 | S.TCPV4.write flow s >|= function 51 | | Error e -> Error (`Msg (Fmt.to_to_string S.TCPV4.pp_write_error e)) 52 | | Ok () -> Ok () 53 | end 54 | 55 | include Dns_client_flow.Make(Uflow) 56 | 57 | end 58 | 59 | (* 60 | type dns_ty = Dns_client 61 | 62 | let config : 'a Mirage.impl = 63 | let open Mirage in 64 | impl @@ object inherit Mirage.base_configurable 65 | method module_name = "Dns_client" 66 | method name = "Dns_client" 67 | method ty : 'a typ = Type Dns_client 68 | method! packages : package list value = 69 | (Key.match_ Key.(value target) @@ begin function 70 | | `Unix -> [package "dns-client-unix"] 71 | | _ -> [] 72 | end 73 | ) 74 | method! deps = [] 75 | end 76 | *) 77 | -------------------------------------------------------------------------------- /lwt/client/dns_client_lwt.ml: -------------------------------------------------------------------------------- 1 | (* {!Uflow} provides the implementation of the underlying flow 2 | that is in turn used by {!Dns_client_flow.Make} to provide the 3 | Lwt convenience module 4 | *) 5 | 6 | open Lwt.Infix 7 | 8 | module Uflow : Dns_client_flow.S 9 | with type flow = Lwt_unix.file_descr 10 | and type io_addr = Lwt_unix.inet_addr * int 11 | and type (+'a,+'b) io = ('a,'b) Lwt_result.t 12 | and type stack = unit 13 | = struct 14 | type io_addr = Lwt_unix.inet_addr * int 15 | type flow = Lwt_unix.file_descr 16 | type ns_addr = [`TCP | `UDP] * io_addr 17 | type (+'a,+'b) io = ('a,'b) Lwt_result.t 18 | constraint 'b = [> `Msg of string] 19 | type stack = unit 20 | type t = { nameserver : ns_addr } 21 | 22 | let create ?(nameserver = `TCP, (Unix.inet_addr_of_string "91.239.100.100", 53)) () = 23 | { nameserver } 24 | 25 | let nameserver { nameserver } = nameserver 26 | 27 | let send socket tx = 28 | let open Lwt in 29 | Lwt_unix.send socket (Cstruct.to_bytes tx) 0 30 | (Cstruct.len tx) [] >>= fun res -> 31 | if res <> Cstruct.len tx then 32 | Lwt_result.fail (`Msg ("oops" ^ (string_of_int res))) 33 | else 34 | Lwt_result.return () 35 | 36 | let recv socket = 37 | let open Lwt in 38 | let recv_buffer = Bytes.make 2048 '\000' in 39 | Lwt_unix.recv socket recv_buffer 0 (Bytes.length recv_buffer) [] 40 | >>= fun read_len -> 41 | let open Lwt_result in 42 | (if read_len > 0 then Lwt_result.return () 43 | else Lwt_result.fail (`Msg "Empty response")) >|= fun () -> 44 | (Cstruct.of_bytes ~len:read_len recv_buffer) 45 | 46 | let map = Lwt_result.bind 47 | let resolve = Lwt_result.bind_result 48 | let lift = Lwt_result.lift 49 | 50 | let connect ?nameserver:ns t = 51 | let (proto, (server, port)) = match ns with None -> nameserver t | Some x -> x in 52 | begin match proto with 53 | | `UDP -> 54 | Lwt_unix.((getprotobyname "udp") >|= fun x -> x.p_proto, 55 | SOCK_DGRAM) 56 | | `TCP -> 57 | Lwt_unix.((getprotobyname "tcp") >|= fun x -> x.p_proto, 58 | SOCK_STREAM) 59 | end >>= fun (proto_number, socket_type) -> 60 | let socket = Lwt_unix.socket PF_INET socket_type proto_number in 61 | let addr = Lwt_unix.ADDR_INET (server, port) in 62 | Lwt_unix.connect socket addr >|= fun () -> 63 | Ok socket 64 | end 65 | 66 | (* Now that we have our {!Uflow} implementation we can include the logic 67 | that goes on top of it: *) 68 | include Dns_client_flow.Make(Uflow) 69 | -------------------------------------------------------------------------------- /client/dns_client_flow.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type flow 3 | type (+'a,+'b) io constraint 'b = [> `Msg of string] 4 | type io_addr 5 | type ns_addr = ([`TCP | `UDP]) * io_addr 6 | type stack 7 | type t 8 | 9 | val create : ?nameserver:ns_addr -> stack -> t 10 | 11 | val nameserver : t -> ns_addr 12 | 13 | val connect : ?nameserver:ns_addr -> t -> (flow,'err) io 14 | val send : flow -> Cstruct.t -> (unit,'b) io 15 | val recv : flow -> (Cstruct.t, 'b) io 16 | 17 | val resolve : ('a,'b) io -> ('a -> ('c,'b) result) -> ('c,'b) io 18 | val map : ('a,'b) io -> ('a -> ('c,'b) io) -> ('c,'b) io 19 | val lift : ('a,'b) result -> ('a,'b) io 20 | end 21 | 22 | module Make = functor (Uflow:S) -> 23 | struct 24 | 25 | let create ?nameserver stack = Uflow.create ?nameserver stack 26 | 27 | let nameserver t = Uflow.nameserver t 28 | 29 | let getaddrinfo (type requested) t ?nameserver (query_type:requested Dns.Rr_map.key) name 30 | : (requested, [> `Msg of string]) Uflow.io = 31 | let proto, _ = match nameserver with None -> Uflow.nameserver t | Some x -> x in 32 | let tx, state = 33 | Dns_client.make_query 34 | (match proto with `UDP -> `Udp | `TCP -> `Tcp) name query_type 35 | in 36 | let (>>|) = Uflow.map in 37 | Uflow.connect ?nameserver t >>| fun socket -> 38 | Logs.debug (fun m -> m "Connected to NS."); 39 | Uflow.send socket tx >>| fun () -> 40 | let () = Logs.debug (fun m -> m "Receiving from NS") in 41 | let rec recv_loop acc = 42 | Uflow.recv socket >>| fun recv_buffer -> 43 | Logs.debug (fun m -> m "Read @[%d bytes@]" 44 | (Cstruct.len recv_buffer)) ; 45 | let buf = Cstruct.append acc recv_buffer in 46 | match Dns_client.parse_response state buf with 47 | | Ok x -> Uflow.lift (Ok x) 48 | | Error (`Msg xxx) -> 49 | Uflow.lift (Error (`Msg( "err: " ^ xxx))) 50 | | Error `Partial -> begin match proto with 51 | | `TCP -> recv_loop buf 52 | | `UDP -> Uflow.lift (Error (`Msg "Truncated UDP response")) end 53 | in recv_loop Cstruct.empty 54 | 55 | let gethostbyname stack ?nameserver domain = 56 | let (>>=) = Uflow.resolve in 57 | getaddrinfo stack ?nameserver Dns.Rr_map.A domain >>= fun (_ttl, resp) -> 58 | match Dns.Rr_map.Ipv4_set.choose_opt resp with 59 | | None -> Error (`Msg "No A record found") 60 | | Some ip -> Ok ip 61 | 62 | let gethostbyname6 stack ?nameserver domain = 63 | let (>>=) = Uflow.resolve in 64 | getaddrinfo stack ?nameserver Dns.Rr_map.Aaaa domain >>= fun (_ttl, res) -> 65 | match Dns.Rr_map.Ipv6_set.choose_opt res with 66 | | None -> Error (`Msg "No AAAA record found") 67 | | Some ip -> Ok ip 68 | end 69 | -------------------------------------------------------------------------------- /app/dns_cli.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | let setup_log style_renderer level = 3 | Fmt_tty.setup_std_outputs ?style_renderer (); 4 | Logs.set_level level; 5 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 6 | 7 | let connect_tcp ip port = 8 | let sa = Unix.ADDR_INET (Ipaddr_unix.V4.to_inet_addr ip, port) in 9 | let sock = Unix.(socket PF_INET SOCK_STREAM 0) in 10 | Unix.(setsockopt sock SO_REUSEADDR true) ; 11 | Unix.connect sock sa ; 12 | sock 13 | 14 | (* TODO EINTR, SIGPIPE *) 15 | let send_tcp sock buf = 16 | let size = Cstruct.len buf in 17 | let size_cs = 18 | let b = Cstruct.create 2 in 19 | Cstruct.BE.set_uint16 b 0 size ; 20 | b 21 | in 22 | let data = Cstruct.(to_bytes (append size_cs buf)) in 23 | let whole = size + 2 in 24 | let rec out off = 25 | if off = whole then () 26 | else 27 | let bytes = Unix.send sock data off (whole - off) [] in 28 | out (bytes + off) 29 | in 30 | out 0 31 | 32 | let recv_tcp sock = 33 | let rec read_exactly buf len off = 34 | if off = len then () 35 | else 36 | let n = Unix.recv sock buf off (len - off) [] in 37 | read_exactly buf len (off + n) 38 | in 39 | let buf = Bytes.create 2 in 40 | read_exactly buf 2 0 ; 41 | let len = Cstruct.BE.get_uint16 (Cstruct.of_bytes buf) 0 in 42 | let buf' = Bytes.create len in 43 | read_exactly buf' len 0 ; 44 | Cstruct.of_bytes buf' 45 | 46 | open Cmdliner 47 | 48 | let setup_log = 49 | Term.(const setup_log 50 | $ Fmt_cli.style_renderer () 51 | $ Logs_cli.level ()) 52 | 53 | let ip_c : Ipaddr.V4.t Arg.converter = 54 | let parse s = 55 | try 56 | `Ok (Ipaddr.V4.of_string_exn s) 57 | with 58 | Not_found -> `Error "failed to parse IP address" 59 | in 60 | parse, Ipaddr.V4.pp 61 | 62 | let namekey_c = 63 | let parse s = 64 | let open Rresult.R.Infix in 65 | match 66 | Dns.Dnskey.name_key_of_string s >>= fun (name, key) -> 67 | Domain_name.drop_label ~amount:2 name >>= fun zone -> 68 | Domain_name.host zone >>| fun zone -> 69 | (name, zone, key) 70 | with 71 | | Error (`Msg m) -> `Error ("failed to parse key: " ^ m) 72 | | Ok a -> `Ok a 73 | in 74 | parse, fun ppf (name, zone, key) -> Fmt.pf ppf "key name %a zone %a dnskey %a" 75 | Domain_name.pp name Domain_name.pp zone Dns.Dnskey.pp key 76 | 77 | let name_c = 78 | (fun s -> match Domain_name.of_string s with 79 | | Error _ -> `Error "failed to parse hostname" 80 | | Ok name -> 81 | match Domain_name.host name with 82 | | Error (`Msg e) -> `Error ("failed to parse hostname: " ^ e) 83 | | Ok host -> `Ok host), Domain_name.pp 84 | 85 | let domain_name_c = 86 | (fun s -> match Domain_name.of_string s with 87 | | Error _ -> `Error "failed to parse domain name" 88 | | Ok name -> `Ok name), Domain_name.pp 89 | -------------------------------------------------------------------------------- /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 : Mirage_stack_lwt.V4) = struct 9 | 10 | module IS = Set.Make(Ipaddr.V4) 11 | 12 | module IM = struct 13 | include Map.Make(Ipaddr.V4) 14 | let find k t = try Some (find k t) with Not_found -> None 15 | end 16 | 17 | module IPM = struct 18 | include Map.Make(struct 19 | type t = Ipaddr.V4.t * int 20 | let compare (ip, p) (ip', p') = match Ipaddr.V4.compare ip ip' with 21 | | 0 -> compare p p' 22 | | x -> x 23 | end) 24 | let find k t = try Some (find k t) with Not_found -> None 25 | end 26 | 27 | module U = S.UDPV4 28 | module T = S.TCPV4 29 | 30 | type f = { 31 | flow : T.flow ; 32 | mutable linger : Cstruct.t ; 33 | } 34 | 35 | let of_flow flow = { flow ; linger = Cstruct.empty } 36 | 37 | let flow { flow ; _ } = flow 38 | 39 | let rec read_exactly f length = 40 | let dst_ip, dst_port = T.dst f.flow in 41 | if Cstruct.len f.linger >= length then 42 | let a, b = Cstruct.split f.linger length in 43 | f.linger <- b ; 44 | Lwt.return (Ok a) 45 | else 46 | T.read f.flow >>= function 47 | | Ok `Eof -> 48 | Log.warn (fun m -> m "end of file on flow %a:%d" Ipaddr.V4.pp dst_ip dst_port) ; 49 | T.close f.flow >>= fun () -> 50 | Lwt.return (Error ()) 51 | | Error e -> 52 | Log.err (fun m -> m "error %a reading flow %a:%d" T.pp_error e Ipaddr.V4.pp dst_ip dst_port) ; 53 | T.close f.flow >>= fun () -> 54 | Lwt.return (Error ()) 55 | | Ok (`Data b) -> 56 | f.linger <- Cstruct.append f.linger b ; 57 | read_exactly f length 58 | 59 | let send_udp stack src_port dst dst_port data = 60 | Log.info (fun m -> m "udp: sending %d bytes from %d to %a:%d" 61 | (Cstruct.len data) src_port Ipaddr.V4.pp dst dst_port) ; 62 | U.write ~src_port ~dst ~dst_port (S.udpv4 stack) data >|= function 63 | | Error e -> Log.warn (fun m -> m "udp: failure %a while sending from %d to %a:%d" 64 | U.pp_error e src_port Ipaddr.V4.pp dst dst_port) 65 | | Ok () -> () 66 | 67 | let send_tcp flow answer = 68 | let dst_ip, dst_port = T.dst flow in 69 | Log.info (fun m -> m "tcp: sending %d bytes to %a:%d" (Cstruct.len answer) Ipaddr.V4.pp dst_ip dst_port) ; 70 | let len = Cstruct.create 2 in 71 | Cstruct.BE.set_uint16 len 0 (Cstruct.len answer) ; 72 | T.write flow (Cstruct.append len answer) >>= function 73 | | Ok () -> Lwt.return (Ok ()) 74 | | Error e -> 75 | Log.err (fun m -> m "tcp: error %a while writing to %a:%d" T.pp_write_error e Ipaddr.V4.pp dst_ip dst_port) ; 76 | T.close flow >|= fun () -> 77 | Error () 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 | -------------------------------------------------------------------------------- /test/tsig.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017 Hannes Mehnert, all rights reserved *) 2 | 3 | let cs = 4 | let module M = struct 5 | type t = Cstruct.t 6 | let pp = Cstruct.hexdump_pp 7 | let equal = Cstruct.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 21 | Nocrypto.Base64.decode 22 | (Cstruct.of_string "GSnQJ+fHuzwj5yKzCOkXdISyGQXBUxMrjEjL4Kr1WIs=") 23 | with 24 | | None -> assert false 25 | | Some x -> x 26 | 27 | let key_name = Domain_name.of_string_exn "mykey.bla.example" 28 | 29 | let of_h = Nocrypto.Uncommon.Cs.of_hex 30 | 31 | let tsig ?(fudge = 300) algorithm signed = 32 | let fudge = Ptime.Span.of_int_s fudge in 33 | let signed = 34 | match Ptime.of_float_s (float_of_int signed) with 35 | | None -> assert false 36 | | Some x -> x 37 | in 38 | match Dns.Tsig.tsig ~algorithm ~signed ~fudge () with 39 | | None -> assert false 40 | | Some x -> x 41 | 42 | let example0 () = 43 | let buf = of_h {__|62 d7 28 00 00 01 00 00 00 02 00 00 07 65 78 61 44 | 6d 70 6c 65 03 63 6f 6d 00 00 06 00 01 03 66 6f 45 | 6f c0 0c 00 ff 00 ff 00 00 00 00 00 00 03 62 61 46 | 72 c0 0c 00 01 00 01 00 00 01 2c 00 04 01 02 03 47 | 04|__} 48 | and now = 1506887417 49 | and mac = of_h {__|bf 5d 77 ba 97 ba 7b 95 9e 1b 0d 95 64 a7 5b a6 50 | 95 bf 24 15 3b 9d a2 1b bf 6f ae 61 9d 0f 28 a1|__} 51 | in 52 | Alcotest.(check cs "tsig is the same" mac 53 | (Dns_tsig.compute_tsig key_name (tsig Dns.Tsig.SHA256 now) ~key buf)) 54 | 55 | let example1 () = 56 | let buf = of_h {__|4c 56 28 00 00 01 00 00 00 01 00 00 07 45 78 41 57 | 6d 50 6c 45 03 63 6f 6d 00 00 06 00 01 03 66 6f 58 | 6f 07 65 78 61 6d 70 6c 65 c0 14 00 ff 00 ff 00 59 | 00 00 00 00 00|__} 60 | and now = 1506887742 61 | and mac = of_h {__|70 67 ae 70 9e fd 22 9e ce d9 65 25 8a db 8c 96 62 | 10 95 80 89 a7 ee 4f bb 13 81 e7 38 e3 a0 78 80|__} 63 | in 64 | Alcotest.(check cs "tsig is the same" mac 65 | (Dns_tsig.compute_tsig key_name (tsig Dns.Tsig.SHA256 now) ~key buf)) 66 | 67 | let example2 () = 68 | let buf = of_h {__|76 8a 28 00 00 01 00 00 00 01 00 00 07 65 78 61 69 | 6d 70 6c 65 00 00 06 00 01 03 66 6f 6f c0 0c 00 70 | ff 00 ff 00 00 00 00 00 00|__} 71 | and now = 1506888104 72 | and mac = of_h {__|e7 76 e6 df 4e 73 14 c8 eb ba 4c c7 a5 39 b3 93 73 | a7 df 6d de 47 b6 fa cc 81 c8 47 29 20 77 40 44|__} 74 | in 75 | Alcotest.(check cs "tsig is the same" mac 76 | (Dns_tsig.compute_tsig key_name (tsig Dns.Tsig.SHA256 now) ~key buf)) 77 | 78 | 79 | let tsig_tests = [ 80 | "example0", `Quick, example0 ; 81 | "example1", `Quick, example1 ; 82 | "example2", `Quick, example2 ; 83 | ] 84 | 85 | 86 | let tests = [ 87 | "Tsig example", tsig_tests ; 88 | ] 89 | 90 | let () = Alcotest.run "DNS name tests" tests 91 | -------------------------------------------------------------------------------- /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, Ipv4_set.singleton ip_address))) 13 | ] 14 | in 15 | (Domain_name.Map.empty, up) 16 | and header = Random.int 0xFFFF, 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 | Random.self_init () ; 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.V4.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.strf "tsig sign error %a" Dns_tsig.pp_s s)) 33 | | Ok (data, mac) -> 34 | let data_len = Cstruct.len 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.strf "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.strf "nsupdate expected update ack, received %a" Packet.pp_reply r)) 50 | | Error e -> 51 | Error (`Msg (Fmt.strf "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 ip_address = 73 | let doc = "New IP address" in 74 | Arg.(required & pos 3 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"IP") 75 | 76 | let cmd = 77 | Term.(term_result (const jump $ Dns_cli.setup_log $ serverip $ port $ key $ hostname $ ip_address)), 78 | Term.info "oupdate" ~version:"%%VERSION_NUM%%" 79 | 80 | let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 81 | -------------------------------------------------------------------------------- /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 *) 31 | let kw_or_cs s = match (String.uppercase_ascii s) with 32 | "A" -> TYPE_A s 33 | | "NS" -> TYPE_NS s 34 | | "CNAME" -> TYPE_CNAME s 35 | | "SOA" -> TYPE_SOA s 36 | | "PTR" -> TYPE_PTR s 37 | | "MX" -> TYPE_MX s 38 | | "TXT" -> TYPE_TXT s 39 | | "AAAA" -> TYPE_AAAA s 40 | | "SRV" -> TYPE_SRV s 41 | | "DNSKEY" -> TYPE_DNSKEY s 42 | | "CAA" -> TYPE_CAA s 43 | | "TLSA" -> TYPE_TLSA s 44 | | "SSHFP" -> TYPE_SSHFP s 45 | | "IN" -> CLASS_IN s 46 | | "CS" -> CLASS_CS s 47 | | "CH" -> CLASS_CH s 48 | | "HS" -> CLASS_HS s 49 | | _ -> CHARSTRING s 50 | 51 | (* Scan an accepted token for linebreaks *) 52 | let count_linebreaks s = 53 | String.iter (function '\n' -> state.lineno <- state.lineno + 1 | _ -> ()) s 54 | 55 | } 56 | 57 | let eol = [' ''\t']* (';' [^'\n']*)? '\n' 58 | let octet = '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] 59 | let escape = '\\' _ (* Strictly \0 is not an escape, but be liberal *) 60 | let qstring = '"' ((([^'\\''"']|octet|escape)*) as contents) '"' 61 | let label = (([^'\\'' ''\t''\n''.''('')']|octet|escape)*) as contents 62 | let number = (['0'-'9']+) as contents 63 | let openpar = [' ''\t']* '(' ([' ''\t''\n'] | eol)* 64 | let closepar = (eol | [' ''\t''\n'])* ')' [' ''\t']* 65 | let typefoo = (['T''t']['Y''y']['P''p']['E''e'] number) as contents 66 | 67 | rule token = parse 68 | eol { state.lineno <- state.lineno + 1; 69 | if state.paren > 0 then SPACE else EOL } 70 | | openpar { state.paren <- state.paren + 1; 71 | count_linebreaks (lexeme lexbuf); SPACE } 72 | | closepar { if state.paren > 0 then state.paren <- state.paren - 1; 73 | count_linebreaks (lexeme lexbuf); SPACE } 74 | | closepar eol { if state.paren > 0 then state.paren <- state.paren - 1; 75 | count_linebreaks (lexeme lexbuf); EOL } 76 | | "\\#" { GENERIC } 77 | | "$ORIGIN" { SORIGIN } 78 | | "$TTL" { STTL } 79 | | '.' { DOT } 80 | | '@' { AT } 81 | | number { NUMBER contents } 82 | | typefoo { TYPE_GENERIC contents } 83 | | qstring { count_linebreaks contents; CHARSTRING contents } 84 | | label { count_linebreaks contents; kw_or_cs contents } 85 | | [' ''\t']+ { SPACE } 86 | | eof { EOF } 87 | -------------------------------------------------------------------------------- /client/dns_client.ml: -------------------------------------------------------------------------------- 1 | open Dns 2 | 3 | type 'key query_state = 4 | { protocol : Dns.proto ; 5 | key: 'key ; 6 | query : Packet.t ; 7 | } constraint 'key = 'a Rr_map.key 8 | 9 | let make_query protocol hostname 10 | : 'xy -> 11 | Cstruct.t * 'xy query_state = 12 | (* SRV records: Service + Protocol are case-insensitive, see RFC2728 pg2. *) 13 | fun record_type -> 14 | let question = Packet.Question.create hostname record_type in 15 | let header = Random.int 0xffff (* TODO *), Packet.Flags.singleton `Recursion_desired in 16 | let query = Packet.create header question `Query in 17 | let cs , _ = Packet.encode protocol query in 18 | begin match protocol with 19 | | `Udp -> cs 20 | | `Tcp -> 21 | let len_field = Cstruct.create 2 in 22 | Cstruct.BE.set_uint16 len_field 0 (Cstruct.len cs) ; 23 | Cstruct.concat [len_field ; cs] 24 | end, { protocol ; query ; key = record_type } 25 | 26 | let parse_response (type requested) 27 | : requested Rr_map.key query_state -> Cstruct.t -> 28 | (requested, [< `Partial | `Msg of string]) result = 29 | fun state buf -> 30 | let open Rresult in 31 | begin match state.protocol with (* consume TCP two-byte length prefix: *) 32 | | `Udp -> Ok buf 33 | | `Tcp -> 34 | begin match Cstruct.BE.get_uint16 buf 0 with 35 | | exception Invalid_argument _ -> Error `Partial (* TODO *) 36 | | pkt_len when pkt_len > Cstruct.len buf -2 -> 37 | Logs.debug (fun m -> m "Partial: %d >= %d-2" 38 | pkt_len (Cstruct.len buf)); 39 | Error `Partial (* TODO return remaining # *) 40 | | pkt_len -> 41 | if 2 + pkt_len < Cstruct.len buf then 42 | Logs.warn (fun m -> m "Extraneous data in DNS response"); 43 | Ok (Cstruct.sub buf 2 pkt_len) 44 | end 45 | end >>= fun buf -> 46 | let to_msg t = function Ok a -> Ok a | Error e -> 47 | R.error_msgf 48 | "QUERY: @[hdr:%a (id: %d = %d) (q=q: %B)@ query:%a%a opt:%a tsig:%B@,failed: %a@,@]" 49 | Packet.pp_header t 50 | (fst t.header) (fst state.query.header) 51 | (Packet.Question.compare t.question state.query.question = 0) 52 | Packet.Question.pp t.question 53 | Packet.pp_data t.data 54 | (Fmt.option Dns.Edns.pp) t.edns 55 | (match t.tsig with None -> false | Some _ -> true) 56 | Packet.pp_mismatch e 57 | in 58 | match Packet.decode buf with 59 | | Ok t -> 60 | begin 61 | to_msg t (Packet.reply_matches_request ~request:state.query t) >>= function 62 | | `Answer (answer, _) -> 63 | let rec follow_cname counter q_name = 64 | if counter <= 0 then Error (`Msg "CNAME recursion too deep") 65 | else 66 | Domain_name.Map.find_opt q_name answer 67 | |> R.of_option ~none:(fun () -> 68 | R.error_msgf "Can't find relevant map in response:@ \ 69 | %a in [%a]" 70 | Domain_name.pp q_name 71 | Name_rr_map.pp answer 72 | ) >>= fun relevant_map -> 73 | begin match Rr_map.find state.key relevant_map with 74 | | Some response -> Ok response 75 | | None -> 76 | begin match Rr_map.(find Cname relevant_map) with 77 | | None -> Error (`Msg "Invalid DNS response") 78 | | Some (_ttl, redirected_host) -> 79 | follow_cname (pred counter) redirected_host 80 | end 81 | end 82 | in 83 | follow_cname 20 (fst state.query.question) 84 | | r -> Error (`Msg (Fmt.strf "Ok %a, expected answer" Packet.pp_reply r)) 85 | end 86 | | Error `Partial as err -> err 87 | | Error err -> R.error_msgf "Error parsing response: %a" Packet.pp_err err 88 | -------------------------------------------------------------------------------- /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 = Random.int 0xFFFF, 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 | Random.self_init () ; 24 | let now = Ptime_clock.now () in 25 | Logs.app (fun m -> m "notifying to %a:%d zone %a serial %lu" 26 | Ipaddr.V4.pp serverip port Domain_name.pp zone serial) ; 27 | match notify zone serial key now with 28 | | Error s -> Error (`Msg (Fmt.strf "signing %a" Dns_tsig.pp_s s)) 29 | | Ok (request, data, mac) -> 30 | let data_len = Cstruct.len 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.strf "expected notify ack, got %a" Packet.pp_reply r)) 45 | | Error e -> Error (`Msg (Fmt.strf "notify reply %a is not ok %a" 46 | Packet.pp reply Packet.pp_mismatch e)) 47 | end 48 | | Error e -> 49 | Error (`Msg (Fmt.strf "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.strf "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.strf "expected notify ack, got %a" Packet.pp_reply r)) 61 | | Error e -> 62 | Error (`Msg (Fmt.strf "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 | Term.(term_result (const jump $ Dns_cli.setup_log $ serverip $ port $ zone $ key $ serial)), 90 | Term.info "onotify" ~version:"%%VERSION_NUM%%" 91 | 92 | let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 93 | -------------------------------------------------------------------------------- /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, ip) -> Domain_name.(host_exn (of_string_exn n)), Ipaddr.V4.of_string_exn ip) 6 | [ 7 | "a.root-servers.net", "198.41.0.4" ; (* , 2001:503:ba3e::2:30 VeriSign, Inc. *) 8 | "b.root-servers.net", "199.9.14.201" ; (* , 2001:500:200::b University of Southern California (ISI) *) 9 | "c.root-servers.net", "192.33.4.12" ; (* , 2001:500:2::c Cogent Communications *) 10 | "d.root-servers.net", "199.7.91.13" ; (* , 2001:500:2d::d University of Maryland *) 11 | "e.root-servers.net", "192.203.230.10" ; (* , 2001:500:a8::e NASA (Ames Research Center) *) 12 | "f.root-servers.net", "192.5.5.241" ; (* , 2001:500:2f::f Internet Systems Consortium, Inc. *) 13 | "g.root-servers.net", "192.112.36.4" ; (* , 2001:500:12::d0d US Department of Defense (NIC) *) 14 | "h.root-servers.net", "198.97.190.53" ; (* , 2001:500:1::53 US Army (Research Lab) *) 15 | "i.root-servers.net", "192.36.148.17" ; (* , 2001:7fe::53 Netnod *) 16 | "j.root-servers.net", "192.58.128.30" ; (* , 2001:503:c27::2:30 VeriSign, Inc. *) 17 | "k.root-servers.net", "193.0.14.129" ; (* , 2001:7fd::1 RIPE NCC *) 18 | "l.root-servers.net", "199.7.83.42" ; (* , 2001:500:9f::42 ICANN *) 19 | "m.root-servers.net", "202.12.27.33" (* , 2001:dc3::35 WIDE Project *) 20 | ] 21 | 22 | let a_ttl = 3600000l 23 | let ns_ttl = 518400l 24 | 25 | let ns_records = 26 | let ns = 27 | let add_to_set set (name, _) = Domain_name.Host_set.add name set in 28 | List.fold_left add_to_set Domain_name.Host_set.empty root_servers 29 | in 30 | Rr_map.(B (Ns, (ns_ttl, ns))) 31 | 32 | let a_records = 33 | List.map (fun (name, ip) -> 34 | Domain_name.raw name, Rr_map.(B (A, (a_ttl, Ipv4_set.singleton ip)))) 35 | root_servers 36 | 37 | let reserved_zone_records = 38 | let n = Domain_name.of_string_exn in 39 | (* RFC 6761, avoid them to get out of here + multicast DNS 6762 *) 40 | let zones = 41 | Domain_name.Set.(add (n "local") (* multicast dns, RFC 6762 *) 42 | (add (n "test") (add (n "invalid") (* RFC 6761 *) 43 | (add (n "localhost") (* RFC 6761, draft let-localhost-be-localhost *) 44 | empty)))) 45 | in 46 | let rec gen acc pos up = function 47 | | n when succ n = up -> List.rev acc 48 | | n -> 49 | let net = string_of_int n ^ pos in 50 | gen (net :: acc) pos up (succ n) 51 | in 52 | let nets = [ (* RFC 6761 and RFC 6890 *) 53 | "0" (* 0.0.0.0/8 *) ; 54 | "10" (* 10.0.0.0/8 *) ; 55 | "127" (* 127.0.0.0/8 *) ; 56 | "254.169" (* "169.254.0.0/16" *) ; 57 | "0.0.192" (* "192.0.0.0/24" *) ; 58 | "2.0.192" (* "192.0.2.0/24" *) ; 59 | "168.192" (* "192.168.0.0/16" *) ; 60 | "18.198" ; "19.198" (* "198.18.0.0/15" *) ; 61 | "100.51.198" (* "198.51.100.0/24" *) ; 62 | "113.0.203" (* "203.0.113.0/24" *) ; 63 | ] @ gen [] ".100" 128 64 (* "100.64.0.0/10" ; *) 64 | @ gen [] ".172" 32 16 (* "172.16.0.0/12" ; *) 65 | @ gen [] "" 256 240 (* "240.0.0.0/4" *) 66 | in 67 | List.fold_left (fun m net -> 68 | let name = net ^ ".in-addr.arpa" in 69 | Domain_name.Set.add (n name) m) 70 | zones nets 71 | (* XXX V6 reserved nets (also RFC6890) *) 72 | 73 | let stub_soa s = 74 | let nameserver = Domain_name.prepend_label_exn s "ns" 75 | and hostmaster = Domain_name.prepend_label_exn s "hostmaster" 76 | in 77 | { Soa.nameserver ; hostmaster ; serial = 0l ; refresh = 300l ; retry = 300l ; 78 | expiry = 300l ; minimum = 300l } 79 | 80 | let reserved_zones = 81 | let inv s = Rr_map.(B (Soa, stub_soa s)) in 82 | Domain_name.Set.fold (fun n acc -> (n, inv n) :: acc) reserved_zone_records [] 83 | 84 | let reserved = 85 | Domain_name.Set.fold (fun name trie -> 86 | Dns_trie.insert name Rr_map.Soa (stub_soa name) trie) 87 | reserved_zone_records Dns_trie.empty 88 | 89 | let root_servers = List.map (fun (n, ip) -> Domain_name.raw n, ip) root_servers 90 | -------------------------------------------------------------------------------- /client/dns_client_flow.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 | 7 | module type S = sig 8 | type flow 9 | (** A flow is a connection produced by {!U.connect} *) 10 | 11 | type (+'ok,+'err) io constraint 'err = [> `Msg of string] 12 | (** [io] is the type of an effect. ['err] is a polymorphic variant. *) 13 | 14 | type io_addr 15 | (** An address for a given flow type, usually this will consist of 16 | IP address + a TCP/IP or UDP/IP port number, but for some flow types 17 | it can carry additional information for purposes of cryptographic 18 | verification. TODO at least that would be nice in the future. TODO 19 | *) 20 | 21 | type ns_addr = [ `TCP | `UDP] * io_addr 22 | (** TODO well this is kind of crude; it's a tuple to prevent having 23 | to do endless amounts of currying things when implementing flow types, 24 | and we need to know the protocol used so we can prefix packets for 25 | DNS-over-TCP and set correct socket options etc. therefore we can't 26 | just use the opaque [io_addr]. 27 | TODO*) 28 | 29 | type stack 30 | (** A stack with which to connect, e.g. {IPv4.tcpv4}*) 31 | 32 | type t 33 | (** The abstract state of a DNS client. *) 34 | 35 | val create : ?nameserver:ns_addr -> stack -> t 36 | (** [create ~nameserver stack] creates the state record of the DNS client. *) 37 | 38 | val nameserver : t -> ns_addr 39 | (** The address of a nameserver that is supposed to work with 40 | the underlying flow, can be used if the user does not want to 41 | bother with configuring their own.*) 42 | 43 | val connect : ?nameserver:ns_addr -> t -> (flow,'err) io 44 | (** [connect addr] is a new connection ([flow]) to [addr], or an error. *) 45 | 46 | val send : flow -> Cstruct.t -> (unit,'err) io 47 | (** [send flow buffer] sends [buffer] to the [flow] upstream.*) 48 | 49 | val recv : flow -> (Cstruct.t, 'err) io 50 | (** [recv flow] tries to read a [buffer] from the [flow] downstream.*) 51 | 52 | val resolve : ('ok,'err) io -> ('ok -> ('next,'err) result) -> ('next,'err) io 53 | (** a.k.a. [>|=] *) 54 | 55 | val map : ('ok,'err) io -> ('ok -> ('next,'err) io) -> ('next,'err) io 56 | (** a.k.a. [>>=] *) 57 | 58 | val lift : ('ok, 'err) result -> ('ok,'err) io 59 | end 60 | 61 | module Make : functor (U : S) -> 62 | sig 63 | 64 | val create : ?nameserver:U.ns_addr -> U.stack -> U.t 65 | (** [create ~nameserver stack] creates the state of the DNS client. *) 66 | 67 | val nameserver : U.t -> U.ns_addr 68 | (** [nameserver t] returns the default nameserver to be used. *) 69 | 70 | val getaddrinfo : U.t -> ?nameserver:U.ns_addr -> 'response Dns.Rr_map.key -> 71 | 'a Domain_name.t -> ('response, 'err) U.io 72 | (** [getaddrinfo nameserver query_type name] is the [query_type]-dependent 73 | response from [nameserver] regarding [name], or an [Error _] message. 74 | See {!Dns_client.query_state} for more information about the 75 | result types. 76 | *) 77 | 78 | val gethostbyname : U.t -> ?nameserver:U.ns_addr -> [ `host ] Domain_name.t -> 79 | (Ipaddr.V4.t, 'err) U.io 80 | (** [gethostbyname state ~nameserver domain] is the IPv4 address of [domain] 81 | resolved via the [state] and [nameserver] specified. 82 | If the query fails, or if the [domain] does not have any IPv4 addresses, 83 | an [Error _] message is returned. 84 | Any extraneous IPv4 addresses are ignored. 85 | For an example of using this API, see [unix/ohost.ml] 86 | in the distribution of this package. 87 | *) 88 | 89 | val gethostbyname6 : U.t -> ?nameserver:U.ns_addr -> [ `host ] Domain_name.t -> 90 | (Ipaddr.V6.t, 'err) U.io 91 | (** [gethostbyname6 state ~nameserver domain] is the IPv6 address of 92 | [domain] resolved via the [state] and [nameserver] specified. 93 | 94 | It is the IPv6 equivalent of {!gethostbyname}. 95 | *) 96 | 97 | end 98 | -------------------------------------------------------------------------------- /certify/dns_certify.ml: -------------------------------------------------------------------------------- 1 | open Dns 2 | 3 | let dns_header rng = 4 | let id = Randomconv.int16 rng in 5 | (id, Packet.Flags.empty) 6 | 7 | let letsencrypt_name name = 8 | match Domain_name.(prepend_label (raw name) "_tcp") with 9 | | Ok name' -> Domain_name.prepend_label name' "_letsencrypt" 10 | | Error e -> Error e 11 | 12 | type u_err = [ `Tsig of Dns_tsig.e | `Bad_reply of Packet.mismatch * Packet.t | `Unexpected_reply of Packet.reply ] 13 | 14 | let pp_u_err ppf = function 15 | | `Tsig e -> Fmt.pf ppf "tsig error %a" Dns_tsig.pp_e e 16 | | `Bad_reply (e, res) -> Fmt.pf ppf "bad reply %a: %a" Packet.pp_mismatch e Packet.pp res 17 | | `Unexpected_reply r -> Fmt.pf ppf "unexpected reply %a" Packet.pp_reply r 18 | 19 | let nsupdate rng now ~host ~keyname ~zone dnskey csr = 20 | match letsencrypt_name host with 21 | | Error e -> Error e 22 | | Ok host -> 23 | let tlsa = 24 | { Tlsa.cert_usage = Domain_issued_certificate ; 25 | selector = Private ; 26 | matching_type = No_hash ; 27 | data = X509.Encoding.cs_of_signing_request csr ; 28 | } 29 | in 30 | let zone = Packet.Question.create zone Soa 31 | and update = 32 | let up = 33 | Domain_name.Map.singleton host 34 | [ 35 | Packet.Update.Remove (K Tlsa) ; 36 | Packet.Update.Add (B (Tlsa, (3600l, Rr_map.Tlsa_set.singleton tlsa))) 37 | ] 38 | in 39 | (Domain_name.Map.empty, up) 40 | and header = dns_header rng 41 | in 42 | let packet = Packet.create header zone (`Update update) in 43 | let now = now () in 44 | match Dns_tsig.encode_and_sign ~proto:`Tcp packet now dnskey keyname with 45 | | Error e -> Error (`Msg (Fmt.to_to_string Dns_tsig.pp_s e)) 46 | | Ok (data, mac) -> 47 | Ok (data, (fun data -> 48 | match Dns_tsig.decode_and_verify now dnskey keyname ~mac data with 49 | | Error e -> Error (`Tsig e) 50 | | Ok (res, _, _) -> 51 | match Packet.reply_matches_request ~request:packet res with 52 | | Ok `Update_ack -> Ok () 53 | | Ok r -> Error (`Unexpected_reply r) 54 | | Error e -> Error (`Bad_reply (e, res)))) 55 | 56 | type q_err = [ 57 | | `Decode of Packet.err 58 | | `Bad_reply of Packet.mismatch * Packet.t 59 | | `Unexpected_reply of Packet.reply 60 | | `No_tlsa 61 | ] 62 | 63 | let pp_q_err ppf = function 64 | | `Decode err -> Fmt.pf ppf "decoding failed %a" Packet.pp_err err 65 | | `Bad_reply (e, res) -> Fmt.pf ppf "bad reply %a: %a" Packet.pp_mismatch e Packet.pp res 66 | | `Unexpected_reply r -> Fmt.pf ppf "unexpected reply %a" Packet.pp_reply r 67 | | `No_tlsa -> Fmt.pf ppf "No TLSA record found" 68 | 69 | let query rng public_key host = 70 | match letsencrypt_name host with 71 | | Error e -> Error e 72 | | Ok host -> 73 | let good_tlsa tlsa = 74 | tlsa.Tlsa.cert_usage = Domain_issued_certificate 75 | && tlsa.selector = Full_certificate 76 | && tlsa.matching_type = No_hash 77 | in 78 | let parse tlsa = 79 | match X509.Encoding.parse tlsa.Tlsa.data with 80 | | Some cert -> 81 | let keys_equal a b = Cstruct.equal (X509.key_id a) (X509.key_id b) in 82 | if keys_equal (X509.public_key cert) public_key then 83 | Some cert 84 | else 85 | None 86 | | _ -> None 87 | in 88 | let header = dns_header rng 89 | and question = Packet.Question.create host Tlsa 90 | in 91 | let request = Packet.create header question `Query in 92 | let out, _ = Packet.encode `Tcp request 93 | and react data = 94 | match Packet.decode data with 95 | | Error e -> Error (`Decode e) 96 | | Ok reply -> 97 | match Packet.reply_matches_request ~request reply with 98 | | Ok (`Answer (answer, _)) -> 99 | begin match Name_rr_map.find host Tlsa answer with 100 | | None -> Error `No_tlsa 101 | | Some (_, tlsas) -> 102 | Rr_map.Tlsa_set.(fold (fun tlsa r -> 103 | match parse tlsa, r with Some c, _ -> Ok c | None, x -> x) 104 | (filter good_tlsa tlsas) 105 | (Error `No_tlsa)) 106 | end 107 | | Ok (`Rcode_error (Rcode.NXDomain, Opcode.Query, _)) -> Error `No_tlsa 108 | | Ok reply -> Error (`Unexpected_reply reply) 109 | | Error e -> Error (`Bad_reply (e, reply)) 110 | in 111 | Ok (out, react) 112 | -------------------------------------------------------------------------------- /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 | type operation = [ 10 | | `Update 11 | | `Transfer 12 | ] 13 | (** The type of operations. *) 14 | 15 | type a = Dns_trie.t -> proto -> ?key:[ `raw ] Domain_name.t -> operation -> zone:[ `raw ] Domain_name.t -> bool 16 | (** The authentifier function signature *) 17 | 18 | val tsig_auth : a 19 | (** [tsig_auth trie proto keyname operation zone] checks that [keyname] 20 | matches the [operation] and is in the [zone]: [foo._transfer.mirage] is 21 | valid to [`Transfer] the [mirage] zone. A key without a zone 22 | [foo._transfer] is valid for all zones! When using [tsig_auth], be aware 23 | that it does no cryptographic verification of the tsig signature! *) 24 | 25 | type t 26 | (** The type for an authenticator. *) 27 | end 28 | 29 | type t = private { 30 | data : Dns_trie.t ; 31 | auth : Authentication.t ; 32 | rng : int -> Cstruct.t ; 33 | tsig_verify : Tsig_op.verify ; 34 | tsig_sign : Tsig_op.sign ; 35 | } 36 | (** The state of a DNS server. *) 37 | 38 | val text : 'a Domain_name.t -> Dns_trie.t -> (string, [> `Msg of string ]) result 39 | (** [text name trie] results in a string representation (zonefile) of the trie. *) 40 | 41 | val handle_question : t -> Packet.Question.t -> 42 | (Packet.Flags.t * Packet.Answer.t * Name_rr_map.t option, 43 | Rcode.t * Packet.Answer.t option) result 44 | (** [handle_question t question] handles the DNS query [question] by looking 45 | it up in the trie of [t]. *) 46 | 47 | val handle_tsig : ?mac:Cstruct.t -> t -> Ptime.t -> Packet.t -> 48 | Cstruct.t -> (([ `raw ] Domain_name.t * Tsig.t * Cstruct.t * Dnskey.t) option, 49 | Tsig_op.e * Cstruct.t option) result 50 | (** [handle_tsig ~mac t now packet buffer] verifies the tsig 51 | signature if present, returning the keyname, tsig, mac, and used key. *) 52 | 53 | module Primary : sig 54 | 55 | type s 56 | (** The state of a primary DNS server. *) 57 | 58 | val server : s -> t 59 | (** [server s] is the server of the primary. *) 60 | 61 | val data : s -> Dns_trie.t 62 | (** [data s] is the data store of [s]. *) 63 | 64 | val with_data : s -> Ptime.t -> int64 -> Dns_trie.t -> s * (Ipaddr.V4.t * Cstruct.t) list 65 | (** [with_data s now ts trie] replaces the current data with [trie] in [s]. 66 | The returned notifications should be send out. *) 67 | 68 | val create : ?keys:('a Domain_name.t * Dnskey.t) list -> 69 | ?a:Authentication.a list -> ?tsig_verify:Tsig_op.verify -> 70 | ?tsig_sign:Tsig_op.sign -> rng:(int -> Cstruct.t) -> Dns_trie.t -> s 71 | (** [create ~keys ~a ~tsig_verify ~tsig_sign ~rng data] creates a primary server. *) 72 | 73 | val handle_packet : s -> Ptime.t -> int64 -> proto -> Ipaddr.V4.t -> int -> 74 | Packet.t -> 'a Domain_name.t option -> 75 | s * Packet.t option * (Ipaddr.V4.t * Cstruct.t) list * 76 | [> `Notify of Soa.t option | `Keep ] option 77 | (** [handle_packet s now ts src src_port proto key packet] handles the given 78 | [packet], returning new state, an answer, and potentially notify packets to 79 | secondary name servers. *) 80 | 81 | val handle_buf : s -> Ptime.t -> int64 -> proto -> 82 | Ipaddr.V4.t -> int -> Cstruct.t -> 83 | s * Cstruct.t option * (Ipaddr.V4.t * Cstruct.t) list * 84 | [ `Notify of Soa.t option | `Signed_notify of Soa.t option | `Keep ] option 85 | (** [handle_buf s now ts proto src src_port buffer] decodes the [buffer], 86 | processes the DNS frame using {!handle_packet}, and encodes the reply. *) 87 | 88 | val closed : s -> Ipaddr.V4.t -> s 89 | (** [closed s ip] marks the connection to [ip] closed. *) 90 | 91 | val timer : s -> Ptime.t -> int64 -> s * (Ipaddr.V4.t * Cstruct.t) list 92 | (** [timer s now ts] may encode some notify if they were not acknowledget by the 93 | other side. *) 94 | 95 | val to_be_notified : s -> [ `host ] Domain_name.t -> 96 | (Ipaddr.V4.t * [ `raw ] Domain_name.t option) list 97 | (** [to_be_notified s zone] returns a list of pairs of IP address and optional 98 | tsig key name of the servers to be notified for a zone change. This list 99 | is based on (a) NS entries for the zone, (b) registered TSIG transfer keys, 100 | and (c) active connection (which transmitted a signed SOA). *) 101 | 102 | end 103 | 104 | module Secondary : sig 105 | 106 | type s 107 | (** The state of a secondary DNS server. *) 108 | 109 | val data : s -> Dns_trie.t 110 | (** [data s] is the zone data of [s]. *) 111 | 112 | val with_data : s -> Dns_trie.t -> s 113 | (** [with_data s trie] is [s] with its data replaced by [trie]. *) 114 | 115 | val create : ?a:Authentication.a list -> ?primary:Ipaddr.V4.t -> 116 | tsig_verify:Tsig_op.verify -> tsig_sign:Tsig_op.sign -> 117 | rng:(int -> Cstruct.t) -> ('a Domain_name.t * Dnskey.t) list -> s 118 | (** [create ~a ~primary ~tsig_verify ~tsig_sign ~rng keys] creates a secondary 119 | DNS server state. *) 120 | 121 | val handle_packet : s -> Ptime.t -> int64 -> Ipaddr.V4.t -> 122 | Packet.t -> 'a Domain_name.t option -> 123 | s * Packet.t option * (proto * Ipaddr.V4.t * Cstruct.t) list 124 | (** [handle_packet s now ts ip proto key t] handles the incoming packet. *) 125 | 126 | val handle_buf : s -> Ptime.t -> int64 -> proto -> Ipaddr.V4.t -> Cstruct.t -> 127 | s * Cstruct.t option * (proto * Ipaddr.V4.t * Cstruct.t) list 128 | (** [handle_buf s now ts proto src buf] decodes [buf], processes with 129 | {!handle_packet}, and encodes the results. *) 130 | 131 | val timer : s -> Ptime.t -> int64 -> s * (proto * Ipaddr.V4.t * Cstruct.t) list 132 | (** [timer s now ts] may request SOA or retransmit AXFR. *) 133 | 134 | val closed : s -> Ptime.t -> int64 -> Ipaddr.V4.t -> 135 | s * (proto * Ipaddr.V4.t * Cstruct.t) list 136 | (** [closed s now ts ip] marks [ip] as closed. *) 137 | 138 | end 139 | -------------------------------------------------------------------------------- /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 {!Dns_name}, whereas the value may be any resource record. The 5 | representation is a tree, where the edges are domain name labels, and the 6 | nodes carry a {{!Dns_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 {!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 {!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_ns of [ `raw ] Domain_name.t 83 | | `Soa_not_a_host of [ `raw ] Domain_name.t * string ] 84 | 85 | val pp_zone_check : zone_check Fmt.t 86 | (** [pp_err ppf err] pretty prints the error [err]. *) 87 | 88 | val check : t -> (unit, zone_check) result 89 | (** [check t] checks all invariants. *) 90 | 91 | 92 | (** {2 Lookup} *) 93 | 94 | type e = [ `Delegation of [ `raw ] Domain_name.t * (int32 * Domain_name.Host_set.t) 95 | | `EmptyNonTerminal of [ `raw ] Domain_name.t * Soa.t 96 | | `NotAuthoritative 97 | | `NotFound of [ `raw ] Domain_name.t * Soa.t ] 98 | (** The type of lookup errors. *) 99 | 100 | val pp_e : e Fmt.t 101 | (** [pp_e ppf e] pretty-prints [e] on [ppf]. *) 102 | 103 | val zone : 'a Domain_name.t -> t -> 104 | ([ `raw ] Domain_name.t * Soa.t, e) result 105 | (** [zone k t] returns either the zone and soa for [k] in [t], or an error. *) 106 | 107 | val lookup_with_cname : 'a Domain_name.t -> 'b Rr_map.key -> t -> 108 | (Rr_map.b * ([ `raw ] Domain_name.t * int32 * Domain_name.Host_set.t), e) result 109 | (** [lookup_with_cname k ty t] finds [k, ty] in [t]. It either returns the found 110 | resource record set and authority information, a cname alias and authority 111 | information, or an error. *) 112 | 113 | val lookup : 'a Domain_name.t -> 'b Rr_map.key -> t -> ('b, e) result 114 | (** [lookup k ty t] finds [k, ty] in [t], which may lead to an error. *) 115 | 116 | val lookup_any : 'a Domain_name.t -> t -> 117 | (Rr_map.t * ([ `raw ] Domain_name.t * int32 * Domain_name.Host_set.t), e) result 118 | (** [lookup_any k t] looks up all resource records of [k] in [t], and returns 119 | that and the authority information. *) 120 | 121 | val lookup_glue : 'a Domain_name.t -> t -> 122 | (int32 * Rr_map.Ipv4_set.t) option * (int32 * Rr_map.Ipv6_set.t) option 123 | (** [lookup_glue k t] finds glue records (A, AAAA) for [k] in [t]. It ignores 124 | potential DNS invariants, e.g. that there is no surrounding zone. *) 125 | 126 | val entries : 'a Domain_name.t -> t -> 127 | (Dns.Soa.t * Rr_map.t Domain_name.Map.t, e) result 128 | (** [entries name t] returns either the SOA and all entries for the requested 129 | [name], or an error. *) 130 | 131 | val fold : 'a Rr_map.key -> t -> ([ `raw ] Domain_name.t -> 'a -> 'b -> 'b) -> 'b -> 'b 132 | (** [fold key t f acc] calls [f] with [dname value acc] element in [t]. *) 133 | 134 | val diff : 'a Domain_name.t -> Soa.t -> old:t -> t -> 135 | (Soa.t * [ `Empty | `Full of Name_rr_map.t | `Difference of Soa.t * Name_rr_map.t * Name_rr_map.t ], 136 | [> `Msg of string ]) result 137 | (** [diff zone soa ~old trie] computes the difference of [zone] in [old] and 138 | [trie], and returns either [`Empty] if [soa] is equal or newer than the one 139 | in [trie], [`Full] (the same as [entries]) if [zone] is not present in [old], 140 | or [`Difference (old_soa, deleted, added)]. Best used with IXFR. An error 141 | occurs if [zone] is not present in [trie]. *) 142 | -------------------------------------------------------------------------------- /mirage/resolver/dns_mirage_resolver.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Lwt.Infix 4 | 5 | let src = Logs.Src.create "dns_mirage_resolver" ~doc:"effectful DNS resolver" 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | module Make (R : Mirage_random.C) (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME : Mirage_time_lwt.S) (S : Mirage_stack_lwt.V4) = struct 9 | 10 | module Dns = Dns_mirage.Make(S) 11 | 12 | module T = S.TCPV4 13 | 14 | module FM = Map.Make(struct 15 | type t = Ipaddr.V4.t * int 16 | let compare (ip, p) (ip', p') = 17 | match Ipaddr.V4.compare ip ip' with 18 | | 0 -> compare p p' 19 | | x -> x 20 | end) 21 | 22 | let resolver stack ?(root = false) ?(timer = 500) ?(port = 53) t = 23 | (* according to RFC5452 4.5, we can chose source port between 1024-49152 *) 24 | let sport () = 1024 + Randomconv.int ~bound:48128 R.generate in 25 | let state = ref t in 26 | let tcp_in = ref FM.empty in 27 | let tcp_out = ref Dns.IM.empty in 28 | 29 | let rec client_out dst port = 30 | T.create_connection (S.tcpv4 stack) (dst, port) >|= function 31 | | Error e -> 32 | (* do i need to report this back into the resolver? what are their options then? *) 33 | Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d" 34 | T.pp_error e Ipaddr.V4.pp dst port) ; 35 | Error () 36 | | Ok flow -> 37 | Log.debug (fun m -> m "established new outgoing TCP connection to %a:%d" 38 | Ipaddr.V4.pp dst port); 39 | tcp_out := Dns.IM.add dst flow !tcp_out ; 40 | Lwt.async (fun () -> 41 | let f = Dns.of_flow flow in 42 | let rec loop () = 43 | Dns.read_tcp f >>= function 44 | | Error () -> 45 | Log.debug (fun m -> m "removing %a from tcp_out" Ipaddr.V4.pp dst) ; 46 | tcp_out := Dns.IM.remove dst !tcp_out ; 47 | Lwt.return_unit 48 | | Ok data -> 49 | let now = Ptime.v (P.now_d_ps ()) in 50 | let ts = M.elapsed_ns () in 51 | let new_state, answers, queries = 52 | Dns_resolver.handle_buf !state now ts false `Tcp dst port data 53 | in 54 | state := new_state ; 55 | Lwt_list.iter_p handle_answer answers >>= fun () -> 56 | Lwt_list.iter_p handle_query queries >>= fun () -> 57 | loop () 58 | in 59 | loop ()) ; 60 | Ok () 61 | and client_tcp dst port data = 62 | match Dns.IM.find dst !tcp_out with 63 | | None -> 64 | begin 65 | client_out dst port >>= function 66 | | Error () -> 67 | let sport = sport () in 68 | S.listen_udpv4 stack ~port:sport (udp_cb false) ; 69 | Dns.send_udp stack sport dst port data 70 | | Ok () -> client_tcp dst port data 71 | end 72 | | Some x -> 73 | Dns.send_tcp x data >>= function 74 | | Ok () -> Lwt.return_unit 75 | | Error () -> 76 | tcp_out := Dns.IM.remove dst !tcp_out ; 77 | client_tcp dst port data 78 | and maybe_tcp dst port data = 79 | (match Dns.IM.find dst !tcp_out with 80 | | Some flow -> Dns.send_tcp flow data 81 | | None -> Lwt.return (Error ())) >>= function 82 | | Ok () -> Lwt.return_unit 83 | | Error () -> 84 | let sport = sport () in 85 | S.listen_udpv4 stack ~port:sport (udp_cb false) ; 86 | Dns.send_udp stack sport dst port data 87 | and handle_query (proto, dst, data) = match proto with 88 | | `Udp -> maybe_tcp dst port data 89 | | `Tcp -> client_tcp dst port data 90 | and handle_answer (proto, dst, dst_port, data) = match proto with 91 | | `Udp -> Dns.send_udp stack port dst dst_port data 92 | | `Tcp -> match try Some (FM.find (dst, dst_port) !tcp_in) with Not_found -> None with 93 | | None -> 94 | Log.err (fun m -> m "wanted to answer %a:%d via TCP, but couldn't find a flow" 95 | Ipaddr.V4.pp dst dst_port) ; 96 | Lwt.return_unit 97 | | Some flow -> Dns.send_tcp flow data >|= function 98 | | Ok () -> () 99 | | Error () -> tcp_in := FM.remove (dst, dst_port) !tcp_in 100 | and udp_cb req ~src ~dst:_ ~src_port buf = 101 | let now = Ptime.v (P.now_d_ps ()) 102 | and ts = M.elapsed_ns () 103 | in 104 | let new_state, answers, queries = 105 | Dns_resolver.handle_buf !state now ts req `Udp src src_port buf 106 | in 107 | state := new_state ; 108 | Lwt_list.iter_p handle_answer answers >>= fun () -> 109 | Lwt_list.iter_p handle_query queries 110 | in 111 | S.listen_udpv4 stack ~port (udp_cb true) ; 112 | Log.app (fun f -> f "DNS resolver listening on UDP port %d" port); 113 | 114 | let tcp_cb query flow = 115 | let dst_ip, dst_port = T.dst flow in 116 | Log.info (fun m -> m "tcp connection from %a:%d" Ipaddr.V4.pp dst_ip dst_port) ; 117 | tcp_in := FM.add (dst_ip, dst_port) flow !tcp_in ; 118 | let f = Dns.of_flow flow in 119 | let rec loop () = 120 | Dns.read_tcp f >>= function 121 | | Error () -> 122 | tcp_in := FM.remove (dst_ip, dst_port) !tcp_in ; 123 | Lwt.return_unit 124 | | Ok data -> 125 | let now = Ptime.v (P.now_d_ps ()) in 126 | let ts = M.elapsed_ns () in 127 | let new_state, answers, queries = 128 | Dns_resolver.handle_buf !state now ts query `Tcp dst_ip dst_port data 129 | in 130 | state := new_state ; 131 | Lwt_list.iter_p handle_answer answers >>= fun () -> 132 | Lwt_list.iter_p handle_query queries >>= fun () -> 133 | loop () 134 | in 135 | loop () 136 | in 137 | S.listen_tcpv4 stack ~port (tcp_cb true) ; 138 | Log.info (fun m -> m "DNS resolver listening on TCP port %d" port) ; 139 | 140 | let rec stats_reporter () = 141 | Dns_resolver.stats !state ; 142 | TIME.sleep_ns (Duration.of_min 5) >>= fun () -> 143 | stats_reporter () 144 | in 145 | Lwt.async stats_reporter ; 146 | 147 | let rec time () = 148 | let new_state, answers, queries = 149 | Dns_resolver.timer !state (M.elapsed_ns ()) 150 | in 151 | state := new_state ; 152 | Lwt_list.iter_p handle_answer answers >>= fun () -> 153 | Lwt_list.iter_p handle_query queries >>= fun () -> 154 | TIME.sleep_ns (Duration.of_ms timer) >>= fun () -> 155 | time () 156 | in 157 | Lwt.async time ; 158 | 159 | if root then 160 | let rec root () = 161 | let new_state, q = Dns_resolver.query_root !state (M.elapsed_ns ()) `Tcp in 162 | state := new_state ; 163 | handle_query q >>= fun () -> 164 | TIME.sleep_ns (Duration.of_day 6) >>= fun () -> 165 | root () 166 | in 167 | Lwt.async root 168 | end 169 | -------------------------------------------------------------------------------- /app/ocertify.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | open Rresult.R.Infix 3 | 4 | let find_or_generate_key key_filename bits seed = 5 | Bos.OS.File.exists key_filename >>= function 6 | | true -> 7 | Bos.OS.File.read key_filename >>= fun data -> 8 | (try Ok (X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string data)) with 9 | | _ -> Error (`Msg "while parsing private key file")) 10 | | false -> 11 | let key = 12 | let g = 13 | match seed with 14 | | None -> None 15 | | Some seed -> 16 | let seed = Cstruct.of_string seed in 17 | Some Nocrypto.Rng.(create ~seed (module Generators.Fortuna)) 18 | in 19 | `RSA (Nocrypto.Rsa.generate ?g bits) 20 | in 21 | let pem = X509.Encoding.Pem.Private_key.to_pem_cstruct1 key in 22 | Bos.OS.File.write ~mode:0o600 key_filename (Cstruct.to_string pem) >>= fun () -> 23 | Ok key 24 | 25 | let query_certificate sock public_key fqdn = 26 | match Dns_certify.query Nocrypto.Rng.generate public_key fqdn with 27 | | Error e -> Error e 28 | | Ok (out, cb) -> 29 | Dns_cli.send_tcp sock out; 30 | let data = Dns_cli.recv_tcp sock in 31 | cb data 32 | 33 | let nsupdate_csr sock host keyname zone dnskey csr = 34 | match Dns_certify.nsupdate Nocrypto.Rng.generate Ptime_clock.now ~host ~keyname ~zone dnskey csr with 35 | | Error s -> Error s 36 | | Ok (out, cb) -> 37 | Dns_cli.send_tcp sock out; 38 | let data = Dns_cli.recv_tcp sock in 39 | match cb data with 40 | | Ok () -> Ok () 41 | | Error e -> Error (`Msg (Fmt.strf "nsupdate reply error %a" Dns_certify.pp_u_err e)) 42 | 43 | let jump _ server_ip port (keyname, zone, dnskey) hostname csr key seed bits cert force = 44 | Nocrypto_entropy_unix.initialize (); 45 | let fn suffix = function 46 | | None -> Fpath.(v (Domain_name.to_string hostname) + suffix) 47 | | Some x -> Fpath.v x 48 | in 49 | let csr_filename = fn "req" csr 50 | and key_filename = fn "key" key 51 | and cert_filename = fn "pem" cert 52 | in 53 | (Bos.OS.File.exists csr_filename >>= function 54 | | true -> 55 | Bos.OS.File.read csr_filename >>= fun data -> 56 | (try Ok (X509.Encoding.Pem.Certificate_signing_request.of_pem_cstruct1 (Cstruct.of_string data)) with 57 | | _ -> Error (`Msg "while parsing certificate signing request")) 58 | | false -> 59 | find_or_generate_key key_filename bits seed >>= fun key -> 60 | let req = X509.CA.request [ `CN (Domain_name.to_string hostname) ] key in 61 | let pem = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 req in 62 | Bos.OS.File.write csr_filename (Cstruct.to_string pem) >>= fun () -> 63 | Ok req) >>= fun req -> 64 | let public_key = (X509.CA.info req).X509.CA.public_key in 65 | (* before doing anything, let's check whether cert_filename is present, matches public key, and is valid *) 66 | let tomorrow = 67 | let (d, ps) = Ptime_clock.now_d_ps () in 68 | Ptime.v (succ d, ps) 69 | in 70 | (Bos.OS.File.exists cert_filename >>= function 71 | | true -> 72 | Bos.OS.File.read cert_filename >>= fun data -> 73 | (try Ok (Some (X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string data))) with 74 | | _ -> Error (`Msg "while parsing certificate")) 75 | | false -> Ok None) >>= (function 76 | | Some cert when not force 77 | && Cstruct.equal (X509.key_id (X509.public_key cert)) (X509.key_id public_key) 78 | && Ptime.is_later (snd (X509.validity cert)) ~than:tomorrow -> 79 | Error (`Msg "valid certificate with matching key already present") 80 | | _ -> Ok ()) >>= fun () -> 81 | (* strategy: unless force is provided, we can request DNS, and if a 82 | certificate is present, compare its public key with csr public key *) 83 | let write_certificate cert = 84 | let cert = X509.Encoding.Pem.Certificate.to_pem_cstruct1 cert in 85 | Bos.OS.File.delete cert_filename >>= fun () -> 86 | Bos.OS.File.write cert_filename (Cstruct.to_string cert) 87 | in 88 | let sock = Dns_cli.connect_tcp server_ip port in 89 | (if force then 90 | Ok true 91 | else match query_certificate sock public_key hostname with 92 | | Ok x -> 93 | Logs.app (fun m -> m "found cached certificate in DNS"); 94 | write_certificate x >>| fun () -> 95 | false 96 | | Error `No_tlsa -> 97 | Logs.debug (fun m -> m "no TLSA found, sending update"); 98 | Ok true 99 | | Error (`Msg m) -> Error (`Msg m) 100 | | Error ((`Decode _ | `Bad_reply _ | `Unexpected_reply _) as e) -> 101 | Error (`Msg (Fmt.strf "error %a while parsing TLSA reply" Dns_certify.pp_q_err e))) 102 | >>= fun send_update -> 103 | if send_update then 104 | nsupdate_csr sock hostname keyname zone dnskey req >>= fun () -> 105 | let rec request retries = 106 | if retries = 0 then 107 | Error (`Msg "failed to request certificate") 108 | else 109 | match query_certificate sock public_key hostname with 110 | | Error `No_tlsa -> 111 | Logs.warn (fun m -> m "still no tlsa, sleeping two more seconds"); 112 | Unix.sleep 2; 113 | request (pred retries) 114 | | Error (`Msg msg) -> 115 | Logs.err (fun m -> m "error %s" msg); 116 | Error (`Msg msg) 117 | | Error ((`Decode _ | `Bad_reply _ | `Unexpected_reply _) as e) -> 118 | Logs.err (fun m -> m "error %a while handling TLSA reply (retrying anyways)" Dns_certify.pp_q_err e); 119 | request (pred retries) 120 | | Ok x -> write_certificate x 121 | in 122 | request 10 123 | else 124 | Ok () 125 | 126 | open Cmdliner 127 | 128 | let dns_server = 129 | let doc = "DNS server IP" in 130 | Arg.(required & pos 0 (some Dns_cli.ip_c) None & info [] ~doc ~docv:"IP") 131 | 132 | let port = 133 | let doc = "Port to connect to" in 134 | Arg.(value & opt int 53 & info [ "port" ] ~doc) 135 | 136 | let dns_key = 137 | let doc = "nsupdate key (name:alg:b64key, where name is YYY._update.zone)" in 138 | Arg.(required & pos 1 (some Dns_cli.namekey_c) None & info [] ~doc ~docv:"KEY") 139 | 140 | let hostname = 141 | let doc = "Hostname (FQDN) to issue a certificate for" in 142 | Arg.(required & pos 2 (some Dns_cli.name_c) None & info [] ~doc ~docv:"HOSTNAME") 143 | 144 | let csr = 145 | let doc = "certificate signing request filename (defaults to hostname.req)" in 146 | Arg.(value & opt (some string) None & info [ "csr" ] ~doc) 147 | 148 | let key = 149 | let doc = "private key filename (default to hostname.key)" in 150 | Arg.(value & opt (some string) None & info [ "key" ] ~doc) 151 | 152 | let seed = 153 | let doc = "private key seed" in 154 | Arg.(value & opt (some string) None & info [ "seed" ] ~doc) 155 | 156 | let bits = 157 | let doc = "private key bits" in 158 | Arg.(value & opt int 4096 & info [ "bits" ] ~doc) 159 | 160 | let cert = 161 | let doc = "certificate filename (defaults to hostname.pem)" in 162 | Arg.(value & opt (some string) None & info [ "certificate" ] ~doc) 163 | 164 | let force = 165 | let doc = "force signing request to DNS" in 166 | Arg.(value & flag & info [ "force" ] ~doc) 167 | 168 | let ocertify = 169 | let doc = "ocertify requests a signed certificate" in 170 | let man = [ `S "BUGS"; `P "Submit bugs to me";] in 171 | Term.(term_result (const jump $ Dns_cli.setup_log $ dns_server $ port $ dns_key $ hostname $ csr $ key $ seed $ bits $ cert $ force)), 172 | Term.info "ocertify" ~version:"%%VERSION_NUM%%" ~doc ~man 173 | 174 | let () = match Term.eval ocertify with `Ok () -> exit 0 | _ -> exit 1 175 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # µDNS - an opinionated Domain Name System (DNS) library 2 | 3 | [![Build Status](https://travis-ci.org/roburio/udns.svg?branch=master)](https://travis-ci.org/roburio/udns) 4 | 5 | (c) 2017-2019 Hannes Mehnert (robur.io, Center for the Cultivation of Technology) 6 | 7 | %%VERSION%% 8 | 9 | µDNS supports most of the domain name system used in the wild. It adheres to 10 | strict conventions. Failing early and hard. It is mostly implemented in the 11 | pure fragment of OCaml (no mutation, isolated IO, no exceptions). 12 | 13 | It all started out as an experiment to run a recursive resolver, but after 14 | initial prototypes it turned out that every configurable recursive resolver 15 | needs a fully-fledged authoritative nameserver as well (for overriding various 16 | zones such as `.localhost` and reverse lookups of RFC 1918 IP ranges). 17 | 18 | Legacy resource record types are not dealt with, and there is no plan to support 19 | `ISDN`, `MAILA`, `MAILB`, `WKS`, `MB`, `NULL`, `HINFO`, ... . `AXFR`, `IXFR`, 20 | and `UPDATE` is only handled via TCP connections. The only resource class 21 | supported is `IN` (the Internet). In a similar vein, wildcard records are _not_ 22 | supported, and it is unlikely they'll ever be in this library. Truncated hmac 23 | in `TSIG` are not supported (always the full length of the hash algorithm is 24 | used). 25 | 26 | Please read [the blog article](https://hannes.nqsb.io/Posts/DNS) for a more 27 | detailed overview. 28 | 29 | The µDNS library is published under the 2 clause BSD license. 30 | 31 | ## Supported RFCs 32 | 33 | * [RFC 1034](https://tools.ietf.org/html/rfc1034) Domain Names - Concepts and Facilities 34 | * [RFC 1035](https://tools.ietf.org/html/rfc1035) Domain Names - Implementation and Specification 35 | * [RFC 1912](https://tools.ietf.org/html/rfc1912) Common DNS Operational and Configuration Errors 36 | * [RFC 1995](https://tools.ietf.org/html/rfc1995) Incremental Zone Transfer in DNS 37 | * [RFC 1996](https://tools.ietf.org/html/rfc1996) A Mechanism for Prompt Notification of Zone Changes (DNS NOTIFY) 38 | * [RFC 2136](https://tools.ietf.org/html/rfc2136) Dynamic Updates in the domain name system (DNS UPDATE) 39 | * [RFC 2181](https://tools.ietf.org/html/rfc2181) Clarifications to the DNS Specification 40 | * [RFC 2308](https://tools.ietf.org/html/rfc2308) Negative Caching of DNS Queries (DNS NCACHE) 41 | * [RFC 2782](https://tools.ietf.org/html/rfc2782) A DNS RR for specifying the location of services (DNS SRV) 42 | * [RFC 2845](https://tools.ietf.org/html/rfc2845) Secret Key Transaction Authentication for DNS (TSIG) 43 | * [RFC 3596](https://tools.ietf.org/html/rfc3596) DNS Extensions to Support IP Version 6 44 | * [RFC 4034](https://tools.ietf.org/html/rfc4034) Resource Records 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 4635](https://tools.ietf.org/html/rfc4635) HMAC SHA TSIG Algorithm Identifiers 48 | * `*` [RFC 5001](https://tools.ietf.org/html/rfc5001) DNS Name Server Identifier (NSID) Option 49 | * [RFC 5358](https://tools.ietf.org/html/rfc5358) Preventing Use of Recursive Nameservers in Reflector Attacks 50 | * [RFC 5452](https://tools.ietf.org/html/rfc5452) Measures for Making DNS More Resilient against Forged Answers 51 | * [RFC 5936](https://tools.ietf.org/html/rfc5936) DNS Zone Transfer Protocol (AXFR) 52 | * [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 53 | * [RFC 6698](https://tools.ietf.org/html/rfc6698.html) The DNS-Based Authentication of Named Entities (DANE) Transport Layer Security (TLS) Protocol: TLSA 54 | * [RFC 6761](https://tools.ietf.org/html/rfc6761) Special-Use Domain Names 55 | * `*` [RFC 6762](https://tools.ietf.org/html/rfc6762) Multicast DNS 56 | * [RFC 6844](https://tools.ietf.org/html/rfc6844) DNS Certification Authority Authorization (CAA) Resource Record 57 | * [RFC 6890](https://tools.ietf.org/html/rfc6890) Special-Purpose IP Address Registries 58 | * [RFC 6891](https://tools.ietf.org/html/rfc6891) Extension Mechanisms for DNS (EDNS(0)) 59 | * [RFC 6895](https://tools.ietf.org/html/rfc6895) Domain Name System (DNS) IANA Considerations (BCP 42) 60 | * [RFC 7479](https://tools.ietf.org/html/rfc7479) Using Ed25519 in SSHFP Resource Records 61 | * [RFC 7626](https://tools.ietf.org/html/rfc7626) DNS Privacy Considerations 62 | * [RFC 7766](https://tools.ietf.org/html/rfc7766) DNS Transport over TCP - Implementation Requirements 63 | * [RFC 7816](https://tools.ietf.org/html/rfc7816) DNS Query Name Minimisation to Improve Privacy 64 | * `*` [RFC 7828](https://tools.ietf.org/html/rfc7828) The edns-tcp-keepalive EDNS0 Option 65 | * `*` [RFC 7830](https://tools.ietf.org/html/rfc7830) The EDNS(0) Padding Option 66 | * `*` [RFC 7873](https://tools.ietf.org/html/rfc7873) Domain Name System (DNS) Cookies 67 | * [RFC 8109](https://tools.ietf.org/html/rfc8109) Initializing a DNS Resolver with Priming Queries 68 | * [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. 69 | 70 | `*`: Please note that the RFCs marked with `*` are only partially implemented 71 | (i.e. only wire format, but no logic handling the feature). 72 | 73 | ## Installation 74 | 75 | You first need to install [OCaml](https://ocaml.org) (at least 4.04.0) and 76 | [opam](https://opam.ocaml.org), the OCaml package manager (at least 2.0.0) on 77 | your machine (you can use opam to install an up-to-date OCaml (`opam switch 78 | 4.07.1`)). 79 | 80 | You may want to follow the [mirage installation 81 | instructions](https://mirage.io/wiki/install) to get `mirage` installed on your 82 | computer. 83 | 84 | To lower the amount of run-time dependencies for each individual functionality, 85 | the library is split across a number of opam packages. 86 | 87 | µDNS is not released yet, but you can install it and its dependencies via opam, 88 | see [Development](#Development). 89 | 90 | Now the µDNS library is installed, and you can try out the examples. Find some 91 | examples at the [unikernel repository](https://github.com/roburio/unikernels). 92 | 93 | ## Documentation 94 | 95 | API documentation [is available online](https://roburio.github.io/udns/doc/). 96 | 97 | ## Development 98 | 99 | To work with the [opam](https://opam.ocaml.org/) packages provided when 100 | developing modifications to µDNS, or when pinning a specific version, 101 | you will have to pin the same *version* for all of them: 102 | 103 | ```csh 104 | : csh syntax 105 | set version=2.0.0 106 | 107 | set repo=git+https://github.com/roburio/udns.git 108 | 109 | # the -y parameter means "force" or 110 | # "do go ahead and register a new package" 111 | 112 | # the -n parameter means 113 | # "just register the pin, don't actually install it yet" 114 | 115 | foreach pkg ( dns dns-{certify,cli,client{,-lwt,-unix}} \ 116 | dns-mirage{,-certify,-client,-resolver,-server} \ 117 | dns-{resolver,server,tsig,zone} ) 118 | opam pin add -y -n $pkg.$version --dev $repo 119 | end 120 | ``` 121 | 122 | ```bash 123 | : bash syntax 124 | version=2.0.0 125 | repo=git+https://github.com/roburio/udns.git 126 | 127 | for pkg in dns dns-{certify,cli,client{,-lwt,-unix}} \ 128 | dns-mirage{,-certify,-client,-resolver,-server} \ 129 | dns-{resolver,server,tsig,zone} 130 | do 131 | opam pin add -y -n $pkg.$version --dev $repo 132 | done 133 | ``` 134 | 135 | Now you can install the packages you need, for instance: 136 | ```shell 137 | opam install dns-client-lwt 138 | ``` 139 | or 140 | ```shell 141 | opam install dns-resolver 142 | ``` -------------------------------------------------------------------------------- /tsig/dns_tsig.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Rresult.R.Infix 4 | 5 | open Dns 6 | 7 | let src = Logs.Src.create "dns_tsig" ~doc:"DNS tsig" 8 | module Log = (val Logs.src_log src : Logs.LOG) 9 | 10 | let algorithm_to_nc = function 11 | | Tsig.SHA1 -> `SHA1 12 | | Tsig.SHA224 -> `SHA224 13 | | Tsig.SHA256 -> `SHA256 14 | | Tsig.SHA384 -> `SHA384 15 | | Tsig.SHA512 -> `SHA512 16 | 17 | let compute_tsig name tsig ~key buf = 18 | let raw_name = Domain_name.raw name in 19 | let h = algorithm_to_nc tsig.Tsig.algorithm 20 | and data = Tsig.encode_raw raw_name tsig 21 | in 22 | Nocrypto.Hash.mac h ~key (Cstruct.append buf data) 23 | 24 | let guard p err = if p then Ok () else Error err 25 | 26 | (* TODO: should name compression be done? atm it's convenient not to do it *) 27 | let add_tsig ?max_size name tsig buf = 28 | Cstruct.BE.set_uint16 buf 10 (succ (Cstruct.BE.get_uint16 buf 10)) ; 29 | let tsig = Tsig.encode_full name tsig in 30 | match max_size with 31 | | Some x when x - Cstruct.len buf < Cstruct.len tsig -> None 32 | | _ -> Some (Cstruct.(append buf tsig)) 33 | 34 | let mac_to_prep = function 35 | | None -> Cstruct.create 0 36 | | Some mac -> 37 | let l = Cstruct.create 2 in 38 | Cstruct.BE.set_uint16 l 0 (Cstruct.len mac) ; 39 | Cstruct.append l mac 40 | 41 | let sign ?mac ?max_size name tsig ~key p buf = 42 | match Nocrypto.Base64.decode key.Dnskey.key with 43 | | None -> None 44 | | Some key -> 45 | let prep = mac_to_prep mac in 46 | let mac = compute_tsig name tsig ~key (Cstruct.append prep buf) in 47 | let tsig = Tsig.with_mac tsig mac in 48 | (* RFC2845 Sec 3.1: if TSIG leads to truncation, alter message: 49 | - header stays (truncated = true)! 50 | - only question is preserved 51 | - _one_ additional, the TSIG itself *) 52 | match add_tsig ?max_size name tsig buf with 53 | | Some out -> Some (out, mac) 54 | | None -> 55 | match p.Packet.data with 56 | | #Packet.request -> 57 | Log.err (fun m -> m "dns_tsig sign: truncated, is a request, not doing anything") ; 58 | None 59 | | #Packet.reply as r -> 60 | Log.err (fun m -> m "dns_tsig sign: truncated reply %a, sending tsig error" 61 | Packet.pp_reply r) ; 62 | let header = 63 | fst p.header, Packet.Flags.add `Truncation (snd p.header) 64 | in 65 | let rc = Packet.rcode_data r 66 | and op = Packet.opcode_data r 67 | in 68 | let p' = Packet.create header p.question (`Rcode_error (rc, op, None)) in 69 | let new_buf, off = Packet.encode `Udp p' in 70 | let tbs = Cstruct.sub new_buf 0 off in 71 | let mac = compute_tsig name tsig ~key (Cstruct.append prep tbs) in 72 | let tsig = Tsig.with_mac tsig mac in 73 | match add_tsig name tsig new_buf with 74 | | None -> 75 | Log.err (fun m -> m "dns_tsig sign failed query %a with tsig %a too big (max_size %a) truncated packet %a:@.%a" 76 | Packet.pp p Tsig.pp tsig Packet.pp p' 77 | Fmt.(option ~none:(unit "none") int) max_size 78 | Cstruct.hexdump_pp new_buf) ; 79 | None 80 | | Some out -> Some (out, mac) 81 | 82 | let verify_raw ?mac now name ~key tsig tbs = 83 | let name = Domain_name.raw name in 84 | Rresult.R.of_option ~none:(fun () -> Error (`Bad_key (name, tsig))) 85 | (Nocrypto.Base64.decode key.Dnskey.key) >>= fun priv -> 86 | let ac = Cstruct.BE.get_uint16 tbs 10 in 87 | Cstruct.BE.set_uint16 tbs 10 (pred ac) ; 88 | let prep = mac_to_prep mac in 89 | let computed = compute_tsig name tsig ~key:priv (Cstruct.append prep tbs) in 90 | let mac = tsig.Tsig.mac in 91 | guard (Cstruct.len mac = Cstruct.len computed) (`Bad_truncation (name, tsig)) >>= fun () -> 92 | guard (Cstruct.equal computed mac) (`Invalid_mac (name, tsig)) >>= fun () -> 93 | guard (Tsig.valid_time now tsig) (`Bad_timestamp (name, tsig, key)) >>= fun () -> 94 | Rresult.R.of_option ~none:(fun () -> Error (`Bad_timestamp (name, tsig, key))) 95 | (Tsig.with_signed tsig now) >>| fun tsig -> 96 | tsig, mac 97 | 98 | let verify ?mac now p name ?key tsig tbs = 99 | let raw_name = Domain_name.raw name in 100 | match 101 | Rresult.R.of_option ~none:(fun () -> Error (`Bad_key (raw_name, tsig))) key >>= fun key -> 102 | verify_raw ?mac now raw_name ~key tsig tbs >>= fun (tsig, mac) -> 103 | Ok (tsig, mac, key) 104 | with 105 | | Ok x -> Ok x 106 | | Error e -> 107 | Log.err (fun m -> m "error %a while verifying %a" Tsig_op.pp_e e Packet.pp p); 108 | let answer = match p.Packet.data with 109 | | #Packet.reply -> None 110 | | #Packet.request as r -> 111 | (* now we prepare a reply for the request! *) 112 | (* TODO not clear which flags to preserve *) 113 | let header = fst p.Packet.header, Packet.Flags.empty 114 | and opcode = Packet.opcode_data r 115 | in 116 | (* TODO: edns *) 117 | let answer = Packet.create header p.question (`Rcode_error (Rcode.NotAuth, opcode, None)) in 118 | let err, max_size = Packet.encode `Udp answer in 119 | let or_err f err = match f err with None -> Some err | Some x -> Some x in 120 | match e with 121 | | `Bad_key (name, tsig) -> 122 | let tsig = Tsig.with_error (Tsig.with_mac tsig Cstruct.empty) Rcode.BadKey in 123 | or_err (add_tsig ~max_size name tsig) err 124 | | `Invalid_mac (name, tsig) -> 125 | let tsig = Tsig.with_error (Tsig.with_mac tsig Cstruct.empty) Rcode.BadVersOrSig in 126 | or_err (add_tsig ~max_size name tsig) err 127 | | `Bad_truncation (name, tsig) -> 128 | let tsig = Tsig.with_error (Tsig.with_mac tsig (Cstruct.create 0)) Rcode.BadTrunc in 129 | or_err (add_tsig ~max_size name tsig) err 130 | | `Bad_timestamp (name, tsig, key) -> 131 | let tsig = Tsig.with_error tsig Rcode.BadTime in 132 | match Tsig.with_other tsig (Some now) with 133 | | None -> Some err 134 | | Some tsig -> 135 | match sign ~max_size ~mac:tsig.Tsig.mac name tsig ~key answer err with 136 | | None -> Some err 137 | | Some (buf, _) -> Some buf 138 | in 139 | Error (e, answer) 140 | 141 | type s = [ `Key_algorithm of Dnskey.t | `Tsig_creation | `Sign ] 142 | 143 | let pp_s ppf = function 144 | | `Key_algorithm key -> Fmt.pf ppf "algorithm %a not supported for tsig" Dnskey.pp key 145 | | `Tsig_creation -> Fmt.pf ppf "failed to create tsig" 146 | | `Sign -> Fmt.pf ppf "failed to sign" 147 | 148 | let encode_and_sign ?(proto = `Udp) p now key keyname = 149 | let b, _ = Packet.encode proto p in 150 | match Tsig.dnskey_to_tsig_algo key with 151 | | Error _ -> Error (`Key_algorithm key) 152 | | Ok algorithm -> match Tsig.tsig ~algorithm ~signed:now () with 153 | | None -> Error `Tsig_creation 154 | | Some tsig -> match sign (Domain_name.raw keyname) ~key tsig p b with 155 | | None -> Error `Sign 156 | | Some r -> Ok r 157 | 158 | type e = [ 159 | | `Decode of Packet.err 160 | | `Unsigned of Packet.t 161 | | `Crypto of Tsig_op.e 162 | | `Invalid_key of [ `raw ] Domain_name.t * [ `raw ] Domain_name.t 163 | ] 164 | 165 | let pp_e ppf = function 166 | | `Decode err -> Fmt.pf ppf "decode %a" Packet.pp_err err 167 | | `Unsigned res -> Fmt.pf ppf "unsigned %a" Packet.pp res 168 | | `Crypto c -> Fmt.pf ppf "crypto %a" Tsig_op.pp_e c 169 | | `Invalid_key (key, used) -> 170 | Fmt.pf ppf "invalid key, expected %a, but %a was used" 171 | Domain_name.pp key Domain_name.pp used 172 | 173 | let decode_and_verify now key keyname ?mac buf = 174 | let raw_keyname = Domain_name.raw keyname in 175 | match Packet.decode buf with 176 | | Error e -> Error (`Decode e) 177 | | Ok ({ Packet.tsig = None ; _ } as res) -> Error (`Unsigned res) 178 | | Ok ({ Packet.tsig = Some (name, tsig, tsig_off) ; _ } as res) when Domain_name.equal keyname name -> 179 | begin match verify_raw ?mac now raw_keyname ~key tsig (Cstruct.sub buf 0 tsig_off) with 180 | | Ok (_, mac) -> Ok (res, tsig, mac) 181 | | Error e -> Error (`Crypto e) 182 | end 183 | | Ok { Packet.tsig = Some (name, _, _) ; _ } -> Error (`Invalid_key (raw_keyname, name)) 184 | -------------------------------------------------------------------------------- /mirage/certify/dns_mirage_certify.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Lwt.Infix 4 | 5 | let src = Logs.Src.create "dns_mirage_resolver" ~doc:"effectful DNS certify" 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | module Make (R : Mirage_random.C) (P : Mirage_clock_lwt.PCLOCK) (TIME : Mirage_time_lwt.S) (S : Mirage_stack_lwt.V4) = struct 9 | 10 | module D = Dns_mirage.Make(S) 11 | 12 | let staging = {|-----BEGIN CERTIFICATE----- 13 | MIIEqzCCApOgAwIBAgIRAIvhKg5ZRO08VGQx8JdhT+UwDQYJKoZIhvcNAQELBQAw 14 | GjEYMBYGA1UEAwwPRmFrZSBMRSBSb290IFgxMB4XDTE2MDUyMzIyMDc1OVoXDTM2 15 | MDUyMzIyMDc1OVowIjEgMB4GA1UEAwwXRmFrZSBMRSBJbnRlcm1lZGlhdGUgWDEw 16 | ggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDtWKySDn7rWZc5ggjz3ZB0 17 | 8jO4xti3uzINfD5sQ7Lj7hzetUT+wQob+iXSZkhnvx+IvdbXF5/yt8aWPpUKnPym 18 | oLxsYiI5gQBLxNDzIec0OIaflWqAr29m7J8+NNtApEN8nZFnf3bhehZW7AxmS1m0 19 | ZnSsdHw0Fw+bgixPg2MQ9k9oefFeqa+7Kqdlz5bbrUYV2volxhDFtnI4Mh8BiWCN 20 | xDH1Hizq+GKCcHsinDZWurCqder/afJBnQs+SBSL6MVApHt+d35zjBD92fO2Je56 21 | dhMfzCgOKXeJ340WhW3TjD1zqLZXeaCyUNRnfOmWZV8nEhtHOFbUCU7r/KkjMZO9 22 | AgMBAAGjgeMwgeAwDgYDVR0PAQH/BAQDAgGGMBIGA1UdEwEB/wQIMAYBAf8CAQAw 23 | HQYDVR0OBBYEFMDMA0a5WCDMXHJw8+EuyyCm9Wg6MHoGCCsGAQUFBwEBBG4wbDA0 24 | BggrBgEFBQcwAYYoaHR0cDovL29jc3Auc3RnLXJvb3QteDEubGV0c2VuY3J5cHQu 25 | b3JnLzA0BggrBgEFBQcwAoYoaHR0cDovL2NlcnQuc3RnLXJvb3QteDEubGV0c2Vu 26 | Y3J5cHQub3JnLzAfBgNVHSMEGDAWgBTBJnSkikSg5vogKNhcI5pFiBh54DANBgkq 27 | hkiG9w0BAQsFAAOCAgEABYSu4Il+fI0MYU42OTmEj+1HqQ5DvyAeyCA6sGuZdwjF 28 | UGeVOv3NnLyfofuUOjEbY5irFCDtnv+0ckukUZN9lz4Q2YjWGUpW4TTu3ieTsaC9 29 | AFvCSgNHJyWSVtWvB5XDxsqawl1KzHzzwr132bF2rtGtazSqVqK9E07sGHMCf+zp 30 | DQVDVVGtqZPHwX3KqUtefE621b8RI6VCl4oD30Olf8pjuzG4JKBFRFclzLRjo/h7 31 | IkkfjZ8wDa7faOjVXx6n+eUQ29cIMCzr8/rNWHS9pYGGQKJiY2xmVC9h12H99Xyf 32 | zWE9vb5zKP3MVG6neX1hSdo7PEAb9fqRhHkqVsqUvJlIRmvXvVKTwNCP3eCjRCCI 33 | PTAvjV+4ni786iXwwFYNz8l3PmPLCyQXWGohnJ8iBm+5nk7O2ynaPVW0U2W+pt2w 34 | SVuvdDM5zGv2f9ltNWUiYZHJ1mmO97jSY/6YfdOUH66iRtQtDkHBRdkNBsMbD+Em 35 | 2TgBldtHNSJBfB3pm9FblgOcJ0FSWcUDWJ7vO0+NTXlgrRofRT6pVywzxVo6dND0 36 | WzYlTWeUVsO40xJqhgUQRER9YLOLxJ0O6C8i0xFxAMKOtSdodMB3RIwt7RFQ0uyt 37 | n5Z5MqkYhlMI3J1tPRTp1nEt9fyGspBOO05gi148Qasp+3N+svqKomoQglNoAxU= 38 | -----END CERTIFICATE-----|} 39 | 40 | let production = {|-----BEGIN CERTIFICATE----- 41 | MIIEkjCCA3qgAwIBAgIQCgFBQgAAAVOFc2oLheynCDANBgkqhkiG9w0BAQsFADA/ 42 | MSQwIgYDVQQKExtEaWdpdGFsIFNpZ25hdHVyZSBUcnVzdCBDby4xFzAVBgNVBAMT 43 | DkRTVCBSb290IENBIFgzMB4XDTE2MDMxNzE2NDA0NloXDTIxMDMxNzE2NDA0Nlow 44 | SjELMAkGA1UEBhMCVVMxFjAUBgNVBAoTDUxldCdzIEVuY3J5cHQxIzAhBgNVBAMT 45 | GkxldCdzIEVuY3J5cHQgQXV0aG9yaXR5IFgzMIIBIjANBgkqhkiG9w0BAQEFAAOC 46 | AQ8AMIIBCgKCAQEAnNMM8FrlLke3cl03g7NoYzDq1zUmGSXhvb418XCSL7e4S0EF 47 | q6meNQhY7LEqxGiHC6PjdeTm86dicbp5gWAf15Gan/PQeGdxyGkOlZHP/uaZ6WA8 48 | SMx+yk13EiSdRxta67nsHjcAHJyse6cF6s5K671B5TaYucv9bTyWaN8jKkKQDIZ0 49 | Z8h/pZq4UmEUEz9l6YKHy9v6Dlb2honzhT+Xhq+w3Brvaw2VFn3EK6BlspkENnWA 50 | a6xK8xuQSXgvopZPKiAlKQTGdMDQMc2PMTiVFrqoM7hD8bEfwzB/onkxEz0tNvjj 51 | /PIzark5McWvxI0NHWQWM6r6hCm21AvA2H3DkwIDAQABo4IBfTCCAXkwEgYDVR0T 52 | AQH/BAgwBgEB/wIBADAOBgNVHQ8BAf8EBAMCAYYwfwYIKwYBBQUHAQEEczBxMDIG 53 | CCsGAQUFBzABhiZodHRwOi8vaXNyZy50cnVzdGlkLm9jc3AuaWRlbnRydXN0LmNv 54 | bTA7BggrBgEFBQcwAoYvaHR0cDovL2FwcHMuaWRlbnRydXN0LmNvbS9yb290cy9k 55 | c3Ryb290Y2F4My5wN2MwHwYDVR0jBBgwFoAUxKexpHsscfrb4UuQdf/EFWCFiRAw 56 | VAYDVR0gBE0wSzAIBgZngQwBAgEwPwYLKwYBBAGC3xMBAQEwMDAuBggrBgEFBQcC 57 | ARYiaHR0cDovL2Nwcy5yb290LXgxLmxldHNlbmNyeXB0Lm9yZzA8BgNVHR8ENTAz 58 | MDGgL6AthitodHRwOi8vY3JsLmlkZW50cnVzdC5jb20vRFNUUk9PVENBWDNDUkwu 59 | Y3JsMB0GA1UdDgQWBBSoSmpjBH3duubRObemRWXv86jsoTANBgkqhkiG9w0BAQsF 60 | AAOCAQEA3TPXEfNjWDjdGBX7CVW+dla5cEilaUcne8IkCJLxWh9KEik3JHRRHGJo 61 | uM2VcGfl96S8TihRzZvoroed6ti6WqEBmtzw3Wodatg+VyOeph4EYpr/1wXKtx8/ 62 | wApIvJSwtmVi4MFU5aMqrSDE6ea73Mj2tcMyo5jMd6jmeWUHK8so/joWUoHOUgwu 63 | X4Po1QYz+3dszkDqMp4fklxBwXRsW10KXzPMTZ+sOPAveyxindmjkW8lGy+QsRlG 64 | PfZ+G6Z6h7mjem0Y+iWlkYcV4PIWL1iwBi8saCbGS5jN2p8M+X+Q7UNKEkROb3N6 65 | KOqkqm57TH2H3eDJAkSnh6/DNFu0Qg== 66 | -----END CERTIFICATE-----|} 67 | 68 | let nsupdate_csr flow host keyname zone dnskey csr = 69 | match 70 | Dns_certify.nsupdate R.generate (fun () -> Ptime.v (P.now_d_ps ())) 71 | ~host ~keyname ~zone dnskey csr 72 | with 73 | | Error s -> Lwt.return (Error s) 74 | | Ok (out, cb) -> 75 | D.send_tcp (D.flow flow) out >>= function 76 | | Error () -> Lwt.return (Error (`Msg "tcp sending error")) 77 | | Ok () -> D.read_tcp flow >|= function 78 | | Error () -> Error (`Msg "tcp receive err") 79 | | Ok data -> match cb data with 80 | | Error e -> Error (`Msg (Fmt.strf "nsupdate reply error %a" Dns_certify.pp_u_err e)) 81 | | Ok () -> Ok () 82 | 83 | let query_certificate flow public_key name = 84 | match Dns_certify.query R.generate public_key name with 85 | | Error e -> Lwt.return (Error e) 86 | | Ok (out, cb) -> 87 | D.send_tcp (D.flow flow) out >>= function 88 | | Error () -> Lwt.return (Error (`Msg "couldn't send tcp")) 89 | | Ok () -> 90 | D.read_tcp flow >|= function 91 | | Error () -> Error (`Msg "error while reading answer") 92 | | Ok data -> match cb data with 93 | | Error e -> Error e 94 | | Ok cert -> Ok cert 95 | 96 | let initialise_csr hostname additionals seed = 97 | let private_key = 98 | let g, print = 99 | match seed with 100 | | None -> (None, true) 101 | | Some seed -> 102 | let seed = Cstruct.of_string seed in 103 | Some (Nocrypto.Rng.(create ~seed (module Generators.Fortuna))), false 104 | in 105 | let key = Nocrypto.Rsa.generate ?g 4096 in 106 | (if print then 107 | let pem = X509.Encoding.Pem.Private_key.to_pem_cstruct1 (`RSA key) in 108 | Log.info (fun m -> m "using private key@.%s" (Cstruct.to_string pem)) 109 | else 110 | ()) ; 111 | key 112 | in 113 | let public_key = `RSA (Nocrypto.Rsa.pub_of_priv private_key) in 114 | let extensions = match additionals with 115 | | [] -> [] 116 | | hostnames -> 117 | let dns = List.map (fun name -> `DNS name) (hostname :: hostnames) in 118 | [ `Extensions [ (false, `Subject_alt_name dns) ] ] 119 | in 120 | let csr = X509.CA.request [`CN hostname ] ~extensions (`RSA private_key) in 121 | (private_key, public_key, csr) 122 | 123 | let query_certificate_or_csr flow pub hostname keyname zone dnskey csr = 124 | query_certificate flow pub hostname >>= function 125 | | Ok certificate -> 126 | Log.info (fun m -> m "found certificate in DNS") ; 127 | Lwt.return (Ok certificate) 128 | | Error (`Msg msg) -> 129 | Log.err (fun m -> m "error %s" msg) ; 130 | Lwt.return (Error (`Msg msg)) 131 | | Error ((`Decode _ | `Bad_reply _ | `Unexpected_reply _) as e) -> 132 | Log.err (fun m -> m "query error %a, giving up" Dns_certify.pp_q_err e); 133 | Lwt.return (Error (`Msg "query error")) 134 | | Error `No_tlsa -> 135 | Log.info (fun m -> m "no certificate in DNS, need to transmit the CSR") ; 136 | nsupdate_csr flow hostname keyname zone dnskey csr >>= function 137 | | Error (`Msg msg) -> 138 | Log.err (fun m -> m "failed to nsupdate TLSA %s" msg) ; 139 | Lwt.fail_with "nsupdate issue" 140 | | Ok () -> 141 | let rec wait_for_cert ?(retry = 10) () = 142 | if retry = 0 then 143 | Lwt.return (Error (`Msg "too many retries, giving up")) 144 | else 145 | query_certificate flow pub hostname >>= function 146 | | Ok certificate -> 147 | Log.info (fun m -> m "finally found a certificate") ; 148 | Lwt.return (Ok certificate) 149 | | Error (`Msg msg) -> 150 | Log.err (fun m -> m "error while querying certificate %s" msg) ; 151 | Lwt.return (Error (`Msg msg)) 152 | | Error (#Dns_certify.q_err as q) -> 153 | Log.info (fun m -> m "still waiting for certificate, got error %a" Dns_certify.pp_q_err q) ; 154 | TIME.sleep_ns (Duration.of_sec 2) >>= fun () -> 155 | wait_for_cert ~retry:(pred retry) () 156 | in 157 | wait_for_cert () 158 | 159 | let retrieve_certificate ?(ca = `Staging) stack ~dns_key ~hostname ?(additional_hostnames = []) ?key_seed dns port = 160 | (match ca with 161 | | `Staging -> Logs.warn (fun m -> m "staging environment - test use only") 162 | | `Production -> Logs.warn (fun m -> m "production environment - take care what you do")); 163 | let keyname, zone, dnskey = 164 | match Dns.Dnskey.name_key_of_string dns_key with 165 | | Ok (name, key) -> 166 | let zone = Domain_name.(host_exn (drop_label_exn ~amount:2 name)) in 167 | (name, zone, key) 168 | | Error (`Msg m) -> invalid_arg ("failed to parse dnskey: " ^ m) 169 | in 170 | let not_sub subdomain = not (Domain_name.sub ~subdomain ~domain:zone) in 171 | if not_sub hostname || List.exists not_sub additional_hostnames then 172 | Lwt.fail_with "hostname not a subdomain of zone provided by dns_key" 173 | else 174 | let host, more = 175 | Domain_name.to_string hostname, 176 | List.map Domain_name.to_string additional_hostnames 177 | in 178 | let priv, pub, csr = initialise_csr host more key_seed in 179 | S.TCPV4.create_connection (S.tcpv4 stack) (dns, port) >>= function 180 | | Error e -> 181 | Log.err (fun m -> m "error %a while connecting to name server, shutting down" S.TCPV4.pp_error e) ; 182 | Lwt.return (Error (`Msg "couldn't connect to name server")) 183 | | Ok flow -> 184 | let flow = D.of_flow flow in 185 | query_certificate_or_csr flow pub hostname keyname zone dnskey csr >>= fun certificate -> 186 | S.TCPV4.close (D.flow flow) >|= fun () -> 187 | match certificate with 188 | | Error e -> Error e 189 | | Ok certificate -> 190 | let ca = match ca with 191 | | `Production -> production 192 | | `Staging -> staging 193 | in 194 | try 195 | let ca = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string ca) in 196 | Ok (`Single ([certificate ; ca], priv)) 197 | with 198 | | Invalid_argument str -> Error (`Msg str) 199 | end 200 | -------------------------------------------------------------------------------- /zone/dns_zone_parser.mly: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2005-2006 Tim Deegan 3 | * Copyright (c) 2017, 2018 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 | * dnsparser.mly -- ocamlyacc parser for DNS "Master zone file" format 18 | */ 19 | 20 | %{ 21 | 22 | open Dns_zone_state 23 | open Dns 24 | 25 | let parse_error s = raise (Zone_parse_problem s) 26 | 27 | (* Parsers for numbers *) 28 | let parse_uint8 s = 29 | try let d = int_of_string s in 30 | if d < 0 || d > 255 then raise Parsing.Parse_error; 31 | d 32 | with Failure _ -> raise Parsing.Parse_error 33 | 34 | let parse_uint16 s = 35 | try 36 | let n = int_of_string s in 37 | if n > 65535 then raise Parsing.Parse_error; 38 | n 39 | with Failure _ -> raise Parsing.Parse_error 40 | 41 | let parse_uint32 s = 42 | try 43 | let n = Int64.of_string s in 44 | if n >= 4294967296L then raise Parsing.Parse_error; 45 | Int64.to_int32 n 46 | with Failure _ -> raise Parsing.Parse_error 47 | 48 | (* Parse an IPv6 address. (RFC 3513 section 2.2) *) 49 | let parse_ipv6 s = 50 | Ipaddr.V6.of_string_exn s 51 | 52 | let add_to_map name (Rr_map.B (k, v)) = Name_rr_map.add name k v 53 | %} 54 | 55 | %token EOF 56 | %token EOL 57 | %token SORIGIN 58 | %token STTL 59 | %token AT 60 | %token DOT 61 | %token SPACE 62 | %token GENERIC 63 | %token NUMBER 64 | %token CHARSTRING 65 | 66 | %token TYPE_A 67 | %token TYPE_NS 68 | %token TYPE_CNAME 69 | %token TYPE_SOA 70 | %token TYPE_PTR 71 | %token TYPE_MX 72 | %token TYPE_TXT 73 | %token TYPE_AAAA 74 | %token TYPE_SRV 75 | %token TYPE_CAA 76 | %token TYPE_DNSKEY 77 | %token TYPE_TLSA 78 | %token TYPE_SSHFP 79 | %token TYPE_GENERIC 80 | 81 | %token CLASS_IN 82 | %token CLASS_CS 83 | %token CLASS_CH 84 | %token CLASS_HS 85 | 86 | %start zfile 87 | %type zfile 88 | 89 | %% 90 | 91 | zfile: lines EOF { state.zone } 92 | 93 | lines: 94 | /* nothing */ { } 95 | | lines EOL { } 96 | | lines origin EOL { } 97 | | lines ttl EOL { } 98 | | lines rrline EOL { } 99 | 100 | s: SPACE {} | s SPACE {} 101 | 102 | origin: SORIGIN s domain { state.origin <- $3 } 103 | 104 | ttl: STTL s int32 { state.ttl <- $3 } 105 | 106 | rrline: 107 | owner s int32 s rrclass s rr { state.zone <- add_to_map $1 (Rr_map.with_ttl $7 $3) state.zone } 108 | | owner s rrclass s int32 s rr { state.zone <- add_to_map $1 (Rr_map.with_ttl $7 $5) state.zone } 109 | | owner s rrclass s rr { state.zone <- add_to_map $1 (Rr_map.with_ttl $5 state.ttl) state.zone } 110 | | owner s int32 s rr { state.zone <- add_to_map $1 (Rr_map.with_ttl $5 $3) state.zone } 111 | | owner s rr { state.zone <- add_to_map $1 (Rr_map.with_ttl $3 state.ttl) state.zone } 112 | 113 | rrclass: 114 | CLASS_IN {} 115 | | CLASS_CS { parse_error "class must be \"IN\"" } 116 | | CLASS_CH { parse_error "class must be \"IN\"" } 117 | | CLASS_HS { parse_error "class must be \"IN\"" } 118 | 119 | rr: 120 | generic_type s generic_rdata { 121 | match Rr_map.I.of_int $1 with 122 | | Ok i -> B (Unknown i, (0l, Rr_map.Txt_set.singleton $3)) 123 | | Error _ -> parse_error "type code reserved, not generic" 124 | } 125 | /* RFC 1035 */ 126 | | TYPE_A s ipv4 { B (A, (0l, Rr_map.Ipv4_set.singleton $3)) } 127 | | TYPE_NS s hostname { B (Ns, (0l, Domain_name.Host_set.singleton $3)) } 128 | | TYPE_CNAME s domain { B (Cname, (0l, $3)) } 129 | | TYPE_SOA s domain s domain s int32 s int32 s int32 s int32 s int32 130 | { B (Soa, { Soa.nameserver = $3 ; hostmaster = $5 ; serial = $7 ; 131 | refresh = $9 ; retry = $11 ; expiry = $13 ; minimum = $15 }) } 132 | | TYPE_PTR s hostname { B (Ptr, (0l, $3)) } 133 | | TYPE_MX s int16 s hostname { B (Mx, (0l, Rr_map.Mx_set.singleton { Mx.preference = $3 ; mail_exchange = $5 })) } 134 | | TYPE_TXT s charstrings { B (Txt, (0l, Rr_map.Txt_set.of_list $3)) } 135 | /* RFC 2782 */ 136 | | TYPE_SRV s int16 s int16 s int16 s hostname 137 | { B (Srv, (0l, Rr_map.Srv_set.singleton { Srv.priority = $3 ; weight = $5 ; port = $7 ; target = $9 })) } 138 | /* RFC 3596 */ 139 | | TYPE_TLSA s int8 s int8 s int8 s hex 140 | { match 141 | Tlsa.int_to_cert_usage $3, 142 | Tlsa.int_to_selector $5, 143 | Tlsa.int_to_matching_type $7 144 | with 145 | | Ok cert_usage, Ok selector, Ok matching_type -> 146 | let tlsa = { Tlsa.cert_usage ; selector ; matching_type ; data = $9 } in 147 | B (Tlsa, (0l, Rr_map.Tlsa_set.singleton tlsa )) 148 | | _ -> raise Parsing.Parse_error 149 | } 150 | | TYPE_SSHFP s int8 s int8 s hex 151 | { match 152 | Sshfp.int_to_algorithm $3, 153 | Sshfp.int_to_typ $5 154 | with 155 | | Ok algorithm, Ok typ -> 156 | let sshfp = { Sshfp.algorithm ; typ ; fingerprint = $7 } in 157 | B (Sshfp, (0l, Rr_map.Sshfp_set.singleton sshfp)) 158 | | _ -> raise Parsing.Parse_error 159 | } 160 | | TYPE_AAAA s ipv6 { B (Aaaa, (0l, Rr_map.Ipv6_set.singleton $3)) } 161 | | TYPE_DNSKEY s int16 s int16 s int16 s charstring 162 | { if not ($5 = 3) then 163 | parse_error ("DNSKEY protocol is not 3, but " ^ string_of_int $5) ; 164 | match Dnskey.int_to_algorithm $7 with 165 | | Error _ -> parse_error ("DNSKEY algorithm not supported " ^ string_of_int $7) 166 | | Ok x -> 167 | let dnskey = { Dnskey.flags = $3 ; algorithm = x ; key = Cstruct.of_string $9 } in 168 | B (Dnskey, (0l, Rr_map.Dnskey_set.singleton dnskey)) 169 | } 170 | | TYPE_CAA s int16 s charstring s charstrings 171 | { let critical = if $3 = 0x80 then true else false in 172 | let caa = { Caa.critical ; tag = $5 ; value = $7 } in 173 | B (Caa, (0l, Rr_map.Caa_set.singleton caa)) } 174 | | CHARSTRING s { parse_error ("TYPE " ^ $1 ^ " not supported") } 175 | 176 | single_hex: charstring 177 | { Cstruct.of_hex $1 } 178 | 179 | hex: 180 | single_hex { $1 } 181 | | hex s single_hex { Cstruct.append $1 $3 } 182 | 183 | generic_type: TYPE_GENERIC 184 | { try parse_uint16 (String.sub $1 4 (String.length $1 - 4)) 185 | with Parsing.Parse_error -> parse_error ($1 ^ " is not a 16-bit number") 186 | } 187 | 188 | generic_rdata: GENERIC s NUMBER s hex 189 | { try 190 | let len = int_of_string $3 191 | and data = Cstruct.to_string $5 192 | in 193 | if not (String.length data = len) then 194 | parse_error ("generic data length field is " 195 | ^ $3 ^ " but actual length is " 196 | ^ string_of_int (String.length data)); 197 | data 198 | with Failure _ -> 199 | parse_error ("\\# should be followed by a number") 200 | } 201 | 202 | ipv4: NUMBER DOT NUMBER DOT NUMBER DOT NUMBER 203 | { try 204 | let a = parse_uint8 $1 in 205 | let b = parse_uint8 $3 in 206 | let c = parse_uint8 $5 in 207 | let d = parse_uint8 $7 in 208 | Ipaddr.V4.make a b c d 209 | with Failure _ | Parsing.Parse_error -> 210 | parse_error ("invalid IPv4 address " ^ $1 ^ "." ^ $3 ^ "." ^ $5 ^ "." ^ $7) 211 | } 212 | 213 | ipv6: charstring 214 | { try parse_ipv6 $1 with 215 | | Failure _ | Parsing.Parse_error -> 216 | parse_error ("invalid IPv6 address " ^ $1) 217 | } 218 | 219 | int8: NUMBER 220 | { try parse_uint8 $1 221 | with Parsing.Parse_error -> 222 | parse_error ($1 ^ " is not a 8-bit number") } 223 | 224 | int16: NUMBER 225 | { try parse_uint16 $1 226 | with Parsing.Parse_error -> 227 | parse_error ($1 ^ " is not a 16-bit number") } 228 | 229 | int32: NUMBER 230 | { try parse_uint32 $1 231 | with Failure _ -> 232 | parse_error ($1 ^ " is not a 32-bit number") } 233 | 234 | /* The owner of an RR is more restricted than a general domain name: it 235 | can't be a pure number or a type or class. If we see one of those we 236 | assume the owner field was omitted */ 237 | owner: 238 | /* nothing */ { state.owner } 239 | | domain { state.owner <- $1 ; state.owner } 240 | 241 | domain: 242 | DOT { Domain_name.root } 243 | | AT { state.origin } 244 | | label_except_at { Domain_name.prepend_label_exn state.origin $1 } 245 | | label DOT { Domain_name.of_strings_exn [$1] } 246 | | label DOT domain_labels { Domain_name.of_strings_exn ($1 :: $3 @ (Domain_name.to_strings state.origin)) } 247 | | label DOT domain_labels DOT { Domain_name.of_strings_exn ($1 :: $3) } 248 | 249 | domain_labels: 250 | label { [$1] } 251 | | domain_labels DOT label { $1 @ [$3] } 252 | 253 | hostname: domain { Domain_name.host_exn $1 } 254 | 255 | /* It's acceptable to re-use numbers and keywords as character-strings. 256 | This is pretty ugly: we need special cases to distinguish a domain 257 | that's made up of just an '@'. */ 258 | 259 | charstrings: charstring { [$1] } | charstrings s charstring { $1 @ [$3] } 260 | 261 | charstring: CHARSTRING { $1 } | keyword_or_number { $1 } | AT { "@" } 262 | 263 | label_except_specials: CHARSTRING 264 | { if String.length $1 > 63 then 265 | parse_error "label is longer than 63 bytes"; 266 | $1 } 267 | 268 | label_except_at: label_except_specials { $1 } | keyword_or_number { $1 } 269 | 270 | label: label_except_at { $1 } | AT { "@" } 271 | 272 | keyword_or_number: 273 | NUMBER { $1 } 274 | | TYPE_A { $1 } 275 | | TYPE_NS { $1 } 276 | | TYPE_CNAME { $1 } 277 | | TYPE_SOA { $1 } 278 | | TYPE_PTR { $1 } 279 | | TYPE_MX { $1 } 280 | | TYPE_TXT { $1 } 281 | | TYPE_AAAA { $1 } 282 | | TYPE_SRV { $1 } 283 | | TYPE_DNSKEY { $1 } 284 | | TYPE_TLSA { $1 } 285 | | TYPE_SSHFP { $1 } 286 | | CLASS_IN { $1 } 287 | | CLASS_CS { $1 } 288 | | CLASS_CH { $1 } 289 | | CLASS_HS { $1 } 290 | 291 | %% 292 | -------------------------------------------------------------------------------- /app/odns.ml: -------------------------------------------------------------------------------- 1 | (* odns client utility. *) 2 | (* RFC 768 DNS over UDP *) 3 | (* RFC 7766 DNS over TCP: https://tools.ietf.org/html/rfc7766 *) 4 | (* RFC 6698 DANE: https://tools.ietf.org/html/rfc6698*) 5 | 6 | let pp_zone ppf (domain,query_type,query_value) = 7 | (* TODO dig also prints 'IN' after the TTL, we don't... *) 8 | Fmt.string ppf 9 | (Dns.Rr_map.text_b domain (Dns.Rr_map.B (query_type, query_value))) 10 | 11 | let pp_zone_tlsa ppf (domain,ttl,(tlsa:Dns.Tlsa.t)) = 12 | (* TODO this implementation differs a bit from Dns_map.text and tries to 13 | follow the `dig` output to make it easier to port existing scripts *) 14 | Fmt.pf ppf "%a.\t%ld\tIN\t%d\t%d\t%d\t%s" 15 | Domain_name.pp domain 16 | ttl 17 | (Dns.Tlsa.cert_usage_to_int tlsa.cert_usage) 18 | (Dns.Tlsa.selector_to_int tlsa.selector) 19 | (Dns.Tlsa.matching_type_to_int tlsa.matching_type) 20 | ( (* this produces output similar to `dig`, splitting the hex string 21 | in chunks of 56 chars (28 bytes): *) 22 | let `Hex hex = Hex.of_cstruct tlsa.data in 23 | let hlen = String.length hex in 24 | let rec loop acc = function 25 | | n when n + 56 >= hlen -> 26 | String.concat " " (List.rev @@ String.sub hex n (hlen-n)::acc) 27 | |> String.uppercase_ascii 28 | | n -> loop ((String.sub hex n 56)::acc) (n+56) 29 | in loop [] 0) 30 | 31 | let do_a nameserver domains _ = 32 | let t = Dns_client_lwt.create ?nameserver () in 33 | let (_, (ns_ip, _)) = Dns_client_lwt.nameserver t in 34 | Logs.info (fun m -> m "querying NS %s for A records of %a" 35 | (Unix.string_of_inet_addr ns_ip) 36 | Fmt.(list ~sep:(unit", ") Domain_name.pp) domains); 37 | let job = 38 | Lwt_list.iter_p (fun domain -> 39 | let open Lwt in 40 | Logs.debug (fun m -> m "looking up %a" Domain_name.pp domain); 41 | Dns_client_lwt.(getaddrinfo t A domain) 42 | >|= function 43 | | Ok (_ttl, addrs) when Dns.Rr_map.Ipv4_set.is_empty addrs -> 44 | (* handle empty response? *) 45 | Logs.app (fun m -> m ";%a. IN %a" 46 | Domain_name.pp domain 47 | Dns.Rr_map.ppk (Dns.Rr_map.K A)) 48 | | Ok resp -> 49 | Logs.app (fun m -> m "%a" pp_zone (domain, A, resp)) 50 | | Error (`Msg msg) -> 51 | Logs.err (fun m -> m "Failed to lookup %a: %s\n" 52 | Domain_name.pp domain msg) 53 | ) domains 54 | in 55 | match Lwt_main.run job with 56 | | () -> Ok () (* TODO handle errors *) 57 | 58 | let for_all_domains nameserver ~domains typ f = 59 | (* [for_all_domains] is a utility function that lets us avoid duplicating 60 | this block of code in all the subcommands. 61 | We leave {!do_a} simple to provide a more readable example. *) 62 | let t = Dns_client_lwt.create ?nameserver () in 63 | let _, (ns_ip, _) = Dns_client_lwt.nameserver t in 64 | Logs.info (fun m -> m "NS: %s" @@ Unix.string_of_inet_addr ns_ip); 65 | let open Lwt in 66 | match Lwt_main.run 67 | (Lwt_list.iter_p 68 | (fun domain -> 69 | Dns_client_lwt.getaddrinfo t typ domain 70 | >|= Rresult.R.reword_error 71 | (function `Msg msg as res -> 72 | Logs.err (fun m -> 73 | m "Failed to lookup %a for %a: %s\n%!" 74 | Dns.Rr_map.ppk (Dns.Rr_map.K typ) 75 | Domain_name.pp domain msg) ; 76 | res) 77 | >|= f domain) 78 | domains) with 79 | | () -> Ok () (* TODO catch failed jobs *) 80 | 81 | let pp_response typ domain = function 82 | | Error _ -> () 83 | | Ok resp -> Logs.app (fun m -> m "%a" pp_zone (domain, typ, resp)) 84 | 85 | let do_aaaa nameserver domains _ = 86 | for_all_domains nameserver ~domains Dns.Rr_map.Aaaa 87 | (pp_response Dns.Rr_map.Aaaa) 88 | 89 | let do_mx nameserver domains _ = 90 | for_all_domains nameserver ~domains Dns.Rr_map.Mx 91 | (pp_response Dns.Rr_map.Mx) 92 | 93 | let do_tlsa nameserver domains _ = 94 | for_all_domains nameserver ~domains Dns.Rr_map.Tlsa 95 | (fun domain -> function 96 | | Ok (ttl, tlsa_resp) -> 97 | Dns.Rr_map.Tlsa_set.iter (fun tlsa -> 98 | Logs.app (fun m -> m "%a" pp_zone_tlsa (domain,ttl,tlsa)) 99 | ) tlsa_resp 100 | | Error _ -> () ) 101 | 102 | 103 | let do_txt nameserver domains _ = 104 | for_all_domains nameserver ~domains Dns.Rr_map.Txt 105 | (fun _domain -> function 106 | | Ok (ttl, txtset) -> 107 | Dns.Rr_map.Txt_set.iter (fun txtrr -> 108 | Logs.app (fun m -> m "%ld: @[%s@]" ttl txtrr) 109 | ) txtset 110 | | Error _ -> () ) 111 | 112 | 113 | let do_any _nameserver _domains _ = 114 | (* TODO *) 115 | Error (`Msg "ANY functionality is not present atm due to refactorings, come back later") 116 | 117 | let do_dkim nameserver (selector:string) domains _ = 118 | let domains = List.map (fun original_domain -> 119 | Domain_name.prepend_label_exn 120 | (Domain_name.prepend_label_exn 121 | (original_domain) "_domainkey") selector 122 | ) domains in 123 | for_all_domains nameserver ~domains Dns.Rr_map.Txt 124 | (fun _domain -> function 125 | | Ok (_ttl, txtset) -> 126 | Dns.Rr_map.Txt_set.iter (fun txt -> 127 | Logs.app (fun m -> m "%s" txt) 128 | ) txtset 129 | | Error _ -> () ) 130 | 131 | 132 | open Cmdliner 133 | 134 | let sdocs = Manpage.s_common_options 135 | 136 | let setup_log = 137 | let _setup_log (style_renderer:Fmt.style_renderer option) level : unit = 138 | Fmt_tty.setup_std_outputs ?style_renderer () ; 139 | Logs.set_level level ; 140 | Logs.set_reporter (Logs_fmt.reporter ()) 141 | in 142 | Term.(const _setup_log $ Fmt_cli.style_renderer ~docs:sdocs () 143 | $ Logs_cli.level ~docs:sdocs ()) 144 | 145 | let parse_ns : ('a * (Lwt_unix.inet_addr * int)) Arg.conv = 146 | ( fun ns -> 147 | try `Ok (`TCP, (Unix.inet_addr_of_string ns, 53)) with 148 | | _ -> `Error "NS must be an IPv4 address"), 149 | ( fun ppf (typ, (ns, port)) -> 150 | Fmt.pf ppf "%s:%d(%s)" (Unix.string_of_inet_addr ns) port 151 | (match typ with `UDP -> "udp" | `TCP -> "tcp")) 152 | 153 | let arg_ns : 'a Term.t = 154 | let doc = "IP of nameserver to use" in 155 | Arg.(value & opt (some parse_ns) None & info ~docv:"NS-IP" ~doc ["ns"]) 156 | 157 | let parse_domain : [ `raw ] Domain_name.t Arg.conv = 158 | ( fun name -> 159 | Domain_name.of_string name 160 | |> Rresult.R.reword_error 161 | (fun (`Msg m) -> Fmt.strf "Invalid domain: %S: %s" name m) 162 | |> Rresult.R.to_presult) , 163 | Domain_name.pp 164 | 165 | let arg_domains : [ `raw ] Domain_name.t list Term.t = 166 | let doc = "Domain names to operate on" in 167 | Arg.(non_empty & pos_all parse_domain [] 168 | & info [] ~docv:"DOMAIN(s)" ~doc) 169 | 170 | let arg_selector : string Term.t = 171 | let doc = "DKIM selector string" in 172 | Arg.(required & opt (some string) None 173 | & info ["selector"] ~docv:"SELECTOR" ~doc) 174 | 175 | let cmd_a : unit Term.t * Term.info = 176 | let doc = "Query a NS for A records" in 177 | let man = [ 178 | `P {| Output mimics that of $(b,dig A )$(i,DOMAIN)|} 179 | ] in 180 | Term.(term_result (const do_a $ arg_ns $ arg_domains $ setup_log)), 181 | Term.info "a" ~version:(Manpage.escape "%%VERSION%%") ~man ~doc ~sdocs 182 | 183 | let cmd_aaaa : unit Term.t * Term.info = 184 | let doc = "Query a NS for AAAA records" in 185 | let man = [ 186 | `P {| Output mimics that of $(b,dig AAAA )$(i,DOMAIN)|} 187 | ] in 188 | Term.(term_result (const do_aaaa $ arg_ns $ arg_domains $ setup_log)), 189 | Term.info "aaaa" ~version:(Manpage.escape "%%VERSION%%") ~man ~doc ~sdocs 190 | 191 | let cmd_mx : unit Term.t * Term.info = 192 | let doc = "Query a NS for mailserver (MX) records" in 193 | let man = [ 194 | `P {| Output mimics that of $(b,dig MX )$(i,DOMAIN)|} 195 | ] in 196 | Term.(term_result (const do_mx $ arg_ns $ arg_domains $ setup_log)), 197 | Term.info "mx" ~version:(Manpage.escape "%%VERSION%%") ~man ~doc ~sdocs 198 | 199 | let cmd_tlsa : unit Term.t * Term.info = 200 | let doc = "Query a NS for TLSA records (see DANE / RFC 7671)" in 201 | let man = [ 202 | `S Manpage.s_arguments ; 203 | `S Manpage.s_description ; 204 | `P {|Note that you must specify which $(b,service name) 205 | you want to retrieve the key(s) of. 206 | To retrieve the $(b,HTTPS) cert of $(i,www.example.com), 207 | you would query the NS: 208 | $(mname) $(tname) $(b,_443._tcp.)$(i,www.example.com) 209 | |} ; 210 | `P {|Brief list of other handy service name prefixes:|}; 211 | `P {| $(b,_5222._tcp) (XMPP); |} ; 212 | `P {| $(b,_853._tcp) (DNS-over-TLS); |} ; 213 | `P {| $(b,_25._tcp) (SMTP with STARTTLS); |} ; 214 | `P {| $(b,_465._tcp)(SMTP); |} ; 215 | `P {| $(b,_993._tcp) (IMAP) |} ; 216 | `S Manpage.s_options ; 217 | ] in 218 | Term.(term_result (const do_tlsa $ arg_ns $ arg_domains $ setup_log)), 219 | Term.info "tlsa" ~version:(Manpage.escape "%%VERSION%%") ~man ~doc ~sdocs 220 | 221 | let cmd_txt : unit Term.t * Term.info = 222 | let doc = "Query a NS for TXT records" in 223 | let man = [ 224 | `S Manpage.s_arguments ; 225 | `S Manpage.s_description ; 226 | `P {| Output format is currently: $(i,{TTL}: {text escaped in OCaml format}) 227 | It would be nice to mirror `dig` output here.|} ; 228 | `S Manpage.s_options ; 229 | ] in 230 | Term.(term_result (const do_txt $ arg_ns $ arg_domains $ setup_log)), 231 | Term.info "txt" ~version:(Manpage.escape "%%VERSION%%") ~man ~doc ~sdocs 232 | 233 | let cmd_any : unit Term.t * Term.info = 234 | let doc = "Query a NS for ANY records" in 235 | let man = [ 236 | `S Manpage.s_arguments ; 237 | `S Manpage.s_description ; 238 | `P {| The output will be fairly similar to $(b,dig ANY )$(i,example.com)|} ; 239 | `S Manpage.s_options ; 240 | ] in 241 | Term.(term_result (const do_any $ arg_ns $ arg_domains $ setup_log)), 242 | Term.info "any" ~version:(Manpage.escape "%%VERSION%%") ~man ~doc ~sdocs 243 | 244 | let cmd_dkim : unit Term.t * Term.info = 245 | let doc = "Query a NS for DKIM (RFC 6376) records for a given selector" in 246 | let man = [ 247 | `S Manpage.s_arguments ; 248 | `S Manpage.s_description ; 249 | `S {| Looks up DKIM (DomainKeys Identified Mail) Signatures in 250 | accordance with RFC 6376. 251 | Basically it's a recursive TXT lookup on 252 | $(i,SELECTOR)._domainkeys.$(i,DOMAIN). 253 | Each key is printed on its own concatenated line. 254 | |} ; 255 | `S Manpage.s_options ; 256 | ] in 257 | Term.(term_result (const do_dkim $ arg_ns $ arg_selector 258 | $ arg_domains $ setup_log)), 259 | Term.info "dkim" ~version:(Manpage.escape "%%VERSION%%") ~man ~doc ~sdocs 260 | 261 | 262 | let cmd_help : 'a Term.t * Term.info = 263 | let doc = "OCaml uDns alternative to `dig`" in 264 | let man = [ 265 | `P {|For more information about the available subcommands, 266 | run them while passing the help flag: $(tname) $(i,SUBCOMMAND) $(b,--help) 267 | |} 268 | ] in 269 | let help _ = `Help (`Pager, None) in 270 | Term.(ret (const help $ setup_log)), 271 | Term.info "odns" ~version:(Manpage.escape "%%VERSION%%") ~man ~doc ~sdocs 272 | 273 | let cmds = 274 | [ cmd_a ; cmd_tlsa; cmd_txt ; cmd_any; cmd_dkim ; cmd_aaaa ; cmd_mx ] 275 | 276 | let () = 277 | Term.(exit @@ eval_choice cmd_help cmds) 278 | -------------------------------------------------------------------------------- /mirage/server/dns_mirage_server.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Lwt.Infix 4 | 5 | let src = Logs.Src.create "dns_mirage_server" ~doc:"effectful DNS server" 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | module Make (P : Mirage_clock_lwt.PCLOCK) (M : Mirage_clock_lwt.MCLOCK) (TIME : Mirage_time_lwt.S) (S : Mirage_stack_lwt.V4) = struct 9 | 10 | module Dns = Dns_mirage.Make(S) 11 | 12 | module T = S.TCPV4 13 | 14 | let primary ?(on_update = fun ~old:_ _ -> Lwt.return_unit) ?(on_notify = fun _ _ -> Lwt.return None) ?(timer = 2) ?(port = 53) stack t = 15 | let state = ref t in 16 | let tcp_out = ref Dns.IM.empty in 17 | 18 | let drop ip = 19 | tcp_out := Dns.IM.remove ip !tcp_out ; 20 | state := Dns_server.Primary.closed !state ip 21 | in 22 | 23 | let connect recv_task ip = 24 | let dport = 53 in 25 | Log.info (fun m -> m "creating connection to %a:%d" Ipaddr.V4.pp ip dport) ; 26 | T.create_connection (S.tcpv4 stack) (ip, dport) >>= function 27 | | Error e -> 28 | Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d" 29 | T.pp_error e Ipaddr.V4.pp ip port) ; 30 | Lwt.return (Error ()) 31 | | Ok flow -> 32 | tcp_out := Dns.IM.add ip flow !tcp_out ; 33 | Lwt.async (recv_task ip dport flow); 34 | Lwt.return (Ok flow) 35 | in 36 | 37 | let send_notify recv_task (ip, data) = 38 | let connect_and_send ip = 39 | connect recv_task ip >>= function 40 | | Ok flow -> Dns.send_tcp flow data 41 | | Error () -> Lwt.return (Error ()) 42 | in 43 | (match Dns.IM.find ip !tcp_out with 44 | | None -> connect_and_send ip 45 | | Some f -> Dns.send_tcp f data >>= function 46 | | Ok () -> Lwt.return (Ok ()) 47 | | Error () -> drop ip ; connect_and_send ip) >>= function 48 | | Ok () -> Lwt.return_unit 49 | | Error () -> 50 | drop ip ; Dns.send_udp stack port ip 53 data 51 | in 52 | 53 | let maybe_update_state t = 54 | let old = !state in 55 | let trie server = Dns_server.Primary.data server in 56 | state := t; 57 | if Dns_trie.equal (trie t) (trie old) then 58 | Lwt.return_unit 59 | else 60 | on_update ~old:(trie old) t 61 | and maybe_notify recv_task t now ts = function 62 | | None -> Lwt.return_unit 63 | | Some n -> on_notify n t >>= function 64 | | None -> Lwt.return_unit 65 | | Some trie -> 66 | let state', outs = Dns_server.Primary.with_data t now ts trie in 67 | state := state'; 68 | Lwt_list.iter_p (send_notify recv_task) outs 69 | in 70 | 71 | let rec recv_task ip port flow () = 72 | let f = Dns.of_flow flow in 73 | let rec loop () = 74 | Dns.read_tcp f >>= function 75 | | Error () -> drop ip ; Lwt.return_unit 76 | | Ok data -> 77 | let now = Ptime.v (P.now_d_ps ()) in 78 | let elapsed = M.elapsed_ns () in 79 | let t, answer, notify, n = Dns_server.Primary.handle_buf !state now elapsed `Tcp ip port data in 80 | let n' = match n with 81 | | Some `Keep -> tcp_out := Dns.IM.add ip flow !tcp_out ; None 82 | | Some `Notify soa -> Some (`Notify soa) 83 | | Some `Signed_notify soa -> Some (`Signed_notify soa) 84 | | None -> None 85 | in 86 | maybe_update_state t >>= fun () -> 87 | maybe_notify recv_task t now elapsed n' >>= fun () -> 88 | (match answer with 89 | | None -> Log.warn (fun m -> m "empty answer") ; Lwt.return_unit 90 | | Some answer -> 91 | Dns.send_tcp flow answer >|= function 92 | | Ok () -> () 93 | | Error () -> drop ip) >>= fun () -> 94 | Lwt_list.iter_p (send_notify recv_task) notify >>= fun () -> 95 | loop () 96 | in 97 | loop () 98 | in 99 | 100 | let tcp_cb flow = 101 | let dst_ip, dst_port = T.dst flow in 102 | Log.info (fun m -> m "tcp connection from %a:%d" Ipaddr.V4.pp dst_ip dst_port) ; 103 | recv_task dst_ip dst_port flow () 104 | in 105 | S.listen_tcpv4 stack ~port tcp_cb ; 106 | Log.info (fun m -> m "DNS server listening on TCP port %d" port) ; 107 | 108 | let udp_cb ~src ~dst:_ ~src_port buf = 109 | Log.info (fun m -> m "udp frame from %a:%d" Ipaddr.V4.pp src src_port) ; 110 | let now = Ptime.v (P.now_d_ps ()) in 111 | let elapsed = M.elapsed_ns () in 112 | let t, answer, notify, n = Dns_server.Primary.handle_buf !state now elapsed `Udp src src_port buf in 113 | let n' = match n with 114 | | None | Some `Keep -> None 115 | | Some `Notify soa -> Some (`Notify soa) 116 | | Some `Signed_notify soa -> Some (`Signed_notify soa) 117 | in 118 | maybe_update_state t >>= fun () -> 119 | maybe_notify recv_task t now elapsed n' >>= fun () -> 120 | (match answer with 121 | | None -> Log.warn (fun m -> m "empty answer") ; Lwt.return_unit 122 | | Some answer -> Dns.send_udp stack port src src_port answer) >>= fun () -> 123 | Lwt_list.iter_p (send_notify recv_task) notify 124 | in 125 | S.listen_udpv4 stack ~port udp_cb ; 126 | Log.info (fun m -> m "DNS server listening on UDP port %d" port) ; 127 | let rec time () = 128 | let now = Ptime.v (P.now_d_ps ()) in 129 | let elapsed = M.elapsed_ns () in 130 | let t, notifies = Dns_server.Primary.timer !state now elapsed in 131 | maybe_update_state t >>= fun () -> 132 | Lwt_list.iter_p (send_notify recv_task) notifies >>= fun () -> 133 | TIME.sleep_ns (Duration.of_sec timer) >>= fun () -> 134 | time () 135 | in 136 | Lwt.async time 137 | 138 | let secondary ?(on_update = fun ~old:_ _trie -> Lwt.return_unit) ?(timer = 5) ?(port = 53) stack t = 139 | let state = ref t in 140 | let tcp_out = ref Dns.IM.empty in 141 | let tcp_packet_transit = ref Dns.IM.empty in 142 | 143 | let maybe_update_state t = 144 | let old = !state in 145 | let trie server = Dns_server.Secondary.data server in 146 | state := t ; 147 | if Dns_trie.equal (trie t) (trie old) then 148 | Lwt.return_unit 149 | else 150 | on_update ~old:(trie old) t 151 | in 152 | 153 | let rec close ip = 154 | (match Dns.IM.find ip !tcp_out with 155 | | None -> Lwt.return_unit 156 | | Some f -> T.close f) >>= fun () -> 157 | tcp_out := Dns.IM.remove ip !tcp_out ; 158 | let now = Ptime.v (P.now_d_ps ()) in 159 | let elapsed = M.elapsed_ns () in 160 | let state', out = Dns_server.Secondary.closed !state now elapsed ip in 161 | state := state' ; 162 | Lwt_list.iter_s request out 163 | and read_and_handle ip f = 164 | Dns.read_tcp f >>= function 165 | | Error () -> 166 | Log.debug (fun m -> m "removing %a from tcp_out" Ipaddr.V4.pp ip) ; 167 | close ip >>= fun () -> 168 | (* re-send once *) 169 | begin match Dns.IM.find ip !tcp_packet_transit with 170 | | None -> Lwt.return_unit 171 | | Some data -> request ~record:false data 172 | end 173 | | Ok data -> 174 | let now = Ptime.v (P.now_d_ps ()) in 175 | let elapsed = M.elapsed_ns () in 176 | let t, answer, out = 177 | Dns_server.Secondary.handle_buf !state now elapsed `Tcp ip data 178 | in 179 | maybe_update_state t >>= fun () -> 180 | (match answer with 181 | | None -> Lwt.return (Ok ()) 182 | | Some x -> 183 | Dns.send_tcp (Dns.flow f) x >>= function 184 | | Error () -> 185 | Log.debug (fun m -> m "removing %a from tcp_out" Ipaddr.V4.pp ip) ; 186 | close ip >|= fun () -> Error () 187 | | Ok () -> Lwt.return (Ok ())) >>= fun r -> 188 | Lwt_list.iter_s request out >>= fun () -> 189 | match r with 190 | | Ok () -> read_and_handle ip f 191 | | Error () -> Lwt.return_unit 192 | and request ?(record = true) (proto, ip, data) = 193 | let dport = 53 in 194 | if record then 195 | tcp_packet_transit := Dns.IM.add ip (proto, ip, data) !tcp_packet_transit; 196 | match Dns.IM.find ip !tcp_out with 197 | | None -> 198 | begin 199 | Log.info (fun m -> m "creating connection to %a:%d" Ipaddr.V4.pp ip dport) ; 200 | T.create_connection (S.tcpv4 stack) (ip, dport) >>= function 201 | | Error e -> 202 | Log.err (fun m -> m "error %a while establishing tcp connection to %a:%d" 203 | T.pp_error e Ipaddr.V4.pp ip dport) ; 204 | Lwt.async (fun () -> 205 | TIME.sleep_ns (Duration.of_sec 5) >>= fun () -> 206 | close ip) ; 207 | Lwt.return_unit 208 | | Ok flow -> 209 | tcp_out := Dns.IM.add ip flow !tcp_out ; 210 | Dns.send_tcp flow data >>= function 211 | | Error () -> close ip 212 | | Ok () -> 213 | Lwt.async (fun () -> read_and_handle ip (Dns.of_flow flow)) ; 214 | Lwt.return_unit 215 | end 216 | | Some flow -> 217 | Dns.send_tcp flow data >>= function 218 | | Ok () -> Lwt.return_unit 219 | | Error () -> 220 | Log.warn (fun m -> m "closing tcp flow to %a:%d, retrying request" 221 | Ipaddr.V4.pp ip dport) ; 222 | T.close flow >>= fun () -> 223 | tcp_out := Dns.IM.remove ip !tcp_out ; 224 | request (proto, ip, data) 225 | in 226 | 227 | let udp_cb ~src ~dst:_ ~src_port buf = 228 | Log.info (fun m -> m "udp frame from %a:%d" Ipaddr.V4.pp src src_port) ; 229 | let now = Ptime.v (P.now_d_ps ()) in 230 | let elapsed = M.elapsed_ns () in 231 | let t, answer, out = Dns_server.Secondary.handle_buf !state now elapsed `Udp src buf in 232 | maybe_update_state t >>= fun () -> 233 | List.iter (fun x -> Lwt.async (fun () -> request x)) out ; 234 | match answer with 235 | | None -> Lwt.return_unit 236 | | Some out -> Dns.send_udp stack port src src_port out 237 | in 238 | S.listen_udpv4 stack ~port udp_cb ; 239 | Log.info (fun m -> m "secondary DNS listening on UDP port %d" port) ; 240 | 241 | let tcp_cb flow = 242 | let dst_ip, dst_port = T.dst flow in 243 | tcp_out := Dns.IM.add dst_ip flow !tcp_out ; 244 | Log.info (fun m -> m "tcp connection from %a:%d" Ipaddr.V4.pp dst_ip dst_port) ; 245 | let f = Dns.of_flow flow in 246 | let rec loop () = 247 | Dns.read_tcp f >>= function 248 | | Error () -> tcp_out := Dns.IM.remove dst_ip !tcp_out ; Lwt.return_unit 249 | | Ok data -> 250 | let now = Ptime.v (P.now_d_ps ()) in 251 | let elapsed = M.elapsed_ns () in 252 | let t, answer, out = 253 | Dns_server.Secondary.handle_buf !state now elapsed `Tcp dst_ip data 254 | in 255 | maybe_update_state t >>= fun () -> 256 | List.iter (fun x -> Lwt.async (fun () -> request x)) out ; 257 | match answer with 258 | | None -> 259 | Log.warn (fun m -> m "no TCP output") ; 260 | loop () 261 | | Some data -> 262 | Dns.send_tcp flow data >>= function 263 | | Ok () -> loop () 264 | | Error () -> tcp_out := Dns.IM.remove dst_ip !tcp_out ; Lwt.return_unit 265 | in 266 | loop () 267 | in 268 | S.listen_tcpv4 stack ~port tcp_cb ; 269 | Log.info (fun m -> m "secondary DNS listening on TCP port %d" port) ; 270 | 271 | let rec time () = 272 | let now = Ptime.v (P.now_d_ps ()) in 273 | let elapsed = M.elapsed_ns () in 274 | let t, out = Dns_server.Secondary.timer !state now elapsed in 275 | maybe_update_state t >>= fun () -> 276 | List.iter (fun x -> Lwt.async (fun () -> request x)) out ; 277 | TIME.sleep_ns (Duration.of_sec timer) >>= fun () -> 278 | time () 279 | in 280 | Lwt.async time 281 | end 282 | -------------------------------------------------------------------------------- /resolver/dns_resolver_utils.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | open Dns_resolver_cache 5 | 6 | open Rresult.R.Infix 7 | 8 | let invalid_soa name = 9 | let p pre = 10 | match Domain_name.(prepend_label name "invalid" >>= fun n -> prepend_label n pre) with 11 | | Ok name -> name 12 | | Error _ -> name 13 | in 14 | { 15 | Soa.nameserver = p "ns" ; hostmaster = p "hostmaster" ; 16 | serial = 1l ; refresh = 16384l ; retry = 2048l ; 17 | expiry = 1048576l ; minimum = 300l 18 | } 19 | 20 | let soa_map name soa = Name_rr_map.singleton name Soa soa 21 | 22 | let _invalid_soa_map name = 23 | let soa = invalid_soa name in 24 | soa_map name soa 25 | 26 | let noerror bailiwick (_, flags) q_name q_type (answer, authority) additional = 27 | (* maybe should be passed explicitly (when we don't do qname minimisation) *) 28 | let in_bailiwick name = Domain_name.sub ~domain:bailiwick ~subdomain:name in 29 | (* ANSWER *) 30 | let answers, anames = 31 | match Domain_name.Map.find q_name answer with 32 | | None -> 33 | (* NODATA (no answer, but SOA (or not) in authority) *) 34 | begin 35 | (* RFC2308, Sec 2.2 "No data": 36 | - answer is empty 37 | - authority has a) SOA + NS, b) SOA, or c) nothing *) 38 | (* an example for this behaviour is NS: 39 | asking for AAAA www.soup.io, get empty answer + SOA in authority 40 | asking for AAAA coffee.soup.io, get empty answer + authority *) 41 | (* the "sub" should be relaxed - for dig ns mail.mehnert.org I get soa in mehnert.org! 42 | --> but how to discover SOA/zone boundaries? *) 43 | let rank = if Packet.Flags.mem `Authoritative flags then AuthoritativeAuthority else Additional in 44 | match 45 | Domain_name.Map.fold (fun name rr_map acc -> 46 | if Domain_name.sub ~subdomain:q_name ~domain:name then 47 | match Rr_map.find Soa rr_map with 48 | | Some soa -> (name, soa) :: acc 49 | | None -> acc 50 | else 51 | acc) 52 | authority [] 53 | with 54 | | (name, soa)::_ -> 55 | begin match q_type with 56 | | `Any -> [] (* i really don't know how to handle ANY NoDATA*) 57 | | `K k -> [ k, q_name, rank, `No_data (name, soa) ] 58 | (* this is wrong for the normal iterative algorithm: 59 | it asks for foo.com @root, and get .com NS in AU and A in AD 60 | | [] when not (Packet.Header.FS.mem `Truncation flags) -> 61 | Logs.warn (fun m -> m "noerror answer, but nothing in authority whose sub is %a in %a, invalid_soa!" 62 | pp_question (q_name, q_type) Name_rr_map.pp authority) ; 63 | [ q_type, q_name, Additional, `No_data (q_name, invalid_soa q_name) ] *) 64 | end 65 | | [] -> [] (* general case when we get an answer from root server *) 66 | end, Domain_name.Set.empty 67 | | Some rr_map -> 68 | let rank = if Packet.Flags.mem `Authoritative flags then AuthoritativeAnswer else NonAuthoritativeAnswer in 69 | (* collect those rrsets which are of interest depending on q_type! *) 70 | match q_type with 71 | | `Any -> 72 | Rr_map.fold (fun (B (k, v)) (acc, names) -> 73 | (Rr_map.K k, q_name, rank, `Entry (Rr_map.B (k, v))) :: acc, 74 | Domain_name.Host_set.fold (fun n acc -> 75 | Domain_name.Set.add (Domain_name.raw n) acc) 76 | (Rr_map.names k v) names) 77 | rr_map ([], Domain_name.Set.empty) 78 | | `K (Rr_map.K Cname) -> 79 | begin match Rr_map.find Cname rr_map with 80 | | Some v -> [ Rr_map.K Cname, q_name, rank, `Alias v ], 81 | Domain_name.Host_set.fold (fun n acc -> 82 | Domain_name.Set.add (Domain_name.raw n) acc) 83 | (Rr_map.names Cname v) Domain_name.Set.empty 84 | | None -> 85 | (* case no cname *) 86 | Logs.warn (fun m -> m "noerror answer with right name, but no cname in %a, invalid soa for %a" 87 | Name_rr_map.pp answer pp_question (q_name, q_type)); 88 | [ Rr_map.K Cname, q_name, rank, `No_data (q_name, invalid_soa q_name) ], 89 | Domain_name.Set.empty 90 | end 91 | | `K (Rr_map.K k) -> match Rr_map.find k rr_map with 92 | | Some v -> 93 | [ Rr_map.K k, q_name, rank, `Entry (B (k, v)) ], 94 | Domain_name.Host_set.fold (fun n acc -> 95 | Domain_name.Set.add (Domain_name.raw n) acc) 96 | (Rr_map.names k v) Domain_name.Set.empty 97 | | None -> match Rr_map.find Cname rr_map with 98 | | None -> 99 | (* case neither TYP nor cname *) 100 | Logs.warn (fun m -> m "noerror answer with right name, but not TYP nor cname in %a, invalid soa for %a" 101 | Name_rr_map.pp answer pp_question (q_name, q_type)); 102 | [ Rr_map.K k, q_name, rank, `No_data (q_name, invalid_soa q_name) ], 103 | Domain_name.Set.empty 104 | | Some cname -> 105 | (* explicitly register as CNAME so it'll be found *) 106 | (* should we try to find further records for the new alias? *) 107 | [ Rr_map.K Cname, q_name, rank, `Alias cname ], 108 | Domain_name.Set.singleton (snd cname) 109 | in 110 | 111 | (* AUTHORITY - NS records *) 112 | let ns, nsnames = 113 | (* authority points us to NS of q_name! *) 114 | (* we collect a list of NS records and the ns names *) 115 | (* TODO need to be more careful, q: foo.com a: foo.com a 1.2.3.4 au: foo.com ns blablubb.com ad: blablubb.com A 1.2.3.4 *) 116 | let nm, names = 117 | Domain_name.Map.fold (fun name map (acc, s) -> 118 | if in_bailiwick name then 119 | match Rr_map.find Ns map with 120 | | None -> acc, s 121 | | Some (ns : int32 * Domain_name.Host_set.t) -> 122 | (name, ns) :: acc, Domain_name.Host_set.fold (fun n acc -> 123 | Domain_name.Set.add (Domain_name.raw n) acc) 124 | (snd ns) s 125 | else 126 | acc, s) 127 | authority 128 | ([], Domain_name.Set.empty) 129 | in 130 | let rank = if Packet.Flags.mem `Authoritative flags then AuthoritativeAuthority else Additional in 131 | List.fold_left (fun acc (name, ns) -> 132 | (Rr_map.(K Ns), name, rank, `Entry Rr_map.(B (Ns, ns))) :: acc) 133 | [] nm, names 134 | in 135 | 136 | (* ADDITIONAL *) 137 | (* maybe only these thingies which are subdomains of q_name? *) 138 | (* preserve A/AAAA records only for NS lookups? *) 139 | (* now we have processed: 140 | - answer (filtered to where name = q_name) 141 | - authority with SOA and NS entries 142 | - names from these answers, and authority 143 | - additional section can contain glue records if needed 144 | - only A and AAAA records are of interest for glue *) 145 | let glues = 146 | let names = Domain_name.Set.union anames nsnames in 147 | let names = Domain_name.Set.filter in_bailiwick names in 148 | Domain_name.Set.fold (fun name acc -> 149 | match Domain_name.Map.find name additional with 150 | | None -> acc 151 | | Some map -> 152 | let a = match Rr_map.find A map with 153 | | None -> acc 154 | | Some v -> (Rr_map.K A, name, Additional, `Entry (Rr_map.B (A, v))) :: acc 155 | in 156 | match Rr_map.find Aaaa map with 157 | | None -> a 158 | | Some v -> (Rr_map.K Aaaa, name, Additional, `Entry (Rr_map.B (Aaaa, v))) :: a) 159 | names [] 160 | in 161 | (* This is defined in RFC2181, Sec9 -- answer is unique if authority or 162 | additional is non-empty *) 163 | let answer_complete = 164 | not (Domain_name.Map.is_empty authority && Domain_name.Map.is_empty additional) 165 | in 166 | match answers, ns with 167 | | [], [] when not answer_complete && Packet.Flags.mem `Truncation flags -> 168 | (* special handling for truncated replies.. better not add anything *) 169 | Logs.warn (fun m -> m "truncated reply for %a, ignoring completely" 170 | pp_question (q_name, q_type)); 171 | [] 172 | | [], [] -> 173 | (* not sure if this can happen, maybe discard everything? *) 174 | Logs.warn (fun m -> m "reply without answers or ns invalid so for %a" 175 | pp_question (q_name, q_type)); 176 | begin match q_type with 177 | | `Any -> [] 178 | | `K k -> [ k, q_name, Additional, `No_data (q_name, invalid_soa q_name) ] 179 | end 180 | | _, _ -> answers @ ns @ glues 181 | 182 | let find_soa name authority = 183 | let rec go name = 184 | match Domain_name.Map.find name authority with 185 | | None -> go (Domain_name.drop_label_exn name) 186 | | Some rrmap -> match Rr_map.(find Soa rrmap) with 187 | | None -> go (Domain_name.drop_label_exn name) 188 | | Some soa -> name, soa 189 | in 190 | try Some (go name) with Invalid_argument _ -> None 191 | 192 | let nxdomain (_, flags) name data = 193 | (* we can't do much if authoritiative is not set (some auth dns do so) *) 194 | (* There are cases where answer is non-empty, but contains a CNAME *) 195 | (* RFC 2308 Sec 1 + 2.1 show that NXDomain is for the last QNAME! *) 196 | (* -> need to potentially extract CNAME(s) *) 197 | let answer, authority = match data with 198 | | None -> Name_rr_map.empty, Name_rr_map.empty 199 | | Some x -> x 200 | in 201 | let cnames = 202 | let rec go acc name = 203 | match Domain_name.Map.find name answer with 204 | | None -> acc 205 | | Some rrmap -> match Rr_map.(find Cname rrmap) with 206 | | None -> acc 207 | | Some (ttl, alias) -> go ((name, (ttl, alias)) :: acc) alias 208 | in 209 | go [] name 210 | in 211 | let soa = find_soa name authority in 212 | (* since NXDomain have CNAME semantics, we store them as CNAME *) 213 | let rank = if Packet.Flags.mem `Authoritative flags then AuthoritativeAnswer else NonAuthoritativeAnswer in 214 | (* we conclude NXDomain, there are 3 cases we care about: 215 | no soa in authority and no cname answer -> inject an invalid_soa (avoid loops) 216 | a matching soa, no cname -> NoDom q_name 217 | _, a matching cname -> NoErr q_name with cname 218 | *) 219 | let entries = 220 | let soa = match soa with 221 | | None -> name, invalid_soa name 222 | | Some x -> x 223 | in 224 | match cnames with 225 | | [] -> [ name, `No_domain soa ] 226 | | rrs -> List.map (fun (name, cname) -> (name, `Alias cname)) rrs 227 | in 228 | (* the cname does not matter *) 229 | List.map (fun (name, res) -> Rr_map.K Cname, name, rank, res) entries 230 | 231 | let noerror_stub name typ (answer, authority) = 232 | (* no glue, just answers - but get all the cnames *) 233 | let find_entry_or_cname name = 234 | match Domain_name.Map.find name answer with 235 | | None -> None 236 | | Some rrmap -> match typ with 237 | | `Any -> Some (`Entries rrmap) 238 | | `K (Rr_map.K k) -> match Rr_map.find k rrmap with 239 | | Some v -> Some (`Entry (Rr_map.B (k, v))) 240 | | None -> match Rr_map.find Cname rrmap with 241 | | None -> None 242 | | Some (ttl, alias) -> Some (`Cname (ttl, alias)) 243 | in 244 | let rec go acc name = match find_entry_or_cname name with 245 | | None -> 246 | let name, soa = match find_soa name authority with 247 | | Some (name, soa) -> (name, soa) 248 | | None -> name, invalid_soa name 249 | in 250 | (* TODO unclear what to do here *) 251 | let typ = match typ with `Any -> Rr_map.K A | `K k -> k in 252 | (typ, name, NonAuthoritativeAnswer, `No_data (name, soa)) :: acc 253 | | Some (`Cname (ttl, alias)) -> 254 | go ((Rr_map.K Cname, name, NonAuthoritativeAnswer, `Alias (ttl, alias)) :: acc) alias 255 | | Some (`Entry (B (k, v))) -> 256 | (K k, name, NonAuthoritativeAnswer, `Entry (Rr_map.B (k, v))) :: acc 257 | | Some (`Entries map) -> 258 | Rr_map.fold (fun Rr_map.(B (k, _) as b) acc -> 259 | (Rr_map.K k, name, NonAuthoritativeAnswer, `Entry b) :: acc) 260 | map acc 261 | in 262 | go [] name 263 | 264 | (* stub vs recursive: maybe sufficient to look into *) 265 | let scrub ?(mode = `Recursive) zone qtype p = 266 | Logs.debug (fun m -> m "scrubbing (bailiwick %a) data %a" 267 | Domain_name.pp zone Packet.pp p); 268 | let qname = fst p.question in 269 | match mode, p.Packet.data with 270 | | `Recursive, `Answer data -> Ok (noerror zone p.header qname qtype data p.additional) 271 | | `Stub, `Answer data -> Ok (noerror_stub qname qtype data) 272 | | _, `Rcode_error (Rcode.NXDomain, _, data) -> Ok (nxdomain p.Packet.header qname data) 273 | | `Stub, `Rcode_error (Rcode.ServFail, _, _) -> 274 | let soa = invalid_soa qname in 275 | Ok [ Rr_map.K Cname, qname, NonAuthoritativeAnswer, `Serv_fail (qname, soa) ] 276 | | _, e -> Error (Packet.rcode_data e) 277 | -------------------------------------------------------------------------------- /server/dns_trie.ml: -------------------------------------------------------------------------------- 1 | (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) 2 | 3 | open Dns 4 | 5 | module O = struct 6 | type t = string 7 | let compare = Domain_name.compare_sub 8 | end 9 | module M = Map.Make(O) 10 | 11 | type t = N of t M.t * Rr_map.t 12 | 13 | let empty = N (M.empty, Rr_map.empty) 14 | 15 | let is_empty (N (sub, map)) = M.is_empty sub && Rr_map.is_empty map 16 | 17 | let bindings t = 18 | let rec go pre (N (sub, e)) = 19 | let subs = M.bindings sub in 20 | (pre, e) :: 21 | List.fold_left 22 | (fun acc (pre', va) -> 23 | acc @ go (Domain_name.prepend_label_exn pre pre') va) [] subs 24 | in 25 | go Domain_name.root t 26 | 27 | let pp_map name ppf map = 28 | Fmt.(list ~sep:(unit "@.") string) ppf 29 | (List.map (Rr_map.text_b name) (Rr_map.bindings map)) 30 | 31 | let pp ppf t = List.iter (fun (name, map) -> pp_map name ppf map) (bindings t) 32 | 33 | let rec equal (N (sub, map)) (N (sub', map')) = 34 | Rr_map.equal { f = Rr_map.equal_rr } map map' && M.equal equal sub sub' 35 | 36 | type e = [ `Delegation of [ `raw ] Domain_name.t * (int32 * Domain_name.Host_set.t) 37 | | `EmptyNonTerminal of [ `raw ] Domain_name.t * Soa.t 38 | | `NotAuthoritative 39 | | `NotFound of [ `raw ] Domain_name.t * Soa.t ] 40 | 41 | let pp_e ppf = function 42 | | `Delegation (name, (ttl, ns)) -> 43 | Fmt.pf ppf "delegation %a to TTL %lu %a" Domain_name.pp name ttl 44 | Fmt.(list ~sep:(unit ",@,") Domain_name.pp) (Domain_name.Host_set.elements ns) 45 | | `EmptyNonTerminal (name, soa) -> 46 | Fmt.pf ppf "empty non terminal %a SOA %a" Domain_name.pp name Soa.pp soa 47 | | `NotAuthoritative -> Fmt.string ppf "not authoritative" 48 | | `NotFound (name, soa) -> Fmt.pf ppf "not found %a soa %a" Domain_name.pp name Soa.pp soa 49 | 50 | 51 | open Rresult.R.Infix 52 | 53 | let guard p err = if p then Ok () else Error err 54 | 55 | let ent name map = 56 | let soa = Rr_map.get Soa map in 57 | `EmptyNonTerminal (name, soa) 58 | 59 | let to_ns name map = 60 | let ttl, ns = 61 | match Rr_map.find Ns map with 62 | | None -> 0l, Domain_name.Host_set.empty 63 | | Some (ttl, ns) -> ttl, ns 64 | in 65 | (name, ttl, ns) 66 | 67 | let check_zone = function 68 | | None -> Error `NotAuthoritative 69 | | Some (`Delegation (name, (ttl, ns))) -> Error (`Delegation (name, (ttl, ns))) 70 | | Some (`Soa (z, zmap)) -> Ok (z, zmap) 71 | 72 | let lookup_res zone ty m = 73 | check_zone zone >>= fun (z, zmap) -> 74 | guard (not (Rr_map.is_empty m)) (ent z zmap) >>= fun () -> 75 | match Rr_map.find ty m with 76 | | Some v -> Ok (Rr_map.B (ty, v), to_ns z zmap) 77 | | None -> match Rr_map.find Cname m with 78 | | None when Rr_map.cardinal m = 1 && Rr_map.(mem Soa m) -> 79 | (* this is primary a hack for localhost, which must be NXDomain, 80 | but there's a SOA for localhost (to handle it authoritatively) *) 81 | (* TODO should we check that the label-node map is empty? 82 | well, if we have a proper authoritative zone, there'll be a NS *) 83 | let soa = Rr_map.get Rr_map.Soa zmap in 84 | Error (`NotFound (z, soa)) 85 | | None -> Error (ent z zmap) 86 | | Some cname -> Ok (B (Cname, cname), to_ns z zmap) 87 | 88 | let lookup_aux name t = 89 | let k = Domain_name.to_array name in 90 | let l = Array.length k in 91 | let fzone idx map = 92 | let name = Domain_name.(of_array (Array.sub (to_array name) 0 idx)) in 93 | match Rr_map.mem Soa map, Rr_map.find Ns map with 94 | | true, _ -> Some (`Soa (name, map)) 95 | | false, Some ns -> Some (`Delegation (name, ns)) 96 | | false, None -> None 97 | in 98 | let rec go idx zone = function 99 | | N (sub, map) -> 100 | let zone = match fzone idx map with None -> zone | Some x -> Some x in 101 | if idx = l then Ok (zone, sub, map) 102 | else match M.find (Array.get k idx) sub with 103 | | exception Not_found -> 104 | begin match zone with 105 | | None -> Error `NotAuthoritative 106 | | Some (`Delegation (name, (ttl, ns))) -> 107 | Error (`Delegation (name, (ttl, ns))) 108 | | Some (`Soa (name, map)) -> 109 | let soa = Rr_map.get Soa map in 110 | Error (`NotFound (name, soa)) 111 | end 112 | | x -> go (succ idx) zone x 113 | in 114 | go 0 None t 115 | 116 | let lookup_with_cname name ty t = 117 | lookup_aux name t >>= fun (zone, _sub, map) -> 118 | lookup_res zone ty map 119 | 120 | let lookup name key t = 121 | match lookup_aux name t with 122 | | Error e -> Error e 123 | | Ok (zone, _sub, map) -> 124 | match Rr_map.find key map with 125 | | Some v -> Ok v 126 | | None -> match zone with 127 | | None -> Error `NotAuthoritative 128 | | Some (`Delegation (name, (ttl, ns))) -> Error (`Delegation (name, (ttl, ns))) 129 | | Some (`Soa (z, zmap)) -> Error (ent z zmap) 130 | 131 | let lookup_any name t = 132 | match lookup_aux name t with 133 | | Error e -> Error e 134 | | Ok (zone, _sub, m) -> 135 | check_zone zone >>= fun (z, zmap) -> 136 | Ok (m, to_ns z zmap) 137 | 138 | let lookup_glue name t = 139 | match lookup_aux name t with 140 | | Error _ -> None, None 141 | | Ok (_zone, _sub, map) -> Rr_map.find A map, Rr_map.find Aaaa map 142 | 143 | let zone name t = 144 | match lookup_aux name t with 145 | | Error e -> Error e 146 | | Ok (zone, _, _) -> 147 | match check_zone zone with 148 | | Error e -> Error e 149 | | Ok (name, map) -> 150 | (* we ended with `Soa, which checked that map contains a Soa *) 151 | Ok (name, Rr_map.get Soa map) 152 | 153 | let fold key (N (sub, map)) f s = 154 | let get name map acc = 155 | match Rr_map.find key map with 156 | | Some a -> f name a acc 157 | | None -> acc 158 | in 159 | let rec collect name sub acc = 160 | List.fold_left (fun acc (pre, N (sub, map)) -> 161 | let n' = Domain_name.prepend_label_exn name pre in 162 | let keys = get n' map acc in 163 | collect n' sub keys) 164 | acc (M.bindings sub) 165 | in 166 | let name = Domain_name.root in 167 | collect name sub (get name map s) 168 | 169 | let collect_rrs name sub map = 170 | (* TODO: do not cross zone boundaries! or maybe not!? *) 171 | let collect_map name rrmap = 172 | (* collecting rr out of rrmap + name, no SOA! *) 173 | Rr_map.fold (fun v acc -> 174 | match v with 175 | | Rr_map.(B (Soa, _)) -> acc 176 | | v -> (name, v) :: acc) 177 | rrmap [] 178 | in 179 | let rec go name sub map = 180 | let entries = collect_map name map in 181 | List.fold_left 182 | (fun acc (pre, N (sub, map)) -> 183 | acc @ go (Domain_name.prepend_label_exn name pre) sub map) 184 | entries (M.bindings sub) 185 | in 186 | go name sub map 187 | 188 | let collect_entries name sub map = 189 | let ttlsoa = 190 | match Rr_map.find Soa map with 191 | | Some v -> Some v 192 | | None when Domain_name.(equal root name) -> 193 | Some { Soa.nameserver = Domain_name.root ; 194 | hostmaster = Domain_name.root ; 195 | serial = 0l ; refresh = 0l ; retry = 0l ; 196 | expiry = 0l ; minimum = 0l } 197 | | None -> None 198 | in 199 | match ttlsoa with 200 | | None -> Error `NotAuthoritative 201 | | Some soa -> 202 | let entries = collect_rrs name sub map in 203 | let map = 204 | List.fold_left (fun acc (name, (Rr_map.B (k, v))) -> 205 | Name_rr_map.add name k v acc) Domain_name.Map.empty entries 206 | in 207 | Ok (soa, map) 208 | 209 | let entries name t = 210 | let name = Domain_name.raw name in 211 | lookup_aux name t >>= fun (zone, sub, map) -> 212 | match zone with 213 | | None -> Error `NotAuthoritative 214 | | Some (`Delegation (name, (ttl, ns))) -> 215 | Error (`Delegation (name, (ttl, ns))) 216 | | Some (`Soa (name', _)) when Domain_name.equal name name' -> 217 | collect_entries name sub map 218 | | Some (`Soa (_, _)) -> Error `NotAuthoritative 219 | 220 | type zone_check = [ `Missing_soa of [ `raw ] Domain_name.t 221 | | `Cname_other of [ `raw ] Domain_name.t 222 | | `Bad_ttl of [ `raw ] Domain_name.t * Rr_map.b 223 | | `Empty of [ `raw ] Domain_name.t * Rr_map.k 224 | | `Missing_address of [ `host ] Domain_name.t 225 | | `Soa_not_ns of [ `raw ] Domain_name.t 226 | | `Soa_not_a_host of [ `raw ] Domain_name.t * string ] 227 | 228 | let pp_zone_check ppf = function 229 | | `Missing_soa name -> Fmt.pf ppf "missing soa for %a" Domain_name.pp name 230 | | `Cname_other name -> Fmt.pf ppf "%a contains a cname record, and also other entries" Domain_name.pp name 231 | | `Bad_ttl (name, v) -> Fmt.pf ppf "bad TTL for %a %a" Domain_name.pp name Rr_map.pp_b v 232 | | `Empty (name, typ) -> Fmt.pf ppf "%a empty %a" Domain_name.pp name Rr_map.ppk typ 233 | | `Missing_address name -> Fmt.pf ppf "missing address record for %a" Domain_name.pp name 234 | | `Soa_not_ns name -> Fmt.pf ppf "%a nameserver of SOA is not in nameserver set" Domain_name.pp name 235 | | `Soa_not_a_host (name, msg) -> Fmt.pf ppf "%a the SOA nameserver is not a hostname: %s" Domain_name.pp name msg 236 | 237 | (* TODO: check for no cname loops? and dangling cname!? *) 238 | let check trie = 239 | let has_address name = 240 | match lookup name Rr_map.A trie with 241 | | Ok _ -> true 242 | | Error (`Delegation _) -> true 243 | | _ -> match lookup name Rr_map.Aaaa trie with 244 | | Ok _ -> true 245 | | _ -> false 246 | in 247 | let rec check_sub names state sub map = 248 | let name = Domain_name.of_strings_exn names in 249 | let state' = 250 | match Rr_map.find Soa map with 251 | | None -> begin match Rr_map.find Ns map with 252 | | None -> state 253 | | Some _ -> `None 254 | end 255 | | Some _ -> `Soa name 256 | in 257 | guard ((Rr_map.mem Cname map && Rr_map.cardinal map = 1) || 258 | not (Rr_map.mem Cname map)) (`Cname_other name) >>= fun () -> 259 | Rr_map.fold (fun v r -> 260 | r >>= fun () -> 261 | match v with 262 | | B (Dnskey, (ttl, keys)) -> 263 | if ttl < 0l then Error (`Bad_ttl (name, v)) 264 | else if Rr_map.Dnskey_set.is_empty keys then 265 | Error (`Empty (name, Rr_map.K Dnskey)) 266 | else Ok () 267 | | B (Ns, (ttl, names)) -> 268 | if ttl < 0l then Error (`Bad_ttl (name, v)) 269 | else if Domain_name.Host_set.is_empty names then 270 | Error (`Empty (name, K Ns)) 271 | else 272 | let domain = match state' with `None -> name | `Soa zone -> zone in 273 | Domain_name.Host_set.fold (fun name r -> 274 | r >>= fun () -> 275 | if Domain_name.sub ~subdomain:name ~domain then 276 | guard (has_address name) (`Missing_address name) 277 | else 278 | Ok ()) names (Ok ()) 279 | | B (Cname, (ttl, _)) -> 280 | if ttl < 0l then Error (`Bad_ttl (name, v)) else Ok () 281 | | B (Mx, (ttl, mxs)) -> 282 | if ttl < 0l then 283 | Error (`Bad_ttl (name, v)) 284 | else if Rr_map.Mx_set.is_empty mxs then 285 | Error (`Empty (name, K Mx)) 286 | else 287 | let domain = match state' with `None -> name | `Soa zone -> zone in 288 | Rr_map.Mx_set.fold (fun { mail_exchange ; _ } r -> 289 | r >>= fun () -> 290 | if Domain_name.sub ~subdomain:mail_exchange ~domain then 291 | guard (has_address mail_exchange) (`Missing_address mail_exchange) 292 | else 293 | Ok ()) 294 | mxs (Ok ()) 295 | | B (Ptr, (ttl, name)) -> 296 | if ttl < 0l then Error (`Bad_ttl (Domain_name.raw name, v)) else Ok () 297 | | B (Soa, soa) -> 298 | begin match Rr_map.find Ns map with 299 | | Some (_, names) -> 300 | begin match Domain_name.host soa.nameserver with 301 | | Error (`Msg m) -> Error (`Soa_not_a_host (soa.nameserver, m)) 302 | | Ok host when Domain_name.Host_set.mem host names -> Ok () 303 | | Ok _ -> Error (`Soa_not_ns soa.nameserver) 304 | end 305 | | None -> Ok () (* we're happy to only have a soa, but nothing else -- useful for grounding zones! *) 306 | end 307 | | B (Txt, (ttl, txts)) -> 308 | if ttl < 0l then Error (`Bad_ttl (name, v)) 309 | else if Rr_map.Txt_set.is_empty txts then 310 | Error (`Empty (name, K Txt)) 311 | else if 312 | Rr_map.Txt_set.exists (fun s -> String.length s > 0) txts 313 | then 314 | Ok () 315 | else 316 | Error (`Empty (name, K Txt)) 317 | | B (A, (ttl, a)) -> 318 | if ttl < 0l then Error (`Bad_ttl (name, v)) 319 | else if Rr_map.Ipv4_set.is_empty a then 320 | Error (`Empty (name, K A)) 321 | else Ok () 322 | | B (Aaaa, (ttl, aaaa)) -> 323 | if ttl < 0l then Error (`Bad_ttl (name, v)) 324 | else if Rr_map.Ipv6_set.is_empty aaaa then 325 | Error (`Empty (name, K Aaaa)) 326 | else Ok () 327 | | B (Srv, (ttl, srvs)) -> 328 | if ttl < 0l then Error (`Bad_ttl (name, v)) 329 | else if Rr_map.Srv_set.is_empty srvs then 330 | Error (`Empty (name, K Srv)) 331 | else Ok () 332 | | B (Caa, (ttl, caas)) -> 333 | if ttl < 0l then Error (`Bad_ttl (name, v)) 334 | else if Rr_map.Caa_set.is_empty caas then 335 | Error (`Empty (name, K Caa)) 336 | else Ok () 337 | | B (Tlsa, (ttl, tlsas)) -> 338 | if ttl < 0l then Error (`Bad_ttl (name, v)) 339 | else if Rr_map.Tlsa_set.is_empty tlsas then 340 | Error (`Empty (name, K Tlsa)) 341 | else Ok () 342 | | B (Sshfp, (ttl, sshfps)) -> 343 | if ttl < 0l then Error (`Bad_ttl (name, v)) 344 | else if Rr_map.Sshfp_set.is_empty sshfps then 345 | Error (`Empty (name, K Sshfp)) 346 | else Ok () 347 | | B (Unknown x, (ttl, datas)) -> 348 | if ttl < 0l then Error (`Bad_ttl (name, v)) 349 | else if Rr_map.Txt_set.is_empty datas then 350 | Error (`Empty (name, K (Unknown x))) 351 | else Ok ()) 352 | map (Ok ()) >>= fun () -> 353 | M.fold (fun lbl (N (sub, map)) r -> 354 | r >>= fun () -> 355 | check_sub (lbl :: names) state' sub map) sub (Ok ()) 356 | in 357 | let (N (sub, map)) = trie in 358 | check_sub [] `None sub map 359 | 360 | let find f name t = 361 | let lbls = Domain_name.to_array name in 362 | let l = Array.length lbls in 363 | let rec go idx (N (sub, map)) = 364 | if idx = l then 365 | let sub', map' = f sub map in 366 | N (sub', map') 367 | else 368 | let lbl = Array.get lbls idx in 369 | let node = match M.find lbl sub with 370 | | exception Not_found -> empty 371 | | x -> x 372 | in 373 | let node' = go (succ idx) node in 374 | if is_empty node' then 375 | N (M.remove lbl sub, map) 376 | else 377 | N (M.add lbl node' sub, map) 378 | in 379 | go 0 t 380 | 381 | let replace name k v t = 382 | find (fun sub map -> sub, Rr_map.add k v map) name t 383 | 384 | let insert name k v t = 385 | let merge sub map = 386 | let new_v = match Rr_map.find k map with 387 | | None -> v 388 | | Some v' -> Rr_map.union_rr k v' v 389 | in 390 | sub, Rr_map.add k new_v map 391 | in 392 | find merge name t 393 | 394 | let replace_map m t = 395 | Domain_name.Map.fold (fun name map trie -> 396 | find (fun sub _ -> sub, map) name trie) m t 397 | 398 | let insert_map m t = 399 | Domain_name.Map.fold (fun name map trie -> 400 | let union sub old = sub, Rr_map.union { f = Rr_map.unionee } old map in 401 | find union name trie) 402 | m t 403 | 404 | let remove k ty v t = 405 | let remove sub map = 406 | let map' = match Rr_map.find ty map with 407 | | None -> map 408 | | Some old -> match Rr_map.remove_rr ty old v with 409 | | None -> Rr_map.remove ty map 410 | | Some v' -> Rr_map.add ty v' map 411 | in 412 | sub, map' 413 | in 414 | find remove k t 415 | 416 | let remove_ty k ty t = 417 | let remove sub map = sub, Rr_map.remove ty map in 418 | find remove k t 419 | 420 | let remove_all k t = 421 | let remove sub _ = sub, Rr_map.empty in 422 | find remove k t 423 | 424 | let remove_map m t = 425 | let merge k present remove = match present, remove with 426 | | None, None -> None 427 | | Some x, None -> Some x 428 | | None, Some _ -> None 429 | | Some x, Some y -> Rr_map.remove_rr k x y 430 | in 431 | Domain_name.Map.fold (fun name map trie -> 432 | let remove sub old = sub, Rr_map.merge { f = merge } old map in 433 | find remove name trie) 434 | m t 435 | 436 | let remove_zone name t = 437 | let remove sub _ = 438 | (* go through all of sub, and retain those subtrees with Soa *) 439 | let rec fold_sub sub = 440 | M.fold (fun lbl node acc -> 441 | match go node with None -> acc | Some n -> M.add lbl n acc) 442 | sub M.empty 443 | and go (N (sub, map)) = 444 | match Rr_map.find Soa map with 445 | | None -> 446 | (* no SOA, continue search *) 447 | let sub' = fold_sub sub in 448 | if M.is_empty sub' then None else Some (N (sub', Rr_map.empty)) 449 | | Some _ -> 450 | (* SOA, retain this submap *) 451 | Some (N (sub, map)) 452 | in 453 | fold_sub sub, Rr_map.empty (* drop the initial RRmap in any case! *) 454 | in 455 | find remove name t 456 | 457 | let diff zone req_soa ~old current = 458 | match entries zone current with 459 | | Error _ -> Error (`Msg "couldn't find zone in current trie") 460 | | Ok (soa, map) -> 461 | if not (Soa.newer ~old:req_soa soa) then 462 | Ok (soa, `Empty) 463 | else 464 | match entries zone old with 465 | | Error _ -> Ok (soa, `Full map) 466 | | Ok (oldsoa, oldmap) -> 467 | (* first, we fold over old map and collect the differences in two maps *) 468 | let (to_remove, to_add), names = 469 | Domain_name.Map.fold (fun name old ((to_remove, to_add), names) -> 470 | let newmap = 471 | match Domain_name.Map.find name map with 472 | | None -> Rr_map.empty | Some x -> x 473 | in 474 | (match Rr_map.diff ~old newmap with 475 | | None, None -> to_remove, to_add 476 | | Some rm, None -> Domain_name.Map.add name rm to_remove, to_add 477 | | None, Some add -> to_remove, Domain_name.Map.add name add to_add 478 | | Some rm, Some add -> 479 | Domain_name.Map.add name rm to_remove, 480 | Domain_name.Map.add name add to_add), 481 | Domain_name.Set.add name names) 482 | oldmap Domain_name.((Map.empty, Map.empty), Set.empty) 483 | in 484 | (* now we fold over newmap and add then unless already handled *) 485 | let to_add = 486 | Domain_name.Map.fold (fun name newmap to_add -> 487 | if Domain_name.Set.mem name names then 488 | to_add 489 | else 490 | Domain_name.Map.add name newmap to_add) 491 | map to_add 492 | in 493 | Ok (soa, `Difference (oldsoa, to_remove, to_add)) 494 | --------------------------------------------------------------------------------