unikernel/duniverse/ocaml-dns/client/dns_client.ml

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

unikernel/duniverse/ocaml-dns/client/dns_client.mli

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

unikernel/duniverse/ocaml-dns/client/dune

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