compare: conform to canonical DNS name order

Author: hannesm

CHANGES.md

@@ -1,3 +1,7 @@
+## 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

domain_name.ml

@@ -198,18 +198,17 @@ let compare_label a b =
   String.compare (String.lowercase_ascii a) (String.lowercase_ascii b)
 
 let compare_domain cmp_sub a b =
-  let la = Array.length a in
-  match compare la (Array.length b) with
-  | 0 ->
-    let rec cmp idx =
-      if idx = la then 0
-      else
-        match cmp_sub (Array.get a idx) (Array.get b idx) with
-        | 0 -> cmp (succ idx)
-        | x -> x
-    in
-    cmp 0
-  | x -> x
+  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
 

domain_name.mli

@@ -165,7 +165,8 @@ val equal : ?case_sensitive:bool -> 'a t -> 'b t -> bool
 
 val compare : 'a t -> 'b t -> int
 (** [compare t t'] compares the domain names [t] and [t'] using a case
-    insensitive string comparison. *)
+    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

tests.ml

@@ -1,5 +1,12 @@
 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
@@ -247,6 +254,23 @@ let get_and_count_and_find_label () =
   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 ;
@@ -255,6 +279,7 @@ let tests = [
   "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 = [