Improve pretty-printer for DNs (RFC 4514 and OSF).

CHANGES.md

@@ -5,6 +5,7 @@
   It used to be an attribute (expressed as GADT) Gmap.t, but this representation
   did not conform to RFC 5280, reported by @paurkedal (#117, fixed by #118)
 * Now using Set.find_first_opt, which bumps lower OCaml bound to 4.05.0
+* Improved pretty-printing for DNs including RFC 4514 conformance (@paurkedal, #119).
 
 ## v0.7.1 (2019-08-09)
 

lib/distinguished_name.ml

@@ -17,25 +17,49 @@ type attribute =
   | Generation of string
   | Other of Asn.oid * string
 
-let pp_attribute ppf attr =
+(* Escaping is described in RFC4514. Escaing '=' is optional, otherwise the
+ * following is minimal, using the character instead of hex where possible. *)
+let pp_attribute_value ?(osf = false) () ppf s =
+  let n = String.length s in
+  for i = 0 to n - 1 do
+    match s.[i] with
+    | '#' when i = 0 -> Fmt.string ppf "\\#"
+    | ' ' when i = 0 || i = n - 1 -> Fmt.string ppf "\\ "
+    | ',' when not osf -> Fmt.string ppf "\\,"
+    | ';' when not osf -> Fmt.string ppf "\\;"
+    | '/' when osf -> Fmt.string ppf "\\/"
+    | '"' | '+' | '<' | '=' | '>' | '\\' as c -> Fmt.pf ppf "\\%c" c
+    | '\x00' -> Fmt.string ppf "\\00"
+    | c -> Fmt.char ppf c
+  done
+
+let pp_string_hex ppf s =
+  for i = 0 to String.length s - 1 do
+    Fmt.pf ppf "%02x" (Char.code s.[i])
+  done
+
+let pp_attribute ?osf ?(ava_equal = Fmt.any "=") () ppf attr =
+  let aux a v =
+    Fmt.pf ppf "%s%a%a" a ava_equal () (pp_attribute_value ?osf ()) v in
   match attr with
-  | CN s -> Fmt.pf ppf "CN=%s" s
-  | Serialnumber s -> Fmt.pf ppf "Serialnumber=%s" s
-  | C s -> Fmt.pf ppf "C=%s" s
-  | L s -> Fmt.pf ppf "L=%s" s
-  | SP s -> Fmt.pf ppf "SP=%s" s
-  | O s -> Fmt.pf ppf "O=%s" s
-  | OU s -> Fmt.pf ppf "OU=%s" s
-  | T s -> Fmt.pf ppf "T=%s" s
-  | DNQ s -> Fmt.pf ppf "DNQ=%s" s
-  | Mail s -> Fmt.pf ppf "Mail=%s" s
-  | DC s -> Fmt.pf ppf "DC=%s" s
-  | Given_name s -> Fmt.pf ppf "Given_name=%s" s
-  | Surname s -> Fmt.pf ppf "Surname=%s" s
-  | Initials s -> Fmt.pf ppf "Initials=%s" s
-  | Pseudonym s -> Fmt.pf ppf "Pseudonym=%s" s
-  | Generation s -> Fmt.pf ppf "Generation=%s" s
-  | Other (oid, s) -> Fmt.pf ppf "%a=%s" Asn.OID.pp oid s
+  | CN s -> aux "CN" s
+  | Serialnumber s -> aux "Serialnumber" s
+  | C s -> aux "C" s
+  | L s -> aux "L" s
+  | SP s -> aux "SP" s
+  | O s -> aux "O" s
+  | OU s -> aux "OU" s
+  | T s -> aux "T" s
+  | DNQ s -> aux "DNQ" s
+  | Mail s -> aux "Mail" s
+  | DC s -> aux "DC" s
+  | Given_name s -> aux "Given_name" s
+  | Surname s -> aux "Surname" s
+  | Initials s -> aux "Initials" s
+  | Pseudonym s -> aux "Pseudonym" s
+  | Generation s -> aux "Generation" s
+  | Other (oid, s) ->
+    Fmt.pf ppf "%a%a#%a" Asn.OID.pp oid ava_equal () pp_string_hex s
 
 module K = struct
   type t = attribute
@@ -94,12 +118,30 @@ let equal a b =
   List.length a = List.length b &&
   List.for_all2 Relative_distinguished_name.equal a b
 
-let pp ppf dn =
-  let pp_rdn ppf rdn =
-    Fmt.(list ~sep:(unit " + ") pp_attribute) ppf
-      (Relative_distinguished_name.elements rdn)
+let make_pp_rdn ?osf ?(spacing = `Tight) () =
+  let ava_sep, ava_equal =
+    match spacing with
+    | `Tight -> Fmt.(any "+" ++ cut, any "=")
+    | `Medium -> Fmt.(any " +" ++ sp, any "=")
+    | `Loose -> Fmt.(any " +" ++ sp, any " = ")
   in
-  Fmt.(list ~sep:(unit "/") pp_rdn) ppf dn
+  let pp_ava = pp_attribute ?osf ~ava_equal () in
+  Fmt.(using Relative_distinguished_name.elements @@ list ~sep:ava_sep pp_ava)
+
+let make_pp ~format ?spacing () =
+  match format, spacing with
+  | `RFC4514, (None | Some `Tight) ->
+    Fmt.(using List.rev @@ list ~sep:(any "," ++ cut) (make_pp_rdn ()))
+  | `RFC4514, Some (`Medium | `Loose as spacing) ->
+    Fmt.(using List.rev @@ list ~sep:comma (make_pp_rdn ~spacing ()))
+  | `OpenSSL, (None | Some `Loose) ->
+    Fmt.(list ~sep:comma (make_pp_rdn ~spacing:`Loose ()))
+  | `OpenSSL, Some (`Tight | `Medium as spacing) ->
+    Fmt.(list ~sep:(any "," ++ cut) (make_pp_rdn ~spacing ()))
+  | `OSF, _ ->
+    Fmt.(any "/" ++ list ~sep:(any "/") (make_pp_rdn ~osf:true ()))
+
+let pp = Fmt.hbox (make_pp ~format:`OSF ())
 
 module Asn = struct
   open Asn.S

lib/x509.mli

@@ -132,7 +132,41 @@ module Distinguished_name : sig
   (** [equal a b] is [true] if the distinguished names [a] and [b] are equal. *)
   val equal : t -> t -> bool
 
-  (** [pp ppf dn] pretty-prints the distinguished name. *)
+  (** [make_pp ()] creates a customized pretty-printer for {!t}.
+
+      @param format
+        Determines RDN order, escaping rules, and the default spacing:
+        - [`RFC4514] produces the
+          {{:https://tools.ietf.org/html/rfc4514}RFC4514}.
+          RDNs are written in reverse order of the ASN.1 representation and
+          spacing defaults to tight.
+        - [`OpenSSL] produces the a format similar to OpenSSL.  RDNs are written
+          in the order of the ASN.1 representation, and spacing defaults to
+          loose.
+        - [`OSF] emits RDNs in the order they occur in the ASN.1 representation,
+          each prefixed by a slashes, using tight spacing.  This format is
+          designed by analogy to RFC4514, substituting slash for comma an
+          semicolon, and may currently not be fully compliant with the OSF
+          specifications.
+      @param spacing
+        Determines whether to add space around separators:
+        - [`Tight] to not add any redundant space,
+        - [`Medium] to add space after comma and around plus signs, and
+        - [`Loose] to also add space around equality signs.
+        This parameter is currently ignored for the OSF format.
+
+      The pretty-printer can be wrapped in a box to control line breaking and
+      set it apart, otherwise the RDN components will flow with the surrounding
+      text. *)
+  val make_pp :
+    format: [`RFC4514 | `OpenSSL | `OSF] ->
+    ?spacing: [`Tight | `Medium | `Loose] ->
+    unit -> t Fmt.t
+
+  (** [pp ppf dn] pretty-prints the distinguished name. This is currently
+      [Fmt.hbox (make_pp ~format:`OSF ())]. If your application relies on the
+      precise format, it is advicable to create a custom formatter with
+      {!make_pp} to guard against future changes to the default format. *)
   val pp : t Fmt.t
 
   (** [decode_der cs] is [dn], the ASN.1 decoded distinguished name of [cs]. *)

tests/regression.ml

@@ -48,7 +48,7 @@ let test_izenpe () =
   let dir = General_name.(get Directory san) in
   Alcotest.(check int "directory san len is 1" 1 (List.length dir));
   let data = Fmt.to_to_string Distinguished_name.pp (List.hd dir) in
-  let expected = "O=IZENPE S.A. - CIF A01337260-RMerc.Vitoria-Gasteiz T1055 F62 S8/2.5.4.9=Avda del Mediterraneo Etorbidea 14 - 01010 Vitoria-Gasteiz" in
+  let expected = "/O=IZENPE S.A. - CIF A01337260-RMerc.Vitoria-Gasteiz T1055 F62 S8/2.5.4.9=#417664612064656c204d65646974657272616e656f2045746f726269646561203134202d203031303130205669746f7269612d4761737465697a" in
   Alcotest.(check string "directory in SAN is correct" expected data)
 
 let test_name_constraints () =
@@ -75,6 +75,37 @@ let test_distinguished_name () =
   Alcotest.(check check_dn "complex subject is good"
               expected (Certificate.subject crt))
 
+let test_distinguished_name_pp () =
+  let module Dn = struct
+    include Distinguished_name
+    let cn s = Relative_distinguished_name.singleton (CN s)
+    let o s = Relative_distinguished_name.singleton (O s)
+    let initials s = Relative_distinguished_name.singleton (Initials s)
+    let (+) = Relative_distinguished_name.union
+  end in
+  let dn1 = "DN1", Dn.[o "Blanc";
+                       cn "John Doe" + initials "J.D." + initials "N.N."] in
+  let dn2 = "DN2", Dn.[o " Escapist"; cn "# 2"; cn " \"+,;/<>\\  "] in
+  let pp1 = "RFC4514", Fmt.hbox (Dn.make_pp ~format:`RFC4514 ()) in
+  let pp2 = "RFC4514-spacy",
+    Fmt.hbox (Dn.make_pp ~format:`RFC4514 ~spacing:`Loose ()) in
+  let pp3 = "OpenSSL", Fmt.hbox (Dn.make_pp ~format:`OpenSSL ()) in
+  let pp4 = "OSF", Fmt.hbox (Dn.make_pp ~format:`OSF ()) in
+  let pp5 = "RFC4514-vbox", Fmt.vbox (Dn.make_pp ~format:`RFC4514 ()) in
+  let check (pp_desc, pp) (dn_desc, dn) expected =
+    Alcotest.(check string) (Printf.sprintf "%s %s" pp_desc dn_desc)
+      expected (Fmt.to_to_string pp dn)
+  in
+  check pp1 dn1 {|CN=John Doe+Initials=J.D.+Initials=N.N.,O=Blanc|} ;
+  check pp1 dn2 {|CN=\ \"\+\,\;/\<\>\\ \ ,CN=\# 2,O=\ Escapist|} ;
+  check pp2 dn1 {|CN = John Doe + Initials = J.D. + Initials = N.N., O = Blanc|} ;
+  check pp2 dn2 {|CN = \ \"\+\,\;/\<\>\\ \ , CN = \# 2, O = \ Escapist|} ;
+  check pp3 dn1 {|O = Blanc, CN = John Doe + Initials = J.D. + Initials = N.N.|} ;
+  check pp3 dn2 {|O = \ Escapist, CN = \# 2, CN = \ \"\+\,\;/\<\>\\ \ |} ;
+  check pp4 dn1 {|/O=Blanc/CN=John Doe+Initials=J.D.+Initials=N.N.|} ;
+  check pp4 dn2 {|/O=\ Escapist/CN=\# 2/CN=\ \"\+,;\/\<\>\\ \ |} ;
+  check pp5 dn1 "CN=John Doe+\nInitials=J.D.+\nInitials=N.N.,\nO=Blanc"
+
 let regression_tests = [
   "RSA: key too small (jc_jc)", `Quick, test_jc_jc ;
   "jc_ca", `Quick, test_jc_ca ;
@@ -83,4 +114,5 @@ let regression_tests = [
   "SAN dir explicit or implicit", `Quick, test_izenpe ;
   "name constraint parsing (DNS: .gr)", `Quick, test_name_constraints ;
   "complex distinguished name", `Quick, test_distinguished_name ;
+  "distinguished name pp", `Quick, test_distinguished_name_pp ;
 ]