distinguished_name.ml

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_cstruct, name_to_cstruct) =
    projections_of Asn.der name
end

let decode_der cs = Asn_grammars.err_to_msg (Asn.name_of_cstruct cs)

let encode_der = Asn.name_to_cstruct