unikernel/duniverse/domain-name/.gitignore

@@ -0,0 +1,3 @@
+_build/
+*.install
+.merlin

unikernel/duniverse/domain-name/CHANGES.md

@@ -0,0 +1,61 @@
+## v0.5.0 (2025-10-13)
+
+* Disallow trailing hyphen (-) in host labels (#15 @hannes, fixes #14)
+
+## v0.4.1 (2025-02-17)
+
+* handle root specially for encoding and decoding (#12 @reynir, fixes #10)
+
+## v0.4.0 (2022-01-07)
+
+* compare: conform to canonical DNS name order (RFC 4034, Section 6.1)
+
+## v0.3.1 (2021-10-27)
+
+* remove fmt and astring dependency
+
+## v0.3.0 (2019-07-08)
+
+* all optional ?back arguments are now ?rev
+* compare_sub is now compare_label
+* new function: equal_label : ?case_sensitive:bool -> string -> string -> bool
+* new function: find_label : ?rev:bool -> 'a t -> (string -> bool) -> int option
+  which searches for the predicate (3rd argument) in t (2nd arguments)
+
+## v0.2.1 (2019-06-30)
+
+* getter functions for labels:
+  get_label : 'a t -> int -> (string, [> `Msg of string ]) result
+  get_label_exn : 'a t -> int -> string
+* count_labels : 'a t -> int
+
+## v0.2.0 (2019-06-25)
+
+* type t is now a phantom type 'a t, where 'a carries whether it is a hostname,
+  a service name or a raw domain name. this lead to removal of various
+  ?hostname:bool arguments
+* val host : 'a t -> ([`host] t, [> `Msg of string ]) result
+* analog host_exn, service, service_exn, raw
+* removed is_service, is_hostname
+* new submodules Host_set, Host_map, Service_set, Service_map
+* new function: append : 'a t -> 'b t -> ([`raw] t, [> `Msg of string ]) result
+* renamed: drop_labels{,_exn} is now drop_label{,_exn}
+* renamed: prepend{,_exn} is now prepend_label{,_exn}
+
+## 0.1.2 (2019-02-16)
+
+* `is_service` accepts numeric service names, used for ports in TLSA records (#1 by @cfcs)
+* port to dune
+
+## 0.1.1 (2018-07-07)
+
+* `to_string` and `to_strings` now have an optional labeled `trailing` argument
+  of type bool
+* support for FQDN with trailing dot: `of_string "example.com."` now returns
+  `Ok`, and is equal to `of_string "example.com"`
+* fix and add tests for `drop_labels` and `drop_labels_exn`, where the semantics
+  of the labeled `back` argument was inversed.
+
+## 0.1.0 (2018-06-26)
+
+* Initial release

unikernel/duniverse/domain-name/LICENSE.md

@@ -0,0 +1,16 @@
+(*
+ * Copyright (c) 2017 2018 Hannes Mehnert <hannes@mehnert.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)

unikernel/duniverse/domain-name/README.md

@@ -0,0 +1,27 @@
+## Domain-name - [RFC 1035](https://tools.ietf.org/html/rfc1035) Internet domain names
+
+v0.5.0
+
+A domain name is a sequence of labels separated by dots, such as `foo.example`.
+Each label may contain any bytes. The length of each label may not exceed 63
+charactes.  The total length of a domain name is limited to 253 (byte
+representation is 255), but other protocols (such as SMTP) may apply even
+smaller limits.  A domain name label is case preserving, comparison is done in a
+case insensitive manner.
+
+The invariants on the length of domain names are preserved throughout the
+module.
+
+## Documentation
+
+[![Build Status](https://travis-ci.org/hannesm/domain-name.svg?branch=master)](https://travis-ci.org/hannesm/domain-name)
+
+[API documentation](https://hannesm.github.io/domain-name/doc/) is available online.
+
+## Installation
+
+You need [opam](https://opam.ocaml.org) installed on your system.  The command
+
+`opam install domain-name`
+
+will install this library.

unikernel/duniverse/domain-name/domain-name.opam

@@ -0,0 +1,29 @@
+version: "0.5.0"
+opam-version: "2.0"
+maintainer: "Hannes Mehnert <hannes@mehnert.org>"
+authors: "Hannes Mehnert <hannes@mehnert.org>"
+license: "ISC"
+homepage: "https://github.com/hannesm/domain-name"
+doc: "https://hannesm.github.io/domain-name/doc"
+bug-reports: "https://github.com/hannesm/domain-name/issues"
+depends: [
+  "ocaml" {>= "4.04.2"}
+  "dune" {>= "1.0"}
+  "alcotest" {with-test}
+]
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+dev-repo: "git+https://github.com/hannesm/domain-name.git"
+synopsis: "RFC 1035 Internet domain names"
+description: """
+A domain name is a sequence of labels separated by dots, such as `foo.example`.
+Each label may contain any bytes. The length of each label may not exceed 63
+charactes.  The total length of a domain name is limited to 253 (byte
+representation is 255), but other protocols (such as SMTP) may apply even
+smaller limits.  A domain name label is case preserving, comparison is done in a
+case insensitive manner.
+"""
+x-maintenance-intent: [ "(latest)" ]

unikernel/duniverse/domain-name/domain_name.ml

@@ -0,0 +1,284 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+type 'a s = string array
+
+let root = Array.make 0 ""
+
+let [@inline always] is_letter = function
+  | 'a'..'z' | 'A'..'Z' -> true
+  | _ -> false
+
+let [@inline always] is_ldh = function
+  | '0'..'9' | 'a'..'z' | 'A'..'Z' | '-' -> true
+  | _ -> false
+
+(* from OCaml 4.13 bytes.ml *)
+let for_all p s =
+  let n = String.length s in
+  let rec loop i =
+    if i = n then true
+    else if p (String.unsafe_get s i) then loop (succ i)
+    else false in
+  loop 0
+
+let exists p s =
+  let n = String.length s in
+  let rec loop i =
+    if i = n then false
+    else if p (String.unsafe_get s i) then true
+    else loop (succ i) in
+  loop 0
+
+let [@inline always] check_host_label s =
+  String.get s 0 <> '-' && (* leading may not be '-' *)
+  String.get s (String.length s - 1) <> '-' && (* trailing may not be '-' *)
+  for_all is_ldh s (* only LDH (letters, digits, hyphen)! *)
+
+let host_exn t =
+  (* TLD should not be all-numeric! *)
+  if
+    (if Array.length t > 0 then
+       exists is_letter (Array.get t 0)
+     else true) &&
+    Array.for_all check_host_label t
+  then
+    t
+  else
+    invalid_arg "invalid host name"
+
+let host t =
+  try Ok (host_exn t) with
+  | Invalid_argument e -> Error (`Msg e)
+
+let check_service_label s =
+  if String.length s > 0 && String.unsafe_get s 0 = '_' then
+    let srv = String.sub s 1 (String.length s - 1) in
+    let slen = String.length srv in
+    (* service label: 1-15 characters; LDH; hyphen _not_ at begin nor end; no hyphen following a hyphen *)
+    slen > 0 && slen <= 15 &&
+    for_all is_ldh srv &&
+    String.unsafe_get srv 0 <> '-' &&
+    String.unsafe_get srv (slen - 1) <> '-' &&
+    List.for_all (fun l -> l <> "")
+      (String.split_on_char '-' srv)
+  else
+    false
+
+let [@inline always] is_proto s =
+  s = "_tcp" || s = "_udp" || s = "_sctp"
+
+let [@inline always] check_label_length s =
+  let l = String.length s in
+  l < 64 && l > 0
+
+let [@inline always] check_total_length t =
+  Array.fold_left (fun acc s -> acc + 1 + String.length s) 1 t <= 255
+
+let service_exn t =
+  let l = Array.length t in
+  if
+    if l > 2 then
+      let name = Array.sub t 0 (l - 2) in
+      check_service_label (Array.get t (l - 1)) &&
+      is_proto (Array.get t (l - 2)) &&
+      Array.for_all check_label_length name &&
+      check_total_length t &&
+      match host name with Ok _ -> true | Error _ -> false
+    else
+      false
+  then
+    t
+  else
+    invalid_arg "invalid service name"
+
+let service t =
+  try Ok (service_exn t) with
+  | Invalid_argument e -> Error (`Msg e)
+
+let raw t = t
+
+let [@inline always] check t =
+  Array.for_all check_label_length t &&
+  check_total_length t
+
+let get_label_exn ?(rev = false) xs idx =
+  let idx' = if rev then idx else pred (Array.length xs) - idx in
+  try Array.get xs idx' with
+  | Invalid_argument _ -> invalid_arg "bad index for domain name"
+
+let get_label ?rev xs idx =
+  try Ok (get_label_exn ?rev xs idx) with
+  | Invalid_argument e -> Error (`Msg e)
+
+let find_label_exn ?(rev = false) xs p =
+  let l = pred (Array.length xs) in
+  let check x = x >= 0 && x <= l in
+  let rec go next idx =
+    if check idx then
+      if p (Array.get xs idx) then
+        idx
+      else
+        go next (next idx)
+    else
+      invalid_arg "label not found"
+  in
+  let next, start = if rev then (succ, 0) else (pred, l) in
+  let r = go next start in
+  l - r
+
+let find_label ?rev xs p =
+  try Some (find_label_exn ?rev xs p) with
+  | Invalid_argument _ -> None
+
+let count_labels xs = Array.length xs
+
+let prepend_label_exn xs lbl =
+  let n = Array.make 1 lbl in
+  let n = Array.append xs n in
+  if check_label_length lbl && check_total_length n then n
+  else invalid_arg "invalid domain name"
+
+let prepend_label xs lbl =
+  try Ok (prepend_label_exn xs lbl) with
+  | Invalid_argument e -> Error (`Msg e)
+
+let drop_label_exn ?(rev = false) ?(amount = 1) t =
+  let len = Array.length t - amount
+  and start = if rev then amount else 0
+  in
+  Array.sub t start len
+
+let drop_label ?rev ?amount t =
+  try Ok (drop_label_exn ?rev ?amount t) with
+  | Invalid_argument _ -> Error (`Msg "couldn't drop labels")
+
+let append_exn pre post =
+  let r = Array.append post pre in
+  if check_total_length r then r else invalid_arg "invalid domain name"
+
+let append pre post =
+  try Ok (append_exn pre post) with
+  | Invalid_argument _ -> Error (`Msg "couldn't concatenate domain names")
+
+let of_strings_exn xs =
+  let labels =
+    (* we support both example.com. and example.com *)
+    match List.rev xs with
+    | ""::rst -> rst
+    | rst -> rst
+  in
+  let t = Array.of_list labels in
+  if check t then t
+  else invalid_arg "invalid domain name"
+
+let of_strings xs =
+  try Ok (of_strings_exn xs) with
+  | Invalid_argument e -> Error (`Msg e)
+
+let of_string_exn = function
+  | "." -> root
+  | s -> of_strings_exn (String.split_on_char '.' s)
+
+let of_string s =
+  try Ok (of_string_exn s) with
+  | Invalid_argument e -> Error (`Msg e)
+
+let of_array a = a
+
+let to_array a = a
+
+let to_strings ?(trailing = false) dn =
+  let labels = Array.to_list dn in
+  List.rev (if trailing then "" :: labels else labels)
+
+let to_string ?trailing dn =
+  match to_strings ?trailing dn with
+  | [""] -> "."
+  | labels -> String.concat "." labels
+
+let canonical t =
+  let str = to_string t in
+  of_string_exn (String.lowercase_ascii str)
+
+let pp ppf xs = Format.pp_print_string ppf (to_string xs)
+
+let compare_label a b =
+  String.compare (String.lowercase_ascii a) (String.lowercase_ascii b)
+
+let compare_domain cmp_sub a b =
+  let al = Array.length a and bl = Array.length b in
+  let rec cmp idx =
+    if al = bl && al = idx then 0
+    else if al = idx then -1
+    else if bl = idx then 1
+    else
+      match cmp_sub (Array.get a idx) (Array.get b idx) with
+      | 0 -> cmp (succ idx)
+      | x -> x
+  in
+  cmp 0
+
+let compare = compare_domain compare_label
+
+let equal_label ?(case_sensitive = false) a b =
+  let cmp = if case_sensitive then String.compare else compare_label in
+  cmp a b = 0
+
+let equal ?(case_sensitive = false) a b =
+  let cmp = if case_sensitive then String.compare else compare_label in
+  compare_domain cmp a b = 0
+
+let is_subdomain ~subdomain ~domain =
+  let supl = Array.length domain in
+  let rec cmp idx =
+    if idx = supl then
+      true
+    else
+      compare_label (Array.get domain idx) (Array.get subdomain idx) = 0 &&
+      cmp (succ idx)
+  in
+  if Array.length subdomain < supl then
+    false
+  else
+    cmp 0
+
+module Ordered = struct
+  type t = [ `raw ] s
+  let compare = compare_domain compare_label
+end
+
+module Host_ordered = struct
+  type t = [ `host ] s
+  let compare = compare_domain compare_label
+end
+
+module Service_ordered = struct
+  type t = [ `service ] s
+  let compare = compare_domain compare_label
+end
+
+type 'a t = 'a s
+
+module Host_map = struct
+  include Map.Make(Host_ordered)
+
+  let find k m = try Some (find k m) with Not_found -> None
+end
+
+module Host_set = Set.Make(Host_ordered)
+
+module Service_map = struct
+  include Map.Make(Service_ordered)
+
+  let find k m = try Some (find k m) with Not_found -> None
+end
+
+module Service_set = Set.Make(Service_ordered)
+
+module Map = struct
+  include Map.Make(Ordered)
+
+  let find k m = try Some (find k m) with Not_found -> None
+end
+
+module Set = Set.Make(Ordered)

unikernel/duniverse/domain-name/domain_name.mli

@@ -0,0 +1,249 @@
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
+type 'a t
+(** The type of a domain name, a sequence of labels separated by dots.  Each
+   label may contain any bytes. The length of each label may not exceed 63
+   characters.  The total length of a domain name is limited to 253 (its byte
+   representation is 255), but other protocols (such as SMTP) may apply even
+   smaller limits.  A domain name label is case preserving, comparison is done
+   in a case insensitive manner.  Every [t] is a fully qualified domain name,
+   its last label is the [root] label. The specification of domain names
+   originates from {{:https://tools.ietf.org/html/rfc1035}RFC 1035}.
+
+    The invariants on the length of domain names are preserved throughout the
+   module - no [t] will exist which violates these.
+
+    Phantom types are used for further name restrictions, {!host} checks for
+   host names ([`host t]): only letters, digits, and hyphen allowed, hyphen not
+   first or last character of a label, the last label must contain at least one letter.
+   {!service} checks for a service name ([`service t]): its first label is a
+   service name: 1-15 characters, no double-hyphen, hyphen not first or last
+   charactes, only letters, digits and hyphen allowed, and the second label is a
+   protocol ([_tcp] or [_udp] or [_sctp]).
+
+    When a [t] is constructed (either from a string, etc.), it is a [`raw t].
+   Subsequent modifications, such as adding or removing labels, appending, of
+   any kind of name also result in a [`raw t], which needs to be checked for
+   [`host t] (using {!host}) or [`service t] (using {!service}) if desired.
+
+    Constructing a [t] (via {!of_string}, {!of_string_exn}, {!of_strings} etc.)
+   does not require a trailing dot.
+
+
+    {e v0.5.0 - {{:https://github.com/hannesm/domain-name }homepage}} *)
+
+(** {2 Constructor} *)
+
+val root : [ `raw ] t
+(** [root] is the root domain ("."), the empty label. *)
+
+(** {2 String representation} *)
+
+val of_string : string -> ([ `raw ] t, [> `Msg of string ]) result
+(** [of_string name] is either [t], the domain name, or an error if the provided
+    [name] is not a valid domain name. A trailing dot is not requred. *)
+
+val of_string_exn : string -> [ `raw ] t
+(** [of_string_exn name] is [t], the domain name. A trailing dot is not
+    required.
+
+    @raise Invalid_argument if [name] is not a valid domain name. *)
+
+val to_string : ?trailing:bool -> 'a t -> string
+(** [to_string ~trailing t] is [String.concat ~sep:"." (to_strings t)], a
+    human-readable representation of [t].  If [trailing] is provided and
+    [true] (defaults to [false]), the resulting string will contain a trailing
+    dot. *)
+
+(** {2 Predicates and basic operations} *)
+
+val canonical : 'a t -> 'a t
+(** [canonical t] is [t'], the canonical domain name, as specified in RFC 4034
+    (and 2535): all characters are lowercase. *)
+
+val host : 'a t -> ([ `host ] t, [> `Msg of string ]) result
+(** [host t] is a [`host t] if [t] is a hostname: the contents of the domain
+    name is limited: each label may start with a digit or letter, followed by
+    digits, letters, or hyphens. *)
+
+val host_exn : 'a t -> [ `host ] t
+(** [host_exn t] is a [`host t] if [t] is a hostname: the contents of the domain
+    name is limited: each label may start with a digit or letter, followed by
+    digits, letters, or hyphens.
+
+    @raise Invalid_argument if [t] is not a hostname. *)
+
+val service : 'a t -> ([ `service ] t, [> `Msg of string ]) result
+(** [service t] is [`service t] if [t] contains a service name, the following
+    conditions have to be met:
+    The first label is a service name (or port number); an underscore preceding
+    1-15 characters from the set [- a-z A-Z 0-9].
+    The service name may not contain a hyphen ([-]) following another hyphen;
+    no hyphen at the beginning or end.
+
+    The second label is the protocol, one of [_tcp], [_udp], or [_sctp].
+    The remaining labels must form a valid hostname.
+
+    This function can be used to validate RR's of the types SRV (RFC 2782)
+    and TLSA (RFC 7671). *)
+
+val service_exn : 'a t -> [ `service ] t
+(** [service_exn t] is [`service t] if [t] is a service name (see {!service}).
+
+    @raise Invalid_argument if [t] is not a service names. *)
+
+val raw : 'a t -> [ `raw ] t
+(** [raw t] is the [`raw t]. *)
+
+val count_labels : 'a t -> int
+(** [count_labels name] returns the amount of labels in [name]. *)
+
+val is_subdomain : subdomain:'a t -> domain:'b t -> bool
+(** [is_subdomain ~subdomain ~domain] is [true] if [subdomain] contains any
+    labels prepended to [domain]: [foo.bar.com] is a subdomain of [bar.com] and
+    of [com], [sub ~subdomain:x ~domain:root] is true for all [x]. *)
+
+val get_label : ?rev:bool -> 'a t -> int -> (string, [> `Msg of string ]) result
+(** [get_label ~rev name idx] retrieves the label at index [idx] from [name]. If
+    [idx] is out of bounds, an Error is returned. If [rev] is provided and [true]
+    (defaults to [false]), [idx] is from the end instead of the beginning. *)
+
+val get_label_exn : ?rev:bool -> 'a t -> int -> string
+(** [get_label_exn ~rev name idx] is the label at index [idx] in [name].
+
+    @raise Invalid_argument if [idx] is out of bounds in [name]. *)
+
+val find_label : ?rev:bool -> 'a t -> (string -> bool) -> int option
+(** [find_label ~rev name p] returns the first position where [p lbl] is [true]
+    in [name], if it exists, otherwise [None]. If [rev] is provided and [true]
+    (defaults to [false]), the [name] is traversed from the end instead of the
+    beginning. *)
+
+val find_label_exn : ?rev:bool -> 'a t -> (string -> bool) -> int
+(** [find_label_exn ~rev name p], see {!find_label}.
+
+    @raise Invalid_argument if [p] does not return [true] in [name]. *)
+
+(** {2 Label addition and removal} *)
+val prepend_label : 'a t -> string -> ([ `raw ] t, [> `Msg of string ]) result
+(** [prepend_label name pre] is either [t], the new domain name, or an error. *)
+
+val prepend_label_exn : 'a t -> string -> [ `raw ] t
+(** [prepend_label_exn name pre] is [t], the new domain name.
+
+    @raise Invalid_argument if [pre] is not a valid domain name. *)
+
+val drop_label : ?rev:bool -> ?amount:int -> 'a t ->
+  ([ `raw ] t, [> `Msg of string ]) result
+(** [drop_label ~rev ~amount t] is either [t], a domain name with [amount]
+    (defaults to [1]) labels dropped from the beginning - if [rev] is provided
+    and [true] (defaults to [false]) labels are dropped from the end.
+    [drop_label (of_string_exn "foo.com") = Ok (of_string_exn "com")],
+    [drop_label ~rev:true (of_string_exn "foo.com") = Ok (of_string_exn "foo")].
+*)
+
+val drop_label_exn : ?rev:bool -> ?amount:int -> 'a t -> [ `raw ] t
+(** [drop_label_exn ~rev ~amount t], see {!drop_label}. Instead of a [result],
+    the value is returned directly.
+
+    @raise Invalid_argument if there are not sufficient labels. *)
+
+val append : 'a t -> 'b t -> ([ `raw ] t, [> `Msg of string ]) result
+(** [append pre post] is [pre ^ "." ^ post]. *)
+
+val append_exn : 'a t -> 'b t -> [ `raw ] t
+(** [append_exn pre post] is [pre ^ "." ^ post].
+
+    @raise Invalid_argument if the result would violate length restrictions. *)
+
+(** {2 Comparison} *)
+
+val equal : ?case_sensitive:bool -> 'a t -> 'b t -> bool
+(** [equal ~case_sensitive t t'] is [true] if all labels of [t] and [t'] are
+    equal. If [case_sensitive] is provided and [true], the cases of the labels
+    are respected (defaults to [false]). *)
+
+val compare : 'a t -> 'b t -> int
+(** [compare t t'] compares the domain names [t] and [t'] using a case
+    insensitive string comparison. This conforms to the canonical DNS name
+    order, as described in RFC 4034, Section 6.1. *)
+
+val equal_label : ?case_sensitive:bool -> string -> string -> bool
+(** [equal_label ~case_sensitive a b] is [true] if [a] and [b] are equal
+    ignoring casing. If [case_sensitive] is provided and [true] (defaults to
+    [false]), the casing is respected. *)
+
+val compare_label : string -> string -> int
+(** [compare_label t t'] compares the labels [t] and [t'] using a case
+    insensitive string comparison. *)
+
+(** {2 Collections} *)
+
+module Host_map : sig
+  include Map.S with type key = [ `host ] t
+
+  (** [find key t] is [Some a] where a is the binding of [key] in [t]. [None] if
+      the [key] is not present. *)
+  val find : key -> 'a t -> 'a option
+end
+(** The module of a host name map *)
+
+module Host_set : Set.S with type elt = [ `host ] t
+(** The module of a host name set *)
+
+module Service_map : sig
+  include Map.S with type key = [ `service ] t
+
+  (** [find key t] is [Some a] where a is the binding of [key] in [t]. [None] if
+      the [key] is not present. *)
+  val find : key -> 'a t -> 'a option
+end
+(** The module of a service name map *)
+
+module Service_set : Set.S with type elt = [ `service ] t
+(** The module of a service name set *)
+
+module Map : sig
+  include Map.S with type key = [ `raw ] t
+
+  (** [find key t] is [Some a] where a is the binding of [key] in [t]. [None] if
+      the [key] is not present. *)
+  val find : key -> 'a t -> 'a option
+end
+(** The module of a domain name map *)
+
+module Set : Set.S with type elt = [ `raw ] t
+(** The module of a domain name set *)
+
+(** {2 String list representation} *)
+
+val of_strings : string list -> ([ `raw ] t, [> `Msg of string ]) result
+(** [of_strings labels] is either [t], a domain name, or an error if
+    the provided [labels] violate domain name constraints. A trailing empty
+    label is not required. *)
+
+val of_strings_exn : string list -> [ `raw ] t
+(** [of_strings_exn labels] is [t], a domain name.  A trailing empty
+    label is not required.
+
+    @raise Invalid_argument if [labels] are not a valid domain name. *)
+
+val to_strings : ?trailing:bool -> 'a t -> string list
+(** [to_strings ~trailing t] is the list of labels of [t].  If [trailing] is
+    provided and [true] (defaults to [false]), the resulting list will contain
+    a trailing empty label. *)
+
+(** {2 Pretty printer} *)
+
+val pp : Format.formatter -> 'a t -> unit
+(** [pp ppf t] pretty prints the domain name [t] on [ppf]. *)
+
+(**/**)
+(* exposing internal structure, used by udns (but could as well use Obj.magic *)
+
+val of_array : string array -> [ `raw ] t
+(** [of_array a] is [t], a domain name from [a], an array containing a reversed
+    domain name. *)
+
+val to_array : 'a t -> string array
+(** [to_array t] is [a], an array containing the reversed domain name of [t]. *)

unikernel/duniverse/domain-name/dune

@@ -0,0 +1,9 @@
+(library
+  (name domain_name)
+  (public_name domain-name)
+  (modules domain_name))
+
+(test
+  (name tests)
+  (modules tests)
+  (libraries alcotest domain-name))

unikernel/duniverse/domain-name/dune-project

@@ -0,0 +1,3 @@
+(lang dune 1.0)
+(name domain-name)
+(version v0.5.0)

unikernel/duniverse/domain-name/tests.ml

@@ -0,0 +1,305 @@
+let n_of_s = Domain_name.of_string_exn
+
+let raw =
+  let module M = struct
+    type t = [ `raw ] Domain_name.t
+    let pp = Domain_name.pp
+    let equal = Domain_name.equal ~case_sensitive:false
+  end in (module M: Alcotest.TESTABLE with type t = M.t)
+
+let host =
+  let module M = struct
+    type t = [ `host ] Domain_name.t
+    let pp = Domain_name.pp
+    let equal = Domain_name.equal ~case_sensitive:false
+  end in (module M: Alcotest.TESTABLE with type t = M.t)
+
+let service =
+  let module M = struct
+    type t = [ `service ] Domain_name.t
+    let pp = Domain_name.pp
+    let equal = Domain_name.equal ~case_sensitive:false
+  end in (module M: Alcotest.TESTABLE with type t = M.t)
+
+let p_msg =
+  let module M = struct
+    type t = [ `Msg of string ]
+    let pp ppf (`Msg m) = Fmt.string ppf m
+    let equal (`Msg _) (`Msg _) = true
+  end in (module M: Alcotest.TESTABLE with type t = M.t)
+
+let is_domain x = match Domain_name.of_string x with
+  | Ok _ -> true | Error _ -> false
+
+let is_host x = match Domain_name.host x with
+  | Ok _ -> true | Error _ -> false
+
+let is_service x = match Domain_name.service x with
+  | Ok _ -> true | Error _ -> false
+
+let longest_label = "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijk"
+let longest_prefix =
+  let d a b = a ^ "." ^ b in
+  d longest_label (d longest_label longest_label)
+
+let basic_preds () =
+  Alcotest.(check bool "root is_hostname" true (is_host Domain_name.root)) ;
+  Alcotest.(check bool "foo is a hostname" true (is_host (n_of_s "foo"))) ;
+  Alcotest.(check bool ".foo is no domain" false (is_domain ".foo")) ;
+  Alcotest.(check bool "bar is a hostname" true (is_host (n_of_s "bar"))) ;
+  Alcotest.(check bool "foo.bar is a hostname" true (is_host (n_of_s "foo.bar"))) ;
+  Alcotest.(check bool "longest label is domain name" true (is_domain longest_label)) ;
+  Alcotest.(check bool "longest label + a is not domain name" false (is_domain (longest_label ^ "a"))) ;
+  Alcotest.(check bool "ll.ll.ll.ll[:-2] is domain name" true
+              (is_domain (longest_prefix ^ "." ^ (String.sub longest_label 0 61)))) ;
+  Alcotest.(check bool "ll.ll.ll.ll[:-1] is not a domain name" false
+              (is_domain (longest_prefix ^ "." ^ (String.sub longest_label 0 62)))) ;
+  Alcotest.(check bool "foo._bar is not a hostname" false (is_host (n_of_s "foo._bar"))) ;
+  Alcotest.(check bool "2foo.bar is a hostname" true (is_host (n_of_s "2foo.bar"))) ;
+  Alcotest.(check bool "f2.bar is a hostname" true (is_host (n_of_s "f2.bar"))) ;
+  Alcotest.(check bool "-f2.bar is not a hostname" false (is_host (n_of_s "-f2.bar"))) ;
+  Alcotest.(check bool "f2.23 is not a hostname" false (is_host (n_of_s "f2.23"))) ;
+  Alcotest.(check bool "42.23b is a hostname" true (is_host (n_of_s "42.23b"))) ;
+  Alcotest.(check bool "'bar.foo is not a hostname" false (is_host (n_of_s "'bar.foo"))) ;
+  Alcotest.(check bool "-foo.bar is not a hostname" false (is_host (n_of_s "'-foo.bar"))) ;
+  Alcotest.(check bool "foo-.bar is not a hostname" false (is_host (n_of_s "foo-.bar"))) ;
+  Alcotest.(check bool "f-o-o.bar is a hostname" true (is_host (n_of_s "f-o-o.bar"))) ;
+  Alcotest.(check bool "2f.b3 is a hostname" true (is_host (n_of_s "2f.b3"))) ;
+  Alcotest.(check bool "2f3.2b3 is a hostname" true (is_host (n_of_s "2f3.2b3"))) ;
+  Alcotest.(check bool "root is no service" false (is_service Domain_name.root)) ;
+  Alcotest.(check bool "_tcp.foo is no service" false
+              (is_service (n_of_s "_tcp.foo"))) ;
+  Alcotest.(check bool "_._tcp.foo is no service" false
+              (is_service (n_of_s "_._tcp.foo"))) ;
+  Alcotest.(check bool "foo._tcp.foo is no service" false
+              (is_service (n_of_s "foo._tcp.foo"))) ;
+  Alcotest.(check bool "f_oo._tcp.foo is no service" false
+              (is_service (n_of_s "f_oo._tcp.foo"))) ;
+  Alcotest.(check bool "foo_._tcp.foo is no service" false
+              (is_service (n_of_s "foo_._tcp.foo"))) ;
+  Alcotest.(check bool "_xmpp-server._tcp.foo is a service" true
+              (is_service (n_of_s "_xmpp-server._tcp.foo"))) ;
+  Alcotest.(check bool "_xmpp-server._tcp2.foo is no service" false
+              (is_service (n_of_s "_xmpp-server._tcp2.foo"))) ;
+  Alcotest.(check bool "_xmpp_server._tcp.foo is no service" false
+              (is_service (n_of_s "_xmpp_server._tcp.foo"))) ;
+  Alcotest.(check bool "_xmpp-server-server._tcp.foo is no service" false
+              (is_service (n_of_s "_xmpp-server-server._tcp.foo"))) ;
+  Alcotest.(check bool "_443._tcp.foo is a service" true
+              (is_service (n_of_s "_443._tcp.foo"))) ;
+  let foo = n_of_s "foo" in
+  Alcotest.(check bool "foo is no subdomain of foo.bar" false
+              (Domain_name.is_subdomain ~subdomain:foo ~domain:(n_of_s "foo.bar"))) ;
+  Alcotest.(check bool "foo is a subdomain of foo" true
+              (Domain_name.is_subdomain ~subdomain:foo ~domain:foo)) ;
+  Alcotest.(check bool "bar.foo is a subdomain of foo" true
+              (Domain_name.is_subdomain ~subdomain:(n_of_s "bar.foo") ~domain:foo))
+
+let case () =
+  Alcotest.(check bool "foo123.com and Foo123.com are equal" true
+              (Domain_name.equal (n_of_s "foo123.com") (n_of_s "Foo123.com"))) ;
+  Alcotest.(check bool "foo123.com and Foo123.com are not equal if case" false
+              (Domain_name.equal ~case_sensitive:true
+                 (n_of_s "foo123.com") (n_of_s "Foo123.com"))) ;
+  Alcotest.(check bool "foo-123.com and com are not equal" false
+              (Domain_name.equal (n_of_s "foo-123.com") (n_of_s "com"))) ;
+  Alcotest.(check bool "foo123.com and Foo123.com are equal if case _and_ canonical used on second"
+              true
+              Domain_name.(equal ~case_sensitive:true
+                 (n_of_s "foo123.com") (canonical (n_of_s "Foo123.com")))) ;
+  Alcotest.(check bool "foo123.com and Foo123.com are not equal if case _and_ canonical used on first"
+              false
+              Domain_name.(equal ~case_sensitive:true
+                 (canonical (n_of_s "foo123.com")) (n_of_s "Foo123.com"))) ;
+  Alcotest.(check bool "foo123.com and Foo123.com are equal if case _and_ canonical used on both"
+              true
+              Domain_name.(equal ~case_sensitive:true
+                 (canonical (n_of_s "foo123.com")) (canonical (n_of_s "Foo123.com"))))
+
+let p_name = Alcotest.testable Domain_name.pp Domain_name.equal
+
+let basic_name () =
+  let lll = String.sub longest_label 0 61
+  and llt = String.sub longest_label 0 62
+  in
+  Alcotest.(check bool "prepend '_foo' to root is not valid hostname"
+              false (is_host (Domain_name.prepend_label_exn Domain_name.root "_foo"))) ;
+  Alcotest.(check bool "host (of_strings [ '_foo' ; 'bar' ]) is not valid"
+              false (is_host (Domain_name.of_strings_exn [ "_foo" ; "bar" ]))) ;
+  Alcotest.(check (result p_name p_msg) "of_string 'foo.bar' is valid"
+              (Ok (n_of_s "foo.bar")) (Domain_name.of_string "foo.bar")) ;
+  Alcotest.(check bool "host (of_string 'foo.bar') is valid"
+              true (is_host (Domain_name.of_string_exn "foo.bar"))) ;
+  Alcotest.(check p_name "of_array 'foo.bar' is good"
+              (n_of_s "foo.bar") (Domain_name.of_array [| "bar" ; "foo" |])) ;
+  Alcotest.(check bool "host (of_array 'foo.bar') is good"
+              true (is_host (Domain_name.of_array [| "bar" ; "foo" |]))) ;
+  Alcotest.(check bool "host (prepend (ll[:-2]) (ll ^ ll ^ ll)) is valid"
+              true (is_host (Domain_name.prepend_label_exn (n_of_s longest_prefix) lll))) ;
+  Alcotest.(check (result p_name p_msg) "prepend '' root is invalid"
+              (Error (`Msg "")) (Domain_name.prepend_label Domain_name.root "")) ;
+  Alcotest.(check (result p_name p_msg) "prepend ll^a root is invalid"
+              (Error (`Msg "")) (Domain_name.prepend_label Domain_name.root (longest_label ^ "a"))) ;
+  Alcotest.(check (result p_name p_msg) "prepend ll (ll ^ ll ^ ll) is invalid"
+              (Error (`Msg "")) (Domain_name.prepend_label (n_of_s longest_prefix) longest_label)) ;
+  Alcotest.(check (result p_name p_msg) "prepend ll[:-1] (ll ^ ll ^ ll) is invalid"
+              (Error (`Msg "")) (Domain_name.prepend_label (n_of_s longest_prefix) llt)) ;
+  Alcotest.(check (result p_name p_msg) "concat 'foo.bar' 'baz.barf' is good"
+              (Ok (n_of_s "foo.bar.baz.barf"))
+              (Domain_name.append (n_of_s "foo.bar") (n_of_s "baz.barf"))) ;
+  let r = Domain_name.prepend_label_exn (n_of_s longest_prefix) lll in
+  Alcotest.(check (result p_name p_msg) "concat ll[:-2] lp is good"
+              (Ok r)
+              (Domain_name.append (n_of_s lll) (n_of_s longest_prefix))) ;
+  Alcotest.(check (result p_name p_msg) "concat ll[:-1] lp is bad"
+              (Error (`Msg ""))
+              (Domain_name.append (n_of_s llt) (n_of_s longest_prefix)))
+
+let fqdn () =
+  Alcotest.(check bool "of_string_exn example.com = of_string_exn example.com."
+              true
+              (Domain_name.equal (n_of_s "example.com") (n_of_s "example.com."))) ;
+  Alcotest.(check bool "of_strings_exn ['example' ; 'com'] = of_strings_exn ['example' ; 'com' ; '']"
+              true
+              Domain_name.(equal
+                             (of_strings_exn [ "example" ; "com" ])
+                             (of_strings_exn [ "example" ; "com" ; "" ])));
+  try
+    Alcotest.(check bool {|of_string_exn "" = of_string_exn "."|})
+      true
+      Domain_name.(equal (n_of_s "") (n_of_s "."))
+  with Invalid_argument _ -> Alcotest.fail "invalid domain name for root"
+
+let fqdn_around () =
+  let d = n_of_s "foo.com." in
+  Alcotest.(check bool "of_string (to_string (of_string 'foo.com.')) works"
+              true Domain_name.(equal d (of_string_exn (to_string d)))) ;
+  Alcotest.(check bool "of_string (to_string ~trailing:true (of_string 'foo.com.')) works"
+              true Domain_name.(equal d (of_string_exn (to_string ~trailing:true d))));
+  try
+    Alcotest.(check bool "of_string (to_string ~trailing:true (of_string '.')) works")
+      true
+      Domain_name.(equal root (of_string_exn (to_string ~trailing:true root)))
+  with Invalid_argument _ -> Alcotest.fail "invalid domain name for root"
+
+
+let drop_labels () =
+  let res = n_of_s "foo.com" in
+  Alcotest.(check p_name "dropping 1 label from www.foo.com is foo.com"
+              res
+              (Domain_name.drop_label_exn (Domain_name.of_string_exn "www.foo.com"))) ;
+  Alcotest.(check p_name "dropping 2 labels from www.bar.foo.com is foo.com"
+              res
+              (Domain_name.drop_label_exn ~amount:2 (Domain_name.of_string_exn "www.bar.foo.com"))) ;
+  Alcotest.(check p_name "dropping 1 label from the back www.foo.com is www.foo"
+              (Domain_name.of_string_exn "www.foo")
+              (Domain_name.drop_label_exn ~rev:true (Domain_name.of_string_exn "www.foo.com"))) ;
+  Alcotest.(check p_name "prepending 1 and dropping 1 label from foo.com is foo.com"
+              res
+              (Domain_name.drop_label_exn (Domain_name.prepend_label_exn (Domain_name.of_string_exn "foo.com") "www"))) ;
+  Alcotest.(check p_name "prepending 1 and dropping 1 label from foo.com is foo.com"
+              res
+              (Domain_name.drop_label_exn (Domain_name.prepend_label_exn (Domain_name.of_string_exn "foo.com") "www"))) ;
+  Alcotest.(check (result p_name p_msg)
+              "dropping 10 labels from foo.com leads to error"
+              (Error (`Msg ""))
+              (Domain_name.drop_label ~amount:10 (Domain_name.of_string_exn "foo.com")))
+
+let get_and_count_and_find_label () =
+  Alcotest.(check int "count labels of root is 0" 0
+              Domain_name.(count_labels root));
+  Alcotest.(check (result string p_msg) "get_label 0 of root is Error"
+              (Error (`Msg ""))
+              Domain_name.(get_label root 0));
+  Alcotest.(check (result string p_msg) "get_label 1 of root is Error"
+              (Error (`Msg ""))
+              Domain_name.(get_label root 1));
+  Alcotest.(check (result string p_msg) "get_label 2 of root is Error"
+              (Error (`Msg ""))
+              Domain_name.(get_label root 2));
+  Alcotest.(check (result string p_msg) "get_label -1 of root is Error"
+              (Error (`Msg ""))
+              Domain_name.(get_label root (-1)));
+  Alcotest.(check (option int) "find_label root '' is none"
+              None Domain_name.(find_label root (fun _ -> true)));
+  Alcotest.(check (option int) "find_label root 'a' is none"
+              None Domain_name.(find_label root (equal_label "a")));
+  let n = n_of_s "www.example.com" in
+  Alcotest.(check int "count labels of www.example.com is 3" 3
+              (Domain_name.count_labels n));
+  Alcotest.(check (result string p_msg) "get_label 0 of n is Ok www"
+              (Ok "www")
+              (Domain_name.get_label n 0));
+  Alcotest.(check (result string p_msg) "get_label 1 of n is Ok example"
+              (Ok "example")
+              (Domain_name.get_label n 1));
+  Alcotest.(check (result string p_msg) "get_label 2 of n is Ok com"
+              (Ok "com")
+              (Domain_name.get_label n 2));
+  Alcotest.(check (result string p_msg) "get_label 3 of n is Error"
+              (Error (`Msg ""))
+              (Domain_name.get_label n 3));
+  Alcotest.(check (result string p_msg) "get_label ~rev:true 0 of n is Ok com"
+              (Ok "com")
+              (Domain_name.get_label ~rev:true n 0));
+  Alcotest.(check (result string p_msg) "get_label ~rev:true 1 of n is Ok example"
+              (Ok "example")
+              (Domain_name.get_label ~rev:true n 1));
+  Alcotest.(check (result string p_msg) "get_label ~rev:true 2 of n is Ok www"
+              (Ok "www")
+              (Domain_name.get_label ~rev:true n 2));
+  Alcotest.(check (result string p_msg) "get_label ~rev:true 3 of n is Error"
+              (Error (`Msg ""))
+              (Domain_name.get_label ~rev:true n 3));
+  Alcotest.(check (option int) "find_label www.example.com is Some 0"
+              (Some 0) Domain_name.(find_label n (fun _ -> true)));
+  Alcotest.(check (option int) "find_label www.example.com 'a' is none"
+              None Domain_name.(find_label n (equal_label "a")));
+  Alcotest.(check (option int) "find_label www.example.com 'w' is none"
+              None Domain_name.(find_label n (equal_label "w")));
+  Alcotest.(check (option int) "find_label www.example.com 'www' is Some 0"
+              (Some 0) Domain_name.(find_label n (equal_label "www")));
+  Alcotest.(check (option int) "find_label www.example.com 'WWW' is Some 0"
+              (Some 0) Domain_name.(find_label n (equal_label "WWW")));
+  Alcotest.(check (option int) "find_label www.example.com 'WWW' is None (case)"
+              None
+              Domain_name.(find_label n (equal_label ~case_sensitive:true "WWW")));
+  let n' = Domain_name.of_string_exn "www.www.www" in
+  Alcotest.(check (option int) "find_label www.www.www 'www' is 0"
+              (Some 0) Domain_name.(find_label n' (equal_label "www")));
+  Alcotest.(check (option int) "find_label ~back:true www.www.www 'www' is 2"
+              (Some 2) Domain_name.(find_label ~rev:true n' (equal_label "www")))
+
+let test_compare_canonical () =
+  (* from RFC 4034, 6.1 *)
+  let names = List.map n_of_s [
+    "example" ;
+    "a.example" ;
+    "yljkjljk.a.example" ;
+    "Z.a.example" ;
+    "zABC.a.EXAMPLE" ;
+    "z.example" ;
+    "\001.z.example" ;
+    "*.z.example" ;
+    "\200.z.example"
+  ] in
+  let sorted_names = List.sort Domain_name.compare names in
+  Alcotest.(check (list raw) "compare fulfills canonical form and order"
+              names sorted_names)
+
+let tests = [
+  "basic predicates", `Quick, basic_preds ;
+  "basic name stuff", `Quick, basic_name ;
+  "case", `Quick, case ;
+  "fqdn", `Quick, fqdn ;
+  "fqdn around", `Quick, fqdn_around ;
+  "drop labels", `Quick, drop_labels ;
+  "get and count and find labels", `Quick, get_and_count_and_find_label ;
+  "sorting", `Quick, test_compare_canonical ;
+]
+
+let suites = [
+  "domain names", tests ;
+]
+
+let () = Alcotest.run "domain name tests" suites