This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
695
unikernel/duniverse/ocaml-x509/lib/extension.ml
Normal file
695
unikernel/duniverse/ocaml-x509/lib/extension.ml
Normal file
|
|
@ -0,0 +1,695 @@
|
|||
|
||||
type key_usage = [
|
||||
| `Digital_signature
|
||||
| `Content_commitment
|
||||
| `Key_encipherment
|
||||
| `Data_encipherment
|
||||
| `Key_agreement
|
||||
| `Key_cert_sign
|
||||
| `CRL_sign
|
||||
| `Encipher_only
|
||||
| `Decipher_only
|
||||
]
|
||||
|
||||
let pp_key_usage ppf ku =
|
||||
Fmt.string ppf
|
||||
(match ku with
|
||||
| `Digital_signature -> "digital signature"
|
||||
| `Content_commitment -> "content commitment"
|
||||
| `Key_encipherment -> "key encipherment"
|
||||
| `Data_encipherment -> "data encipherment"
|
||||
| `Key_agreement -> "key agreement"
|
||||
| `Key_cert_sign -> "key cert sign"
|
||||
| `CRL_sign -> "CRL sign"
|
||||
| `Encipher_only -> "encipher only"
|
||||
| `Decipher_only -> "decipher only")
|
||||
|
||||
type extended_key_usage = [
|
||||
| `Any
|
||||
| `Server_auth
|
||||
| `Client_auth
|
||||
| `Code_signing
|
||||
| `Email_protection
|
||||
| `Ipsec_end
|
||||
| `Ipsec_tunnel
|
||||
| `Ipsec_user
|
||||
| `Time_stamping
|
||||
| `Ocsp_signing
|
||||
| `Other of Asn.oid
|
||||
]
|
||||
|
||||
let pp_extended_key_usage ppf = function
|
||||
| `Any -> Fmt.string ppf "any"
|
||||
| `Server_auth -> Fmt.string ppf "server authentication"
|
||||
| `Client_auth -> Fmt.string ppf "client authentication"
|
||||
| `Code_signing -> Fmt.string ppf "code signing"
|
||||
| `Email_protection -> Fmt.string ppf "email protection"
|
||||
| `Ipsec_end -> Fmt.string ppf "ipsec end"
|
||||
| `Ipsec_tunnel -> Fmt.string ppf "ipsec tunnel"
|
||||
| `Ipsec_user -> Fmt.string ppf "ipsec user"
|
||||
| `Time_stamping -> Fmt.string ppf "time stamping"
|
||||
| `Ocsp_signing -> Fmt.string ppf "ocsp signing"
|
||||
| `Other oid -> Asn.OID.pp ppf oid
|
||||
|
||||
type authority_key_id = string option * General_name.t * string option
|
||||
|
||||
let pp_authority_key_id ppf (id, issuer, serial) =
|
||||
Fmt.pf ppf "identifier %a@ issuer %a@ serial %a@ "
|
||||
Fmt.(option ~none:(any "none") Ohex.pp) id
|
||||
General_name.pp issuer
|
||||
Fmt.(option ~none:(any "none") Ohex.pp) serial
|
||||
|
||||
type priv_key_usage_period = [
|
||||
| `Interval of Ptime.t * Ptime.t
|
||||
| `Not_after of Ptime.t
|
||||
| `Not_before of Ptime.t
|
||||
]
|
||||
|
||||
let pp_priv_key_usage_period ppf =
|
||||
let pp_ptime = Ptime.pp_human ~tz_offset_s:0 () in
|
||||
function
|
||||
| `Interval (start, stop) ->
|
||||
Fmt.pf ppf "from %a till %a" pp_ptime start pp_ptime stop
|
||||
| `Not_after after -> Fmt.pf ppf "not after %a" pp_ptime after
|
||||
| `Not_before before -> Fmt.pf ppf "not before %a" pp_ptime before
|
||||
|
||||
type name_constraint = (General_name.b * int * int option) list
|
||||
|
||||
let pp_name_constraints ppf (permitted, excluded) =
|
||||
let pp_one ppf (General_name.B (k, base), min, max) =
|
||||
Fmt.pf ppf "base %a min %u max %a"
|
||||
(General_name.pp_k k) base min Fmt.(option ~none:(any "none") int) max
|
||||
in
|
||||
Fmt.pf ppf "permitted %a@ excluded %a"
|
||||
Fmt.(list ~sep:(any ", ") pp_one) permitted
|
||||
Fmt.(list ~sep:(any ", ") pp_one) excluded
|
||||
|
||||
type policy = [ `Any | `Something of Asn.oid ]
|
||||
|
||||
let pp_policy ppf = function
|
||||
| `Any -> Fmt.string ppf "any"
|
||||
| `Something oid -> Fmt.pf ppf "some oid %a" Asn.OID.pp oid
|
||||
|
||||
type reason = [
|
||||
| `Unspecified
|
||||
| `Key_compromise
|
||||
| `CA_compromise
|
||||
| `Affiliation_changed
|
||||
| `Superseded
|
||||
| `Cessation_of_operation
|
||||
| `Certificate_hold
|
||||
| `Remove_from_CRL
|
||||
| `Privilege_withdrawn
|
||||
| `AA_compromise
|
||||
]
|
||||
|
||||
let reason_to_int = function
|
||||
| `Unspecified -> 0
|
||||
| `Key_compromise -> 1
|
||||
| `CA_compromise -> 2
|
||||
| `Affiliation_changed -> 3
|
||||
| `Superseded -> 4
|
||||
| `Cessation_of_operation -> 5
|
||||
| `Certificate_hold -> 6
|
||||
(* 7 is not used *)
|
||||
| `Remove_from_CRL -> 8
|
||||
| `Privilege_withdrawn -> 9
|
||||
| `AA_compromise -> 10
|
||||
|
||||
let reason_of_int = function
|
||||
| 0 -> `Unspecified
|
||||
| 1 -> `Key_compromise
|
||||
| 2 -> `CA_compromise
|
||||
| 3 -> `Affiliation_changed
|
||||
| 4 -> `Superseded
|
||||
| 5 -> `Cessation_of_operation
|
||||
| 6 -> `Certificate_hold
|
||||
(* 7 is not used *)
|
||||
| 8 -> `Remove_from_CRL
|
||||
| 9 -> `Privilege_withdrawn
|
||||
| 10 -> `AA_compromise
|
||||
| x -> Asn.S.parse_error "Unknown reason %d" x
|
||||
|
||||
let pp_reason ppf r =
|
||||
Fmt.string ppf (match r with
|
||||
| `Unspecified -> "unspecified"
|
||||
| `Key_compromise -> "key compromise"
|
||||
| `CA_compromise -> "CA compromise"
|
||||
| `Affiliation_changed -> "affiliation changed"
|
||||
| `Superseded -> "superseded"
|
||||
| `Cessation_of_operation -> "cessation of operation"
|
||||
| `Certificate_hold -> "certificate hold"
|
||||
| `Remove_from_CRL -> "remove from CRL"
|
||||
| `Privilege_withdrawn -> "privilege withdrawn"
|
||||
| `AA_compromise -> "AA compromise")
|
||||
|
||||
type distribution_point_name =
|
||||
[ `Full of General_name.t
|
||||
| `Relative of Distinguished_name.t ]
|
||||
|
||||
let pp_distribution_point_name ppf = function
|
||||
| `Full name -> Fmt.pf ppf "full %a" General_name.pp name
|
||||
| `Relative name -> Fmt.pf ppf "relative %a" Distinguished_name.pp name
|
||||
|
||||
type distribution_point =
|
||||
distribution_point_name option *
|
||||
reason list option *
|
||||
General_name.t option
|
||||
|
||||
let pp_distribution_point ppf (name, reasons, issuer) =
|
||||
Fmt.pf ppf "name %a reason %a issuer %a"
|
||||
Fmt.(option ~none:(any "none") pp_distribution_point_name) name
|
||||
Fmt.(option ~none:(any "none") (list ~sep:(any ", ") pp_reason)) reasons
|
||||
Fmt.(option ~none:(any "none") General_name.pp) issuer
|
||||
|
||||
let pp_issuing_distribution_point ppf (name, onlyuser, onlyca, onlysome, indirectcrl, onlyattributes) =
|
||||
Fmt.pf ppf "name %a only user certs %B only CA certs %B only reasons %a indirectcrl %B only attribute certs %B"
|
||||
Fmt.(option ~none:(any "none") pp_distribution_point_name) name
|
||||
onlyuser onlyca
|
||||
Fmt.(option ~none:(any "no") (list ~sep:(any ", ") pp_reason)) onlysome
|
||||
indirectcrl onlyattributes
|
||||
|
||||
type 'a extension = bool * 'a
|
||||
|
||||
type _ k =
|
||||
| Unsupported : Asn.oid -> string extension k
|
||||
| Subject_alt_name : General_name.t extension k
|
||||
| Authority_key_id : authority_key_id extension k
|
||||
| Subject_key_id : string extension k
|
||||
| Issuer_alt_name : General_name.t extension k
|
||||
| Key_usage : key_usage list extension k
|
||||
| Ext_key_usage : extended_key_usage list extension k
|
||||
| Basic_constraints : (bool * int option) extension k
|
||||
| CRL_number : int extension k
|
||||
| Delta_CRL_indicator : int extension k
|
||||
| Priv_key_period : priv_key_usage_period extension k
|
||||
| Name_constraints : (name_constraint * name_constraint) extension k
|
||||
| CRL_distribution_points : distribution_point list extension k
|
||||
| Issuing_distribution_point : (distribution_point_name option * bool * bool * reason list option * bool * bool) extension k
|
||||
| Freshest_CRL : distribution_point list extension k
|
||||
| Reason : reason extension k
|
||||
| Invalidity_date : Ptime.t extension k
|
||||
| Certificate_issuer : General_name.t extension k
|
||||
| Policies : policy list extension k
|
||||
|
||||
let pp_one' : type a. (Format.formatter -> Asn.oid * string -> unit) -> a k -> Format.formatter -> a -> unit = fun custom k ppf v ->
|
||||
let c_to_str b = if b then "critical " else "" in
|
||||
match k, v with
|
||||
| Subject_alt_name, (crit, alt) ->
|
||||
Fmt.pf ppf "%ssubjectAlternativeName %a" (c_to_str crit)
|
||||
General_name.pp alt
|
||||
| Authority_key_id, (crit, kid) ->
|
||||
Fmt.pf ppf "%sauthorityKeyIdentifier %a" (c_to_str crit)
|
||||
pp_authority_key_id kid
|
||||
| Subject_key_id, (crit, kid) ->
|
||||
Fmt.pf ppf "%ssubjectKeyIdentifier %a" (c_to_str crit)
|
||||
Ohex.pp kid
|
||||
| Issuer_alt_name, (crit, alt) ->
|
||||
Fmt.pf ppf "%sissuerAlternativeNames %a" (c_to_str crit)
|
||||
General_name.pp alt
|
||||
| Key_usage, (crit, ku) ->
|
||||
Fmt.pf ppf "%skeyUsage %a" (c_to_str crit)
|
||||
Fmt.(list ~sep:(any ", ") pp_key_usage) ku
|
||||
| Ext_key_usage, (crit, eku) ->
|
||||
Fmt.pf ppf "%sextendedKeyUsage %a" (c_to_str crit)
|
||||
Fmt.(list ~sep:(any ", ") pp_extended_key_usage) eku
|
||||
| Basic_constraints, (crit, (ca, depth)) ->
|
||||
Fmt.pf ppf "%sbasicConstraints CA %B depth %a" (c_to_str crit) ca
|
||||
Fmt.(option ~none:(any "none") int) depth
|
||||
| CRL_number, (crit, i) ->
|
||||
Fmt.pf ppf "%scRLNumber %u" (c_to_str crit) i
|
||||
| Delta_CRL_indicator, (crit, indicator) ->
|
||||
Fmt.pf ppf "%sdeltaCRLIndicator %u" (c_to_str crit) indicator
|
||||
| Priv_key_period, (crit, period) ->
|
||||
Fmt.pf ppf "%sprivateKeyUsagePeriod %a" (c_to_str crit)
|
||||
pp_priv_key_usage_period period
|
||||
| Name_constraints, (crit, ncs) ->
|
||||
Fmt.pf ppf "%snameConstraints %a" (c_to_str crit) pp_name_constraints ncs
|
||||
| CRL_distribution_points, (crit, points) ->
|
||||
Fmt.pf ppf "%scRLDistributionPoints %a" (c_to_str crit)
|
||||
Fmt.(list ~sep:(any "; ") pp_distribution_point) points
|
||||
| Issuing_distribution_point, (crit, point) ->
|
||||
Fmt.pf ppf "%sissuingDistributionPoint %a" (c_to_str crit)
|
||||
pp_issuing_distribution_point point
|
||||
| Freshest_CRL, (crit, points) ->
|
||||
Fmt.pf ppf "%sfreshestCRL %a" (c_to_str crit)
|
||||
Fmt.(list ~sep:(any "; ") pp_distribution_point) points
|
||||
| Reason, (crit, reason) ->
|
||||
Fmt.pf ppf "%sreason %a" (c_to_str crit) pp_reason reason
|
||||
| Invalidity_date, (crit, date) ->
|
||||
Fmt.pf ppf "%sinvalidityDate %a" (c_to_str crit)
|
||||
(Ptime.pp_human ~tz_offset_s:0 ()) date
|
||||
| Certificate_issuer, (crit, name) ->
|
||||
Fmt.pf ppf "%scertificateIssuer %a" (c_to_str crit) General_name.pp name
|
||||
| Policies, (crit, pols) ->
|
||||
Fmt.pf ppf "%spolicies %a" (c_to_str crit)
|
||||
Fmt.(list ~sep:(any "; ") pp_policy) pols
|
||||
| Unsupported oid, (crit, str) ->
|
||||
Fmt.pf ppf "%s%a" (c_to_str crit) custom (oid, str)
|
||||
|
||||
let default_pp_custom_extension ppf (oid, str) =
|
||||
Fmt.pf ppf "unsupported %a: %a" Asn.OID.pp oid Ohex.pp str
|
||||
|
||||
let pp_one k fmt =
|
||||
pp_one' default_pp_custom_extension k fmt
|
||||
|
||||
module ID = Registry.Cert_extn
|
||||
|
||||
let to_oid : type a. a k -> Asn.oid = function
|
||||
| Unsupported oid -> oid
|
||||
| Subject_alt_name -> ID.subject_alternative_name
|
||||
| Authority_key_id -> ID.authority_key_identifier
|
||||
| Subject_key_id -> ID.subject_key_identifier
|
||||
| Issuer_alt_name -> ID.issuer_alternative_name
|
||||
| Key_usage -> ID.key_usage
|
||||
| Ext_key_usage -> ID.extended_key_usage
|
||||
| Basic_constraints -> ID.basic_constraints
|
||||
| CRL_number -> ID.crl_number
|
||||
| Delta_CRL_indicator -> ID.delta_crl_indicator
|
||||
| Priv_key_period -> ID.private_key_usage_period
|
||||
| Name_constraints -> ID.name_constraints
|
||||
| CRL_distribution_points -> ID.crl_distribution_points
|
||||
| Issuing_distribution_point -> ID.issuing_distribution_point
|
||||
| Freshest_CRL -> ID.freshest_crl
|
||||
| Reason -> ID.reason_code
|
||||
| Invalidity_date -> ID.invalidity_date
|
||||
| Certificate_issuer -> ID.certificate_issuer
|
||||
| Policies -> ID.certificate_policies_2
|
||||
|
||||
let critical : type a. a k -> a -> bool = fun k v ->
|
||||
match k, v with
|
||||
| Unsupported _, (b, _) -> b
|
||||
| Subject_alt_name, (b, _) -> b
|
||||
| Authority_key_id, (b, _) -> b
|
||||
| Subject_key_id, (b, _) -> b
|
||||
| Issuer_alt_name, (b, _) -> b
|
||||
| Key_usage, (b, _) -> b
|
||||
| Ext_key_usage, (b, _) -> b
|
||||
| Basic_constraints, (b, _) -> b
|
||||
| CRL_number, (b, _) -> b
|
||||
| Delta_CRL_indicator, (b, _) -> b
|
||||
| Priv_key_period, (b, _) -> b
|
||||
| Name_constraints, (b, _) -> b
|
||||
| CRL_distribution_points, (b, _) -> b
|
||||
| Issuing_distribution_point, (b, _) -> b
|
||||
| Freshest_CRL, (b, _) -> b
|
||||
| Reason, (b, _) -> b
|
||||
| Invalidity_date, (b, _) -> b
|
||||
| Certificate_issuer, (b, _) -> b
|
||||
| Policies, (b, _) -> b
|
||||
|
||||
module K = struct
|
||||
type 'a t = 'a k
|
||||
|
||||
let compare : type a b. a t -> b t -> (a, b) Gmap.Order.t = fun t t' ->
|
||||
let open Gmap.Order in
|
||||
match t, t' with
|
||||
| Subject_alt_name, Subject_alt_name -> Eq
|
||||
| Authority_key_id, Authority_key_id -> Eq
|
||||
| Subject_key_id, Subject_key_id -> Eq
|
||||
| Issuer_alt_name, Issuer_alt_name -> Eq
|
||||
| Key_usage, Key_usage -> Eq
|
||||
| Ext_key_usage, Ext_key_usage -> Eq
|
||||
| Basic_constraints, Basic_constraints -> Eq
|
||||
| CRL_number, CRL_number -> Eq
|
||||
| Delta_CRL_indicator, Delta_CRL_indicator -> Eq
|
||||
| Priv_key_period, Priv_key_period -> Eq
|
||||
| Name_constraints, Name_constraints -> Eq
|
||||
| CRL_distribution_points, CRL_distribution_points -> Eq
|
||||
| Issuing_distribution_point, Issuing_distribution_point -> Eq
|
||||
| Freshest_CRL, Freshest_CRL -> Eq
|
||||
| Reason, Reason -> Eq
|
||||
| Invalidity_date, Invalidity_date -> Eq
|
||||
| Certificate_issuer, Certificate_issuer -> Eq
|
||||
| Policies, Policies -> Eq
|
||||
| Unsupported oid, Unsupported oid' when Asn.OID.equal oid oid' -> Eq
|
||||
| a, b ->
|
||||
let r = Asn.OID.compare (to_oid a) (to_oid b) in
|
||||
if r = 0 then assert false else if r < 0 then Lt else Gt
|
||||
end
|
||||
|
||||
include Gmap.Make(K)
|
||||
|
||||
let pp' custom ppf m =
|
||||
iter (fun (B (k, v)) -> pp_one' custom k ppf v ; Fmt.sp ppf ()) m
|
||||
|
||||
let pp = pp' default_pp_custom_extension
|
||||
|
||||
let hostnames exts =
|
||||
match find Subject_alt_name exts with
|
||||
| None -> None
|
||||
| Some (_, names) ->
|
||||
match General_name.find DNS names with
|
||||
| None -> None
|
||||
| Some xs ->
|
||||
let names =
|
||||
List.fold_left (fun acc s ->
|
||||
match Host.host s with
|
||||
| Some (typ, hostname) -> Host.Set.add (typ, hostname) acc
|
||||
| None -> acc)
|
||||
Host.Set.empty xs
|
||||
in
|
||||
if Host.Set.is_empty names then None else Some names
|
||||
|
||||
let ips exts =
|
||||
match find Subject_alt_name exts with
|
||||
| None -> None
|
||||
| Some (_, names) ->
|
||||
match General_name.find IP names with
|
||||
| None -> None
|
||||
| Some xs ->
|
||||
let ips =
|
||||
List.fold_left (fun acc ip ->
|
||||
match
|
||||
match String.length ip with
|
||||
| 4 -> Result.map (fun ip -> Ipaddr.V4 ip) (Ipaddr.V4.of_octets ip)
|
||||
| 16 -> Result.map (fun ip -> Ipaddr.V6 ip) (Ipaddr.V6.of_octets ip)
|
||||
| _ -> Error (`Msg "unknown IP address kind")
|
||||
with
|
||||
| Ok ip -> Ipaddr.Set.add ip acc
|
||||
| Error _ -> acc)
|
||||
Ipaddr.Set.empty xs
|
||||
in
|
||||
if Ipaddr.Set.is_empty ips then None else Some ips
|
||||
|
||||
module Asn = struct
|
||||
open Asn.S
|
||||
open Asn_grammars
|
||||
|
||||
let display_text =
|
||||
map (function `C1 s -> s | `C2 s -> s | `C3 s -> s | `C4 s -> s)
|
||||
(fun s -> `C4 s)
|
||||
@@
|
||||
choice4 ia5_string visible_string bmp_string utf8_string
|
||||
|
||||
module ID = Registry.Cert_extn
|
||||
|
||||
let key_usage : key_usage list Asn.t = bit_string_flags [
|
||||
0, `Digital_signature
|
||||
; 1, `Content_commitment
|
||||
; 2, `Key_encipherment
|
||||
; 3, `Data_encipherment
|
||||
; 4, `Key_agreement
|
||||
; 5, `Key_cert_sign
|
||||
; 6, `CRL_sign
|
||||
; 7, `Encipher_only
|
||||
; 8, `Decipher_only
|
||||
]
|
||||
|
||||
let ext_key_usage =
|
||||
let open ID.Extended_usage in
|
||||
let f = case_of_oid [
|
||||
(any , `Any ) ;
|
||||
(server_auth , `Server_auth ) ;
|
||||
(client_auth , `Client_auth ) ;
|
||||
(code_signing , `Code_signing ) ;
|
||||
(email_protection , `Email_protection) ;
|
||||
(ipsec_end_system , `Ipsec_end ) ;
|
||||
(ipsec_tunnel , `Ipsec_tunnel ) ;
|
||||
(ipsec_user , `Ipsec_user ) ;
|
||||
(time_stamping , `Time_stamping ) ;
|
||||
(ocsp_signing , `Ocsp_signing ) ]
|
||||
~default:(fun oid -> `Other oid)
|
||||
and g = function
|
||||
| `Any -> any
|
||||
| `Server_auth -> server_auth
|
||||
| `Client_auth -> client_auth
|
||||
| `Code_signing -> code_signing
|
||||
| `Email_protection -> email_protection
|
||||
| `Ipsec_end -> ipsec_end_system
|
||||
| `Ipsec_tunnel -> ipsec_tunnel
|
||||
| `Ipsec_user -> ipsec_user
|
||||
| `Time_stamping -> time_stamping
|
||||
| `Ocsp_signing -> ocsp_signing
|
||||
| `Other oid -> oid
|
||||
in
|
||||
map (List.map f) (List.map g) @@ sequence_of oid
|
||||
|
||||
let basic_constraints =
|
||||
map (fun (a, b) -> (Option.value ~default:false a, b))
|
||||
(fun (a, b) -> ((if a = false then None else Some a), b))
|
||||
@@
|
||||
sequence2
|
||||
(optional ~label:"cA" bool)
|
||||
(optional ~label:"pathLen" int)
|
||||
|
||||
let authority_key_id =
|
||||
map (fun (a, b, c) ->
|
||||
(a, Option.value ~default:General_name.empty b, c))
|
||||
(fun (a, b, c) ->
|
||||
(a, (if General_name.is_empty b then None else Some b), c))
|
||||
@@
|
||||
sequence3
|
||||
(optional ~label:"keyIdentifier" @@ implicit 0 octet_string)
|
||||
(optional ~label:"authCertIssuer" @@ implicit 1 General_name.Asn.gen_names)
|
||||
(optional ~label:"authCertSN" @@ implicit 2 serial)
|
||||
|
||||
let priv_key_usage_period =
|
||||
let f = function
|
||||
| (Some t1, Some t2) -> `Interval (t1, t2)
|
||||
| (Some t1, None ) -> `Not_before t1
|
||||
| (None , Some t2) -> `Not_after t2
|
||||
| _ -> parse_error "empty PrivateKeyUsagePeriod"
|
||||
and g = function
|
||||
| `Interval (t1, t2) -> (Some t1, Some t2)
|
||||
| `Not_before t1 -> (Some t1, None )
|
||||
| `Not_after t2 -> (None , Some t2) in
|
||||
map f g @@
|
||||
sequence2
|
||||
(optional ~label:"notBefore" @@ implicit 0 generalized_time_no_frac_s)
|
||||
(optional ~label:"notAfter" @@ implicit 1 generalized_time_no_frac_s)
|
||||
|
||||
let name_constraints =
|
||||
let subtree =
|
||||
map
|
||||
(fun (base, min, max) -> (base, Option.value ~default:0 min, max))
|
||||
(fun (base, min, max) -> (base, (if min = 0 then None else Some min), max))
|
||||
@@
|
||||
sequence3
|
||||
(required ~label:"base" General_name.Asn.general_name)
|
||||
(optional ~label:"minimum" @@ implicit 0 int)
|
||||
(optional ~label:"maximum" @@ implicit 1 int)
|
||||
in
|
||||
map
|
||||
(fun (a, b) -> (Option.value ~default:[] a, Option.value ~default:[] b))
|
||||
(fun (a, b) -> ((if a = [] then None else Some a),
|
||||
(if b = [] then None else Some b)))
|
||||
@@
|
||||
sequence2
|
||||
(optional ~label:"permittedSubtrees" @@ implicit 0 (sequence_of subtree))
|
||||
(optional ~label:"excludedSubtrees" @@ implicit 1 (sequence_of subtree))
|
||||
|
||||
let cert_policies =
|
||||
let open ID.Cert_policy in
|
||||
let qualifier_info =
|
||||
map (function | (oid, `C1 s) when oid = cps -> s
|
||||
| (oid, `C2 s) when oid = unotice -> s
|
||||
| _ -> parse_error "bad policy qualifier")
|
||||
(function s -> (cps, `C1 s))
|
||||
@@
|
||||
sequence2
|
||||
(required ~label:"qualifierId" oid)
|
||||
(required ~label:"qualifier"
|
||||
(choice2
|
||||
ia5_string
|
||||
@@
|
||||
map (function (_, Some s) -> s | _ -> "#(BLAH BLAH)")
|
||||
(fun s -> (None, Some s))
|
||||
(sequence2
|
||||
(optional ~label:"noticeRef"
|
||||
(sequence2
|
||||
(required ~label:"organization" display_text)
|
||||
(required ~label:"numbers" (sequence_of integer))))
|
||||
(optional ~label:"explicitText" display_text))))
|
||||
in
|
||||
(* "Optional qualifiers, which MAY be present, are not expected to change
|
||||
* the definition of the policy."
|
||||
* Hence, we just drop them. *)
|
||||
sequence_of @@
|
||||
map (function | (oid, _) when oid = any_policy -> `Any
|
||||
| (oid, _) -> `Something oid)
|
||||
(function | `Any -> (any_policy, None)
|
||||
| `Something oid -> (oid, None))
|
||||
@@
|
||||
sequence2
|
||||
(required ~label:"policyIdentifier" oid)
|
||||
(optional ~label:"policyQualifiers" (sequence_of qualifier_info))
|
||||
|
||||
let reason : reason list Asn.t = bit_string_flags [
|
||||
0, `Unspecified
|
||||
; 1, `Key_compromise
|
||||
; 2, `CA_compromise
|
||||
; 3, `Affiliation_changed
|
||||
; 4, `Superseded
|
||||
; 5, `Cessation_of_operation
|
||||
; 6, `Certificate_hold
|
||||
; 7, `Privilege_withdrawn
|
||||
; 8, `AA_compromise
|
||||
]
|
||||
|
||||
let reason_enumerated : reason Asn.t =
|
||||
enumerated reason_of_int reason_to_int
|
||||
|
||||
let distribution_point_name =
|
||||
map (function | `C1 s -> `Full s | `C2 s -> `Relative s)
|
||||
(function | `Full s -> `C1 s | `Relative s -> `C2 s)
|
||||
@@
|
||||
choice2
|
||||
(implicit 0 General_name.Asn.gen_names)
|
||||
(implicit 1 Distinguished_name.Asn.name)
|
||||
|
||||
let distribution_point =
|
||||
sequence3
|
||||
(optional ~label:"distributionPoint" @@ explicit 0 distribution_point_name)
|
||||
(optional ~label:"reasons" @@ implicit 1 reason)
|
||||
(optional ~label:"cRLIssuer" @@ implicit 2 General_name.Asn.gen_names)
|
||||
|
||||
let crl_distribution_points = sequence_of distribution_point
|
||||
|
||||
let issuing_distribution_point =
|
||||
map
|
||||
(fun (a, b, c, d, e, f) ->
|
||||
(a,
|
||||
Option.value ~default:false b,
|
||||
Option.value ~default:false c,
|
||||
d,
|
||||
Option.value ~default:false e,
|
||||
Option.value ~default:false f))
|
||||
(fun (a, b, c, d, e, f) ->
|
||||
(a,
|
||||
(if b = false then None else Some b),
|
||||
(if c = false then None else Some c),
|
||||
d,
|
||||
(if e = false then None else Some e),
|
||||
(if f = false then None else Some f)))
|
||||
@@
|
||||
sequence6
|
||||
(optional ~label:"distributionPoint" @@ explicit 0 distribution_point_name)
|
||||
(optional ~label:"onlyContainsUserCerts" @@ implicit 1 bool)
|
||||
(optional ~label:"onlyContainsCACerts" @@ implicit 2 bool)
|
||||
(optional ~label:"onlySomeReasons" @@ implicit 3 reason)
|
||||
(optional ~label:"indirectCRL" @@ implicit 4 bool)
|
||||
(optional ~label:"onlyContainsAttributeCerts" @@ implicit 5 bool)
|
||||
|
||||
let crl_reason : reason Asn.t =
|
||||
let alist = [
|
||||
0, `Unspecified
|
||||
; 1, `Key_compromise
|
||||
; 2, `CA_compromise
|
||||
; 3, `Affiliation_changed
|
||||
; 4, `Superseded
|
||||
; 5, `Cessation_of_operation
|
||||
; 6, `Certificate_hold
|
||||
; 8, `Remove_from_CRL
|
||||
; 9, `Privilege_withdrawn
|
||||
; 10, `AA_compromise
|
||||
]
|
||||
in
|
||||
let rev = List.map (fun (k, v) -> (v, k)) alist in
|
||||
enumerated (fun i -> List.assoc i alist) (fun k -> List.assoc k rev)
|
||||
|
||||
let gen_names_of_str, gen_names_to_str = project_exn General_name.Asn.gen_names
|
||||
and auth_key_id_of_str, auth_key_id_to_str = project_exn authority_key_id
|
||||
and subj_key_id_of_str, subj_key_id_to_str = project_exn octet_string
|
||||
and key_usage_of_str, key_usage_to_str = project_exn key_usage
|
||||
and e_key_usage_of_str, e_key_usage_to_str = project_exn ext_key_usage
|
||||
and basic_constr_of_str, basic_constr_to_str = project_exn basic_constraints
|
||||
and pr_key_peri_of_str, pr_key_peri_to_str = project_exn priv_key_usage_period
|
||||
and name_con_of_str, name_con_to_str = project_exn name_constraints
|
||||
and crl_distrib_of_str, crl_distrib_to_str = project_exn crl_distribution_points
|
||||
and cert_pol_of_str, cert_pol_to_str = project_exn cert_policies
|
||||
and int_of_str, int_to_str = project_exn int
|
||||
and issuing_dp_of_str, issuing_dp_to_str = project_exn issuing_distribution_point
|
||||
and crl_reason_of_str, crl_reason_to_str = project_exn crl_reason
|
||||
and time_of_str, time_to_str = project_exn generalized_time_no_frac_s
|
||||
|
||||
(* XXX 4.2.1.4. - cert policies! ( and other x509 extensions ) *)
|
||||
|
||||
let reparse_extension_exn crit = case_of_oid_f [
|
||||
(ID.subject_alternative_name,
|
||||
fun cs -> B (Subject_alt_name, (crit, gen_names_of_str cs))) ;
|
||||
(ID.issuer_alternative_name,
|
||||
fun cs -> B (Issuer_alt_name, (crit, gen_names_of_str cs))) ;
|
||||
(ID.authority_key_identifier,
|
||||
fun cs -> B (Authority_key_id, (crit, auth_key_id_of_str cs))) ;
|
||||
(ID.subject_key_identifier,
|
||||
fun cs -> B (Subject_key_id, (crit, subj_key_id_of_str cs))) ;
|
||||
(ID.key_usage,
|
||||
fun cs -> B (Key_usage, (crit, key_usage_of_str cs))) ;
|
||||
(ID.basic_constraints,
|
||||
fun cs -> B (Basic_constraints, (crit, basic_constr_of_str cs))) ;
|
||||
(ID.crl_number,
|
||||
fun cs -> B (CRL_number, (crit, int_of_str cs))) ;
|
||||
(ID.delta_crl_indicator,
|
||||
fun cs -> B (Delta_CRL_indicator, (crit, int_of_str cs))) ;
|
||||
(ID.extended_key_usage,
|
||||
fun cs -> B (Ext_key_usage, (crit, e_key_usage_of_str cs))) ;
|
||||
(ID.private_key_usage_period,
|
||||
fun cs -> B (Priv_key_period, (crit, pr_key_peri_of_str cs))) ;
|
||||
(ID.name_constraints,
|
||||
fun cs -> B (Name_constraints, (crit, name_con_of_str cs))) ;
|
||||
(ID.crl_distribution_points,
|
||||
fun cs -> B (CRL_distribution_points, (crit, crl_distrib_of_str cs))) ;
|
||||
(ID.issuing_distribution_point,
|
||||
fun cs -> B (Issuing_distribution_point, (crit, issuing_dp_of_str cs))) ;
|
||||
(ID.freshest_crl,
|
||||
fun cs -> B (Freshest_CRL, (crit, crl_distrib_of_str cs))) ;
|
||||
(ID.reason_code,
|
||||
fun cs -> B (Reason, (crit, crl_reason_of_str cs))) ;
|
||||
(ID.invalidity_date,
|
||||
fun cs -> B (Invalidity_date, (crit, time_of_str cs))) ;
|
||||
(ID.certificate_issuer,
|
||||
fun cs -> B (Certificate_issuer, (crit, gen_names_of_str cs))) ;
|
||||
(ID.certificate_policies_2,
|
||||
fun cs -> B (Policies, (crit, cert_pol_of_str cs)))
|
||||
]
|
||||
~default:(fun oid -> fun cs -> B (Unsupported oid, (crit, cs)))
|
||||
|
||||
let unparse_extension (B (k, v)) =
|
||||
let v' = match k, v with
|
||||
| Subject_alt_name, (_, x) -> gen_names_to_str x
|
||||
| Issuer_alt_name, (_, x) -> gen_names_to_str x
|
||||
| Authority_key_id, (_, x) -> auth_key_id_to_str x
|
||||
| Subject_key_id, (_, x) -> subj_key_id_to_str x
|
||||
| Key_usage, (_, x) -> key_usage_to_str x
|
||||
| Basic_constraints, (_, x) -> basic_constr_to_str x
|
||||
| CRL_number, (_, x) -> int_to_str x
|
||||
| Delta_CRL_indicator, (_, x) -> int_to_str x
|
||||
| Ext_key_usage, (_, x) -> e_key_usage_to_str x
|
||||
| Priv_key_period, (_, x) -> pr_key_peri_to_str x
|
||||
| Name_constraints, (_, x) -> name_con_to_str x
|
||||
| CRL_distribution_points, (_, x) -> crl_distrib_to_str x
|
||||
| Issuing_distribution_point, (_, x) -> issuing_dp_to_str x
|
||||
| Freshest_CRL, (_, x) -> crl_distrib_to_str x
|
||||
| Reason, (_, x) -> crl_reason_to_str x
|
||||
| Invalidity_date, (_, x) -> time_to_str x
|
||||
| Certificate_issuer, (_, x) -> gen_names_to_str x
|
||||
| Policies, (_, x) -> cert_pol_to_str x
|
||||
| Unsupported _, (_, x) -> x
|
||||
in
|
||||
to_oid k, critical k v, v'
|
||||
|
||||
let extensions_der =
|
||||
let extension =
|
||||
let f (oid, crit, cs) =
|
||||
reparse_extension_exn (Option.value ~default:false crit) (oid, cs)
|
||||
and g b =
|
||||
let oid, crit, cs = unparse_extension b in
|
||||
(oid, (if crit = false then None else Some crit), cs)
|
||||
in
|
||||
map f g @@
|
||||
sequence3
|
||||
(required ~label:"id" oid)
|
||||
(optional ~label:"critical" bool) (* default false *)
|
||||
(required ~label:"value" octet_string)
|
||||
in
|
||||
let f exts =
|
||||
List.fold_left (fun map (B (k, v)) ->
|
||||
match add_unless_bound k v map with
|
||||
| None -> parse_error "%a already bound" (pp_one k) v
|
||||
| Some b -> b)
|
||||
empty exts
|
||||
and g map = bindings map
|
||||
in
|
||||
map f g @@ sequence_of extension
|
||||
end
|
||||
Loading…
Add table
Add a link
Reference in a new issue