unikernel/duniverse/ocaml-x509/lib/distinguished_name.ml

@@ -0,0 +1,255 @@
+type attribute =
+  | CN of string
+  | Serialnumber of string
+  | C of string
+  | L of string
+  | ST of string
+  | O of string
+  | OU of string
+  | T of string
+  | DNQ of string
+  | Mail of string
+  | DC of string
+  | Given_name of string
+  | Surname of string
+  | Initials of string
+  | Pseudonym of string
+  | Generation of string
+  | Street of string
+  | Userid of string
+  | Other of Asn.oid * string
+
+(* 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 -> aux "CN" s
+  | Serialnumber s -> aux "Serialnumber" s
+  | C s -> aux "C" s
+  | L s -> aux "L" s
+  | ST s -> aux "ST" 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
+  | Street s -> aux "Street" s
+  | Userid s -> aux "UID" 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
+
+  let compare t t' =
+    match t, t' with
+    | CN a, CN b -> String.compare a b
+    | CN _, _ -> -1 | _, CN _ -> 1
+    | Serialnumber a, Serialnumber b -> String.compare a b
+    | Serialnumber _, _ -> -1 | _, Serialnumber _ -> 1
+    | C a, C b -> String.compare a b
+    | C _, _ -> -1 | _, C _ -> 1
+    | L a, L b -> String.compare a b
+    | L _, _ -> -1 | _, L _ -> 1
+    | ST a, ST b -> String.compare a b
+    | ST _, _ -> -1 | _, ST _ -> 1
+    | O a, O b -> String.compare a b
+    | O _, _ -> -1 | _, O _ -> 1
+    | OU a, OU b -> String.compare a b
+    | OU _, _ -> -1 | _, OU _ -> 1
+    | T a, T b -> String.compare a b
+    | T _, _ -> -1 | _, T _ -> 1
+    | DNQ a, DNQ b -> String.compare a b
+    | DNQ _, _ -> -1 | _, DNQ _ -> 1
+    | Mail a, Mail b -> String.compare a b
+    | Mail _, _ -> -1 | _, Mail _ -> 1
+    | DC a, DC b -> String.compare a b
+    | DC _, _ -> -1 | _, DC _ -> 1
+    | Given_name a, Given_name b -> String.compare a b
+    | Given_name _, _ -> -1 | _, Given_name _ -> 1
+    | Surname a, Surname b -> String.compare a b
+    | Surname _, _ -> -1 | _, Surname _ -> 1
+    | Initials a, Initials b -> String.compare a b
+    | Initials _, _ -> -1 | _, Initials _ -> 1
+    | Pseudonym a, Pseudonym b -> String.compare a b
+    | Pseudonym _, _ -> -1 | _, Pseudonym _ -> 1
+    | Generation a, Generation b -> String.compare a b
+    | Generation _, _ -> -1 | _, Generation _ -> 1
+    | Street a, Street b -> String.compare a b
+    | Street _, _ -> -1 | _, Street _ -> 1
+    | Userid a, Userid b -> String.compare a b
+    | Userid _, _ -> -1 | _, Userid _ -> 1
+    | Other (oid_a, v_a), Other (oid_b, v_b) ->
+      match Asn.OID.compare oid_a oid_b with
+      | 0 -> String.compare v_a v_b
+      | x when x < 0 -> -1
+      | _ -> 1
+end
+
+module Relative_distinguished_name = Set.Make(K)
+
+(* TODO:
+   - each RDN should be a non-empty set
+   - nothing prevents a user from putting Other (base 2 5 <| 4 <| 3, "foo")
+     and Common_name "foo" into the same RDN -- which are identical (i.e. Other
+     should filter the other named constructors) *)
+type t = Relative_distinguished_name.t list
+
+let equal a b =
+  List.length a = List.length b &&
+  List.for_all2 Relative_distinguished_name.equal a b
+
+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
+  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 ())
+
+let common_name t =
+  let is_cn = function CN _ -> true | _ -> false
+  in
+  List.fold_left (fun acc dn ->
+      match Relative_distinguished_name.find_first_opt is_cn dn with
+      | Some CN x -> Some x | _ -> acc)
+    None t
+
+module Asn = struct
+  open Asn.S
+  open Asn_grammars
+
+  (* ASN `Name' fragmet appears all over. *)
+
+  (* rfc5280 section 4.1.2.4 - name components we "must" handle. *)
+  (* A list of abbreviations: http://pic.dhe.ibm.com/infocenter/wmqv7/v7r1/index.jsp?topic=%2Fcom.ibm.mq.doc%2Fsy10570_.htm *)
+  (* Also rfc4519. *)
+
+  (* See rfc5280 section 4.1.2.4. *)
+  let directory_name =
+    choice6
+      utf8_string printable_string
+      ia5_string universal_string teletex_string bmp_string
+
+  (* We flatten the sequence-of-set-of-tuple here into a single list.
+  * This means that we can't write non-singleton sets back.
+  * Does anyone need that, ever?
+  *)
+
+  let name =
+    let open Registry in
+    let of_c = function
+      | `C1 x | `C2 x | `C3 x | `C4 x | `C5 x | `C6 x -> x in
+
+    let a_f = case_of_oid_f [
+      (domain_component              , fun x -> DC (of_c x)) ;
+      (X520.common_name              , fun x -> CN (of_c x)) ;
+      (X520.serial_number            , fun x -> Serialnumber (of_c x)) ;
+      (X520.country_name             , fun x -> C (of_c x)) ;
+      (X520.locality_name            , fun x -> L (of_c x)) ;
+      (X520.state_or_province_name   , fun x -> ST (of_c x)) ;
+      (X520.organization_name        , fun x -> O (of_c x)) ;
+      (X520.organizational_unit_name , fun x -> OU (of_c x)) ;
+      (X520.title                    , fun x -> T (of_c x)) ;
+      (X520.dn_qualifier             , fun x -> DNQ (of_c x)) ;
+      (PKCS9.email                   , fun x -> Mail (of_c x)) ;
+      (X520.given_name               , fun x -> Given_name (of_c x)) ;
+      (X520.surname                  , fun x -> Surname (of_c x)) ;
+      (X520.initials                 , fun x -> Initials (of_c x)) ;
+      (X520.pseudonym                , fun x -> Pseudonym (of_c x)) ;
+      (X520.generation_qualifier     , fun x -> Generation (of_c x)) ;
+      (X520.street_address           , fun x -> Street (of_c x)) ;
+      (userid                        , fun x -> Userid (of_c x))]
+      ~default:(fun oid x -> Other (oid, of_c x))
+
+    and a_g = function
+      | DC x -> (domain_component, `C3 x )
+      | CN x -> (X520.common_name, `C1 x )
+      | Serialnumber x -> (X520.serial_number, `C2 x )
+      | C x -> (X520.country_name, `C2 x )
+      | L x -> (X520.locality_name, `C1 x )
+      | ST x -> (X520.state_or_province_name, `C1 x )
+      | O x -> (X520.organization_name, `C1 x )
+      | OU x -> (X520.organizational_unit_name, `C1 x )
+      | T x -> (X520.title, `C1 x )
+      | DNQ x -> (X520.dn_qualifier, `C2 x )
+      | Mail x -> (PKCS9.email, `C3 x )
+      | Given_name x -> (X520.given_name, `C1 x )
+      | Surname x -> (X520.surname, `C1 x )
+      | Initials x -> (X520.initials, `C1 x )
+      | Pseudonym x -> (X520.pseudonym, `C1 x )
+      | Generation x -> (X520.generation_qualifier, `C1 x )
+      | Street x -> (X520.street_address, `C1 x )
+      | Userid x -> (userid, `C1 x )
+      | Other (oid, x) -> (oid, `C1 x )
+    in
+
+    let attribute_tv =
+      map a_f a_g @@
+      sequence2
+        (required ~label:"attr type"  oid)
+        (* This is ANY according to rfc5280. *)
+        (required ~label:"attr value" directory_name)
+    in
+    let rd_name =
+      let f exts =
+        List.fold_left
+          (fun set attr -> Relative_distinguished_name.add attr set)
+          Relative_distinguished_name.empty exts
+      and g map = Relative_distinguished_name.elements map
+      in
+      map f g @@ set_of attribute_tv
+    in
+    sequence_of rd_name (* A vacuous choice, in the standard. *)
+
+  let (name_of_octets, name_to_octets) =
+    projections_of Asn.der name
+end
+
+let decode_der cs = Asn_grammars.err_to_msg (Asn.name_of_octets cs)
+
+let encode_der = Asn.name_to_octets