swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

385
unikernel/duniverse/ocaml-x509/lib/algorithm.ml Normal file
View file

@ -0,0 +1,385 @@
open Asn.S
open Asn_grammars
(* This type really conflates three things: the set of pk algos that describe
* the public key, the set of hashes, and the set of hash+pk algo combinations
* that describe digests. The three are conflated because they are generated by
* the same ASN grammar, AlgorithmIdentifier, to keep things close to the
* standards.
*
* It's expected that downstream code with pick a subset and add a catch-all
* that handles unsupported algos anyway.
*)
type ec_curve =
[ `SECP256R1 | `SECP384R1 | `SECP521R1 ]
let ec_curve_to_string = function
| `SECP256R1 -> "SECP256R1"
| `SECP384R1 -> "SECP384R1"
| `SECP521R1 -> "SECP521R1"
type t =
(* pk algos *)
(* any more? is the universe big enough? ramsey's theorem for pk cyphers? *)
| RSA
| EC_pub of ec_curve
(* sig algos *)
| MD5_RSA
| SHA1_RSA
| SHA256_RSA
| SHA384_RSA
| SHA512_RSA
| SHA224_RSA
| ECDSA_SHA1
| ECDSA_SHA224
| ECDSA_SHA256
| ECDSA_SHA384
| ECDSA_SHA512
| ED25519
(* digest algorithms *)
| MD5
| SHA1
| SHA256
| SHA384
| SHA512
| SHA224
(* HMAC algorithms *)
| HMAC_SHA1
| HMAC_SHA224
| HMAC_SHA256
| HMAC_SHA384
| HMAC_SHA512
(* symmetric block ciphers *)
| AES128_CBC of string
| AES192_CBC of string
| AES256_CBC of string
(* PBE encryption algorithms *)
| SHA_RC4_128 of string * int
| SHA_RC4_40 of string * int
| SHA_3DES_CBC of string * int
| SHA_2DES_CBC of string * int
| SHA_RC2_128_CBC of string * int
| SHA_RC2_40_CBC of string * int
| PBKDF2 of string * int * int option * t
| PBES2 of t * t
let to_string = function
| RSA -> "RSA"
| EC_pub curve -> ec_curve_to_string curve
| MD5_RSA -> "RSA MD5"
| SHA1_RSA -> "RSA SHA1"
| SHA256_RSA -> "RSA SHA256"
| SHA384_RSA -> "RSA SHA384"
| SHA512_RSA -> "RSA SHA512"
| SHA224_RSA -> "RSA SHA224"
| ECDSA_SHA1 -> "ECDSA SHA1"
| ECDSA_SHA224 -> "ECDSA SHA224"
| ECDSA_SHA256 -> "ECDSA SHA256"
| ECDSA_SHA384 -> "ECDSA SHA384"
| ECDSA_SHA512 -> "ECDSA SHA512"
| ED25519 -> "Ed25519"
| MD5 -> "MD5"
| SHA1 -> "SHA1"
| SHA256 -> "SHA256"
| SHA384 -> "SHA384"
| SHA512 -> "SHA512"
| SHA224 -> "SHA224"
| HMAC_SHA1 -> "HMAC SHA1"
| HMAC_SHA224 -> "HMAC SHA224"
| HMAC_SHA256 -> "HMAC SHA256"
| HMAC_SHA384 -> "HMAC SHA384"
| HMAC_SHA512 -> "HMAC SHA512"
| AES128_CBC _ -> "AES128 CBC"
| AES192_CBC _ -> "AES192 CBC"
| AES256_CBC _ -> "AES256 CBC"
| SHA_RC4_128 (_, _) -> "PBES: SHA RC4 128"
| SHA_RC4_40 (_, _) -> "PBES: SHA RC4 40"
| SHA_3DES_CBC (_, _) -> "PBES: SHA 3DES CBC"
| SHA_2DES_CBC (_, _) -> "PBES: SHA 2DES CBC"
| SHA_RC2_128_CBC (_, _) -> "PBES: SHA RC2 128"
| SHA_RC2_40_CBC (_, _) -> "PBES: SHA RC2 40"
| PBKDF2 (_, _, _, _) -> "PBKDF2"
| PBES2 (_, _) -> "PBES2"
let to_hash = function
| MD5 -> Some `MD5
| SHA1 -> Some `SHA1
| SHA224 -> Some `SHA224
| SHA256 -> Some `SHA256
| SHA384 -> Some `SHA384
| SHA512 -> Some `SHA512
| _ -> None
and of_hash = function
| `MD5 -> MD5
| `SHA1 -> SHA1
| `SHA224 -> SHA224
| `SHA256 -> SHA256
| `SHA384 -> SHA384
| `SHA512 -> SHA512
and to_hmac = function
| HMAC_SHA1 -> Some `SHA1
| HMAC_SHA224 -> Some `SHA224
| HMAC_SHA256 -> Some `SHA256
| HMAC_SHA384 -> Some `SHA384
| HMAC_SHA512 -> Some `SHA512
| _ -> None
and of_hmac = function
| `SHA1 -> HMAC_SHA1
| `SHA224 -> HMAC_SHA224
| `SHA256 -> HMAC_SHA256
| `SHA384 -> HMAC_SHA384
| `SHA512 -> HMAC_SHA512
and to_key_type = function
| RSA -> Some `RSA
| EC_pub curve -> Some (`EC curve)
| ED25519 -> Some `ED25519
| _ -> None
and of_key_type = function
| `RSA -> RSA
| `EC curve -> EC_pub curve
| `ED25519 -> ED25519
and to_signature_algorithm = function
| MD5_RSA -> Some (`RSA_PKCS1, `MD5)
| SHA1_RSA -> Some (`RSA_PKCS1, `SHA1)
| SHA256_RSA -> Some (`RSA_PKCS1, `SHA256)
| SHA384_RSA -> Some (`RSA_PKCS1, `SHA384)
| SHA512_RSA -> Some (`RSA_PKCS1, `SHA512)
| SHA224_RSA -> Some (`RSA_PKCS1, `SHA224)
| ECDSA_SHA1 -> Some (`ECDSA, `SHA1)
| ECDSA_SHA224 -> Some (`ECDSA, `SHA224)
| ECDSA_SHA256 -> Some (`ECDSA, `SHA256)
| ECDSA_SHA384 -> Some (`ECDSA, `SHA384)
| ECDSA_SHA512 -> Some (`ECDSA, `SHA512)
| ED25519 -> Some (`ED25519, `SHA512)
| _ -> None
and of_signature_algorithm public_key_algorithm digest =
match public_key_algorithm, digest with
| (`RSA_PKCS1, `MD5) -> MD5_RSA
| (`RSA_PKCS1, `SHA1) -> SHA1_RSA
| (`RSA_PKCS1, `SHA256) -> SHA256_RSA
| (`RSA_PKCS1, `SHA384) -> SHA384_RSA
| (`RSA_PKCS1, `SHA512) -> SHA512_RSA
| (`RSA_PKCS1, `SHA224) -> SHA224_RSA
| (`ECDSA, `SHA1) -> ECDSA_SHA1
| (`ECDSA, `SHA224) -> ECDSA_SHA224
| (`ECDSA, `SHA256) -> ECDSA_SHA256
| (`ECDSA, `SHA384) -> ECDSA_SHA384
| (`ECDSA, `SHA512) -> ECDSA_SHA512
| (`ED25519, _) -> ED25519
| _ -> failwith "unsupported signature scheme and hash"
(* XXX
*
* PKCS1/RFC5280 allows params to be `ANY', depending on the algorithm. I don't
* know of one that uses anything other than NULL and OID, however, so we accept
* only that.
RFC 3279 Section 2.2.1 defines for RSA Signature Algorithms SHALL have null
as parameter, but certificates in the wild don't contain the parameter field
at all (it is optional). We accept both, and output a null paramter.
Section 2.2.2 specifies DSA to have a null parameter,
Section 2.2.3 specifies ECDSA to have a null parameter,
Section 2.3.1 specifies rsaEncryption (for RSA public keys) requires null.
*)
let curve_of_oid, curve_to_oid =
let open Registry.ANSI_X9_62 in
(let default oid = Asn.(S.parse_error "Unknown algorithm %a" OID.pp oid) in
case_of_oid ~default [
(secp256r1, `SECP256R1) ;
(secp384r1, `SECP384R1) ;
(secp521r1, `SECP521R1) ;
]),
(function
| `SECP256R1 -> secp256r1
| `SECP384R1 -> secp384r1
| `SECP521R1 -> secp521r1)
let identifier =
let open Registry in
let f =
let none x = function
| None -> x
| _ -> parse_error "Algorithm: expected no parameters"
and null x = function
| Some (`C1 ()) -> x
| _ -> parse_error "Algorithm: expected null parameters"
and null_or_none x = function
| None | Some (`C1 ()) -> x
| _ -> parse_error "Algorithm: expected null or none parameter"
and oid f = function
| Some (`C2 id) -> f id
| _ -> parse_error "Algorithm: expected parameter OID"
and pbe f = function
| Some (`C3 `PBE pbe) -> f pbe
| _ -> parse_error "Algorithm: expected parameter PBE"
and pbkdf2 f = function
| Some (`C3 `PBKDF2 params) -> f params
| _ -> parse_error "Algorithm: expected parameter PBKDF2"
and pbes2 f = function
| Some (`C3 `PBES2 params) -> f params
| _ -> parse_error "Algorithm: expected parameter PBES2"
and octets f = function
| Some (`C4 salt) -> f salt
| _ -> parse_error "Algorithm: expected parameter octet_string"
and default oid = Asn.(S.parse_error "Unknown algorithm %a" OID.pp oid)
in
case_of_oid_f ~default [
(ANSI_X9_62.ec_pub_key, oid (fun id -> EC_pub (curve_of_oid id))) ;
(PKCS1.rsa_encryption , null RSA ) ;
(PKCS1.md5_rsa_encryption , null_or_none MD5_RSA ) ;
(PKCS1.sha1_rsa_encryption , null_or_none SHA1_RSA ) ;
(sha1_rsa_encryption , null_or_none SHA1_RSA ) ;
(PKCS1.sha256_rsa_encryption , null_or_none SHA256_RSA ) ;
(PKCS1.sha384_rsa_encryption , null_or_none SHA384_RSA ) ;
(PKCS1.sha512_rsa_encryption , null_or_none SHA512_RSA ) ;
(PKCS1.sha224_rsa_encryption , null_or_none SHA224_RSA ) ;
(ANSI_X9_62.ecdsa_sha1 , none ECDSA_SHA1 ) ;
(ANSI_X9_62.ecdsa_sha224 , none ECDSA_SHA224 ) ;
(ANSI_X9_62.ecdsa_sha256 , none ECDSA_SHA256 ) ;
(ANSI_X9_62.ecdsa_sha384 , none ECDSA_SHA384 ) ;
(ANSI_X9_62.ecdsa_sha512 , none ECDSA_SHA512 ) ;
(RFC8410.ed25519 , none ED25519 ) ;
(md5 , null MD5 ) ;
(sha1 , null SHA1 ) ;
(sha256 , null SHA256 ) ;
(sha384 , null SHA384 ) ;
(sha512 , null SHA512 ) ;
(sha224 , null SHA224 ) ;
(PKCS2.hmac_sha1 , null HMAC_SHA1 );
(PKCS2.hmac_sha224 , null HMAC_SHA224 );
(PKCS2.hmac_sha256 , null HMAC_SHA256 );
(PKCS2.hmac_sha384 , null HMAC_SHA384 );
(PKCS2.hmac_sha512 , null HMAC_SHA512 );
(PKCS5.aes128_cbc , octets (fun iv -> AES128_CBC iv));
(PKCS5.aes192_cbc , octets (fun iv -> AES192_CBC iv));
(PKCS5.aes256_cbc , octets (fun iv -> AES256_CBC iv));
(PKCS12.pbe_with_SHA_and_128Bit_RC4, pbe (fun (s, i) -> SHA_RC4_128 (s, i))) ;
(PKCS12.pbe_with_SHA_and_40Bit_RC4, pbe (fun (s, i) -> SHA_RC4_40 (s, i))) ;
(PKCS12.pbe_with_SHA_and_3_KeyTripleDES_CBC, pbe (fun (s, i) -> SHA_3DES_CBC (s, i))) ;
(PKCS12.pbe_with_SHA_and_2_KeyTripleDES_CBC, pbe (fun (s, i) -> SHA_2DES_CBC (s, i))) ;
(PKCS12.pbe_with_SHA_and_128Bit_RC2_CBC, pbe (fun (s, i) -> SHA_RC2_128_CBC (s, i))) ;
(PKCS12.pbe_with_SHA_and_40Bit_RC2_CBC, pbe (fun (s, i) -> SHA_RC2_40_CBC (s, i))) ;
(PKCS5.pbkdf2, pbkdf2 (fun (s, i, l, m) -> PBKDF2 (s, i, l, m))) ;
(PKCS5.pbes2, pbes2 (fun (oid, oid') -> PBES2 (oid, oid')))
]
and g =
let none = None
and null = Some (`C1 ())
and oid id = Some (`C2 id)
and pbe (s, i) = Some (`C3 (`PBE (s, i)))
and pbkdf2 (s, i, k, m) = Some (`C3 (`PBKDF2 (s, i, k, m)))
and pbes2 (oid, oid') = Some (`C3 (`PBES2 (oid, oid')))
and octets data = Some (`C4 data)
in
function
| EC_pub id -> (ANSI_X9_62.ec_pub_key , oid (curve_to_oid id))
| RSA -> (PKCS1.rsa_encryption , null)
| MD5_RSA -> (PKCS1.md5_rsa_encryption , null)
| SHA1_RSA -> (PKCS1.sha1_rsa_encryption , null)
| SHA256_RSA -> (PKCS1.sha256_rsa_encryption , null)
| SHA384_RSA -> (PKCS1.sha384_rsa_encryption , null)
| SHA512_RSA -> (PKCS1.sha512_rsa_encryption , null)
| SHA224_RSA -> (PKCS1.sha224_rsa_encryption , null)
| ECDSA_SHA1 -> (ANSI_X9_62.ecdsa_sha1 , none)
| ECDSA_SHA224 -> (ANSI_X9_62.ecdsa_sha224 , none)
| ECDSA_SHA256 -> (ANSI_X9_62.ecdsa_sha256 , none)
| ECDSA_SHA384 -> (ANSI_X9_62.ecdsa_sha384 , none)
| ECDSA_SHA512 -> (ANSI_X9_62.ecdsa_sha512 , none)
| ED25519 -> (RFC8410.ed25519 , none)
| MD5 -> (md5 , null)
| SHA1 -> (sha1 , null)
| SHA256 -> (sha256 , null)
| SHA384 -> (sha384 , null)
| SHA512 -> (sha512 , null)
| SHA224 -> (sha224 , null)
| HMAC_SHA1 -> (PKCS2.hmac_sha1 , null)
| HMAC_SHA224 -> (PKCS2.hmac_sha224 , null)
| HMAC_SHA256 -> (PKCS2.hmac_sha256 , null)
| HMAC_SHA384 -> (PKCS2.hmac_sha384 , null)
| HMAC_SHA512 -> (PKCS2.hmac_sha512 , null)
| AES128_CBC iv -> (PKCS5.aes128_cbc , octets iv)
| AES192_CBC iv -> (PKCS5.aes192_cbc , octets iv)
| AES256_CBC iv -> (PKCS5.aes256_cbc , octets iv)
| SHA_RC4_128 (s, i) -> (PKCS12.pbe_with_SHA_and_128Bit_RC4, pbe (s, i))
| SHA_RC4_40 (s, i) -> (PKCS12.pbe_with_SHA_and_40Bit_RC4, pbe (s, i))
| SHA_3DES_CBC (s, i) -> (PKCS12.pbe_with_SHA_and_3_KeyTripleDES_CBC, pbe (s, i))
| SHA_2DES_CBC (s, i) -> (PKCS12.pbe_with_SHA_and_2_KeyTripleDES_CBC, pbe (s, i))
| SHA_RC2_128_CBC (s, i) -> (PKCS12.pbe_with_SHA_and_128Bit_RC2_CBC, pbe (s, i))
| SHA_RC2_40_CBC (s, i) -> (PKCS12.pbe_with_SHA_and_40Bit_RC2_CBC, pbe (s, i))
| PBKDF2 (s, i, k, m) -> (PKCS5.pbkdf2, pbkdf2 (s, i, k, m))
| PBES2 (oid, oid') -> (PKCS5.pbes2, pbes2 (oid, oid'))
in
fix (fun id ->
let pbkdf2_or_pbe_or_pbes2_params =
(* TODO PBKDF2 should support `C2 oid (saltSources) *)
let f (salt, count, (* key_len, *) prf) =
match salt, count, (* key_len, *) prf with
| `C1 salt, Some count, (* None, *) None -> `PBE (salt, count)
| `C1 salt, Some count, (* x, *) Some prf -> `PBKDF2 (salt, count, None, prf)
| `C2 oid, None, (* None, *) Some oid' -> `PBES2 (oid, oid')
| _ -> parse_error "bad parameters"
and g = function
| `PBE (salt, count) -> (`C1 salt, Some count, (* None, *) None)
| `PBKDF2 (salt, count, _key_len, prf) -> (`C1 salt, Some count, (* key_len, *) Some prf)
| `PBES2 (oid, oid') -> (`C2 oid, None, (* None, *) Some oid')
in
map f g @@
sequence3
(required ~label:"salt" (choice2 octet_string id))
(optional ~label:"iteration count" int) (* modified - required for pbkdf2/pbes *)
(* (optional ~label:"key length" int) (* should be there and optional *) *)
(optional ~label:"prf" id) (* only present in pbkdf2 / pbes2 *)
in
map f g @@
sequence2
(required ~label:"algorithm" oid)
(optional ~label:"params"
(choice4 null oid pbkdf2_or_pbe_or_pbes2_params octet_string)))
let ecdsa_sig =
sequence2
(required ~label:"r" unsigned_integer)
(required ~label:"s" unsigned_integer)
let ecdsa_sig_of_octets, ecdsa_sig_to_octets =
projections_of Asn.der ecdsa_sig
let pp fmt x = Fmt.string fmt (to_string x)

74
unikernel/duniverse/ocaml-x509/lib/asn_grammars.ml Normal file
View file

@ -0,0 +1,74 @@
let src = Logs.Src.create "x509.decoding" ~doc:"X509 decoding"
module Log = (val Logs.src_log src : Logs.LOG)
let ( let* ) = Result.bind
let decode codec cs =
let* a, cs = Asn.decode codec cs in
if String.length cs = 0 then Ok a else Error (`Parse "Leftover")
let projections_of encoding asn =
let c = Asn.codec encoding asn in (decode c, Asn.encode c)
module Hashtbl(T : Hashtbl.HashedType) = struct
include Hashtbl.Make (T)
let of_assoc xs =
let ht = create 16 in List.iter (fun (a, b) -> add ht a b) xs; ht
end
module OID_H = Hashtbl (struct
type t = Asn.oid let (equal, hash) = Asn.OID.(equal, hash)
end)
let case_of_oid ~default xs =
let ht = OID_H.of_assoc xs in fun a ->
try OID_H.find ht a with Not_found -> default a
let case_of_oid_f ~default xs =
let ht = OID_H.of_assoc xs in fun (a, b) ->
(try OID_H.find ht a with Not_found -> default a) b
(*
* A way to parse by propagating (and contributing to) exceptions, so those can
* be handles up in a single place. Meant for parsing embedded structures.
*
* XXX Would be nicer if combinators could handle embedded structures.
*)
let project_exn asn =
let c = Asn.(codec der) asn in
let dec cs = match decode c cs with
| Ok a -> a
| Error err -> Asn.S.error err in
(dec, Asn.encode c)
let err_to_msg f = Result.map_error (function `Parse msg -> `Msg msg) f
(* specified in RFC 5280 4.1.2.5.2 - "MUST NOT include fractional seconds" *)
let generalized_time_no_frac_s =
Asn.S.(map
(fun x ->
if Ptime.Span.(equal zero (Ptime.frac_s x)) then
x
else
parse_error "generalized time has fractional seconds")
(fun y -> Ptime.truncate ~frac_s:0 y)
generalized_time)
(* serial number, as defined in RFC 5280 4.1.2.2: must be > 0 and not be longer
than 20 octets. we accept 0.
we also accept < 0, but when encoding mandate >= 0!
*)
let serial =
Asn.S.(map
(fun x ->
if String.length x > 20 then parse_error "serial exceeds 20 octets";
if String.length x > 0 && String.get_uint8 x 0 > 0x7F then
Log.warn (fun m -> m "negative serial number %a" Ohex.pp x);
x)
(fun y ->
if String.length y > 20 then failwith "serial exceeds 20 octets";
if String.length y > 0 && String.get_uint8 y 0 > 0x7F then
"\x00" ^ y
else
y)
integer)

83
unikernel/duniverse/ocaml-x509/lib/authenticator.ml Normal file
View file

@ -0,0 +1,83 @@
let ( let* ) = Result.bind
type t = ?ip:Ipaddr.t -> host:[`host] Domain_name.t option ->
Certificate.t list -> Validation.r
(* XXX
* Authenticator just hands off a list of certs. Should be indexed.
* *)
let chain_of_trust ~time ?crls ?(allowed_hashes = Validation.sha2) cas =
let revoked = match crls with
| None -> None
| Some crls -> Some (Crl.is_revoked crls ~allowed_hashes)
in
fun ?ip ~host certificates ->
Validation.verify_chain_of_trust ?ip ~host ~time ?revoked ~allowed_hashes
~anchors:cas certificates
let key_fingerprint ~time ~hash ~fingerprint =
fun ?ip ~host certificates ->
Validation.trust_key_fingerprint ?ip ~host ~time ~hash ~fingerprint certificates
let cert_fingerprint ~time ~hash ~fingerprint =
fun ?ip ~host certificates ->
Validation.trust_cert_fingerprint ?ip ~host ~time ~hash ~fingerprint certificates
let hash_of_string = function
| "sha224" -> Ok `SHA224
| "sha256" -> Ok `SHA256
| "sha384" -> Ok `SHA384
| "sha512" -> Ok `SHA512
| hash -> Error (`Msg (Fmt.str "Unknown hash algorithm %S" hash))
let fingerprint_of_string s =
let* d =
Result.map_error
(function `Msg m ->
`Msg (Fmt.str "Invalid base64 encoding in fingerprint (%s): %S" m s))
(Base64.decode ~pad:false s)
in
Ok d
let format =
{|
The format of an authenticator is:
- [none]: no authentication
- [key-fp(:<hash>?):<base64-encoded fingerprint>]: to authenticate a peer via
its key fingerprintf (hash is optional and defaults to SHA256)
- [cert-fp(:<hash>?):<base64-encoded fingerprint>]: to authenticate a peer via
its certificate fingerprint (hash is optional and defaults to SHA256)
- [trust-anchor(:<base64-encoded DER certificate>)+] to authenticate a peer from
a list of certificates (certificate must be in PEM format witthout header and
footer (----BEGIN CERTIFICATE----) and without newlines).
|}
let of_string str =
begin match String.split_on_char ':' str with
| [ "key-fp" ; hash ; tls_key_fingerprint ] ->
let* hash = hash_of_string (String.lowercase_ascii hash) in
let* fingerprint = fingerprint_of_string tls_key_fingerprint in
Ok (fun time -> key_fingerprint ~time ~hash ~fingerprint)
| [ "key-fp" ; tls_key_fingerprint ] ->
let* fingerprint = fingerprint_of_string tls_key_fingerprint in
Ok (fun time -> key_fingerprint ~time ~hash:`SHA256 ~fingerprint)
| [ "cert-fp" ; hash ; tls_cert_fingerprint ] ->
let* hash = hash_of_string (String.lowercase_ascii hash) in
let* fingerprint = fingerprint_of_string tls_cert_fingerprint in
Ok (fun time -> cert_fingerprint ~time ~hash ~fingerprint)
| [ "cert-fp" ; tls_cert_fingerprint ] ->
let* fingerprint = fingerprint_of_string tls_cert_fingerprint in
Ok (fun time -> cert_fingerprint ~time ~hash:`SHA256 ~fingerprint)
| "trust-anchor" :: certs ->
let* anchors =
List.fold_left (fun acc s ->
let* acc = acc in
let* der = Base64.decode ~pad:false s in
let* cert = Certificate.decode_der der in
Ok (cert :: acc))
(Ok []) certs
in
Ok (fun time -> chain_of_trust ~time (List.rev anchors))
| [ "none" ] -> Ok (fun _ ?ip:_ ~host:_ _ -> Ok None)
| _ -> Error (`Msg (Fmt.str "Invalid TLS authenticator: %S" str))
end |> Result.map_error (function `Msg e -> `Msg (e ^ format))

264
unikernel/duniverse/ocaml-x509/lib/certificate.ml Normal file
View file

@ -0,0 +1,264 @@
(*
* X509 certs
*)
type tBSCertificate = {
version : [ `V1 | `V2 | `V3 ] ;
serial : string ;
signature : Algorithm.t ;
issuer : Distinguished_name.t ;
validity : Ptime.t * Ptime.t ;
subject : Distinguished_name.t ;
pk_info : Public_key.t ;
issuer_id : string option ;
subject_id : string option ;
extensions : Extension.t
}
type certificate = {
tbs_cert : tBSCertificate ;
signature_algo : Algorithm.t ;
signature_val : string
}
(*
* There are two reasons to carry octets around:
* - we still need to hack on the octets to get bytes to hash
* ( this needs to go )
* - we need a cs to send to the peer
* It's a bit ugly to have two levels, and both are better solved by extending
* the asn parser and writer respectively, but until then there needs to be one
* place that hides the existence of this pair.
*)
type t = {
asn : certificate ;
raw : string
}
module Asn = struct
open Asn.S
open Asn_grammars
let version =
map (function 2 -> `V3 | 1 -> `V2 | 0 -> `V1 | _ -> parse_error "unknown version")
(function `V3 -> 2 | `V2 -> 1 | `V1 -> 0)
int
let time =
let f = function `C1 t -> t | `C2 t -> t
and g t =
let (y, _, _) = Ptime.to_date t in
if y < 2050 then `C1 t else `C2 t in
map f g (choice2 utc_time generalized_time_no_frac_s)
let validity =
sequence2
(required ~label:"not before" time)
(required ~label:"not after" time)
let unique_identifier = bit_string_octets
let tBSCertificate =
let f = fun (a, (b, (c, (d, (e, (f, (g, (h, (i, j))))))))) ->
let extn = match j with None -> Extension.empty | Some xs -> xs in
{ version = Option.value ~default:`V1 a ; serial = b ;
signature = c ; issuer = d ;
validity = e ; subject = f ;
pk_info = g ; issuer_id = h ;
subject_id = i ; extensions = extn }
and g = fun
{ version = a ; serial = b ;
signature = c ; issuer = d ;
validity = e ; subject = f ;
pk_info = g ; issuer_id = h ;
subject_id = i ; extensions = j } ->
let extn = if Extension.is_empty j then None else Some j in
((if a = `V1 then None else Some a),
(b, (c, (d, (e, (f, (g, (h, (i, extn)))))))))
in
map f g @@
sequence @@
(optional ~label:"version" @@ explicit 0 version) (* default v1 *)
@ (required ~label:"serialNumber" @@ serial)
@ (required ~label:"signature" @@ Algorithm.identifier)
@ (required ~label:"issuer" @@ Distinguished_name.Asn.name)
@ (required ~label:"validity" @@ validity)
@ (required ~label:"subject" @@ Distinguished_name.Asn.name)
@ (required ~label:"subjectPKInfo" @@ Public_key.Asn.pk_info_der)
(* if present, version is v2 or v3 *)
@ (optional ~label:"issuerUID" @@ implicit 1 unique_identifier)
(* if present, version is v2 or v3 *)
@ (optional ~label:"subjectUID" @@ implicit 2 unique_identifier)
(* v3 if present *)
-@ (optional ~label:"extensions" @@ explicit 3 Extension.Asn.extensions_der)
let (tbs_certificate_of_octets, tbs_certificate_to_octets) =
projections_of Asn.der tBSCertificate
let certificate =
let f (a, b, c) =
if a.signature <> b then
parse_error "signatureAlgorithm != tbsCertificate.signature"
else
{ tbs_cert = a; signature_algo = b; signature_val = c }
and g { tbs_cert = a; signature_algo = b; signature_val = c } = (a, b, c) in
map f g @@
sequence3
(required ~label:"tbsCertificate" tBSCertificate)
(required ~label:"signatureAlgorithm" Algorithm.identifier)
(required ~label:"signatureValue" bit_string_octets)
let (certificate_of_octets, certificate_to_octets) =
projections_of Asn.der certificate
let pkcs1_digest_info =
let open Algorithm in
let f (algo, cs) =
match to_hash algo with
| Some h -> (h, cs)
| None -> parse_error "pkcs1 digest info: unknown hash"
and g (h, cs) = (of_hash h, cs)
in
map f g @@
sequence2
(required ~label:"digestAlgorithm" Algorithm.identifier)
(required ~label:"digest" octet_string)
let (pkcs1_digest_info_of_octets, pkcs1_digest_info_to_octets) =
projections_of Asn.der pkcs1_digest_info
end
let decode_pkcs1_digest_info cs =
Asn_grammars.err_to_msg (Asn.pkcs1_digest_info_of_octets cs)
let encode_pkcs1_digest_info = Asn.pkcs1_digest_info_to_octets
let ( let* ) = Result.bind
let decode_der cs =
let* asn = Asn_grammars.err_to_msg (Asn.certificate_of_octets cs) in
Ok { asn ; raw = cs }
let encode_der { raw ; _ } = raw
let decode_pem_multiple cs =
let* data = Pem.parse cs in
let certs =
List.filter (fun (t, _) -> String.equal "CERTIFICATE" t) data
in
Pem.foldM (fun (_, cs) -> decode_der cs) certs
let fold_decode_pem_multiple fn acc cs =
List.fold_left
(fun acc data ->
let data = match data with
| Ok ("CERTIFICATE", cs) -> decode_der cs
| Ok (hdr, _) -> Error (`Msg ("ignore non certificate (" ^ hdr ^ ")"))
| Error e -> Error e
in
fn acc data)
acc
(Pem.parse_with_errors cs)
let decode_pem cs =
let* certs = decode_pem_multiple cs in
Pem.exactly_one ~what:"certificate" certs
let encode_pem v =
Pem.unparse ~tag:"CERTIFICATE" (encode_der v)
let encode_pem_multiple cs =
String.concat "" (List.map encode_pem cs)
let pp_version ppf v =
Fmt.string ppf (match v with `V1 -> "1" | `V2 -> "2" | `V3 -> "3")
let pp_hash ppf hash =
Fmt.string ppf (match hash with
| `MD5 -> "MD5" | `SHA1 -> "SHA1" | `SHA224 -> "SHA224"
| `SHA256 -> "SHA256" | `SHA384 -> "SHA384" | `SHA512 -> "SHA512")
let pp_sigalg ppf (asym, hash) =
Fmt.pf ppf "%a-%a" Key_type.pp_signature_scheme asym pp_hash hash
let pp' pp_custom_extensions ppf { asn ; _ } =
let tbs = asn.tbs_cert in
let sigalg = Algorithm.to_signature_algorithm tbs.signature in
Fmt.pf ppf "X.509 certificate@.version %a@.serial %a@.algorithm %a@.issuer %a@.valid from %a until %a@.subject %a@.extensions %a"
pp_version tbs.version Ohex.pp tbs.serial
Fmt.(option ~none:(any "NONE") pp_sigalg) sigalg
Distinguished_name.pp tbs.issuer
(Ptime.pp_human ~tz_offset_s:0 ()) (fst tbs.validity)
(Ptime.pp_human ~tz_offset_s:0 ()) (snd tbs.validity)
Distinguished_name.pp tbs.subject
(Extension.pp' pp_custom_extensions) tbs.extensions
let pp = pp' Extension.default_pp_custom_extension
let fingerprint hash cert =
let module Hash = (val (Digestif.module_of_hash' hash)) in
Hash.(to_raw_string (digest_string cert.raw))
let issuer { asn ; _ } = asn.tbs_cert.issuer
let subject { asn ; _ } = asn.tbs_cert.subject
let serial { asn ; _ } = asn.tbs_cert.serial
let validity { asn ; _ } = asn.tbs_cert.validity
let signature_algorithm { asn ; _ } =
Algorithm.to_signature_algorithm asn.signature_algo
let public_key { asn = cert ; _ } = cert.tbs_cert.pk_info
let supports_keytype c t =
match public_key c, t with
| (`RSA _), `RSA -> true
| _ -> false
let extensions { asn = cert ; _ } = cert.tbs_cert.extensions
(* RFC 6125, 6.4.4:
Therefore, if and only if the presented identifiers do not include a
DNS-ID, SRV-ID, URI-ID, or any application-specific identifier types
supported by the client, then the client MAY as a last resort check
for a string whose form matches that of a fully qualified DNS domain
name in a Common Name field of the subject field (i.e., a CN-ID). If
the client chooses to compare a reference identifier of type CN-ID
against that string, it MUST follow the comparison rules for the DNS
domain name portion of an identifier of type DNS-ID, SRV-ID, or
URI-ID, as described under Section 6.4.1, Section 6.4.2, and
Section 6.4.3. *)
let hostnames { asn = cert ; _ } =
let subj =
match Distinguished_name.common_name cert.tbs_cert.subject with
| None -> Host.Set.empty
| Some x ->
match Host.host x with
| Some (wild, d) -> Host.Set.singleton (wild, d)
| None -> Host.Set.empty
in
match Extension.hostnames cert.tbs_cert.extensions with
| Some names -> names
| None -> subj
let supports_hostname cert name =
let names = hostnames cert in
let wc_name_opt =
match Domain_name.drop_label name with
| Error _ -> None
| Ok name -> match Domain_name.host name with
| Ok hostname -> Some hostname
| Error _ -> None
in
Host.Set.mem (`Strict, name) names
|| (match wc_name_opt with
| None -> false
| Some wc_name -> Host.Set.mem (`Wildcard, wc_name) names)
let ips { asn = cert ; _ } =
match Extension.ips cert.tbs_cert.extensions with
| None -> Ipaddr.Set.empty
| Some ips -> ips
let supports_ip cert ip = Ipaddr.Set.mem ip (ips cert)

251
unikernel/duniverse/ocaml-x509/lib/crl.ml Normal file
View file

@ -0,0 +1,251 @@
type revoked_cert = {
serial : string ;
date : Ptime.t ;
extensions : Extension.t
}
type tBS_CRL = {
version : [ `V1 | `V2 ] ;
signature : Algorithm.t ;
issuer : Distinguished_name.t ;
this_update : Ptime.t ;
next_update : Ptime.t option ;
revoked_certs : revoked_cert list ;
extensions : Extension.t
}
type crl = {
tbs_crl : tBS_CRL ;
signature_algo : Algorithm.t ;
signature_val : string
}
module Asn = struct
open Asn.S
open Asn_grammars
let revokedCertificate =
let f (serial, date, e) =
let extensions = match e with None -> Extension.empty | Some xs -> xs in
{ serial ; date ; extensions }
and g { serial ; date ; extensions } =
let e = if Extension.is_empty extensions then None else Some extensions in
(serial, date, e)
in
map f g @@
sequence3
(required ~label:"userCertificate" @@ serial)
(required ~label:"revocationDate" @@ Certificate.Asn.time)
(optional ~label:"crlEntryExtensions" @@ Extension.Asn.extensions_der)
let version =
map
(function 0 -> `V1 | 1 -> `V2 | _ -> parse_error "unknown version")
(function `V2 -> 1 | `V1 -> 0)
int
let tBSCertList =
let f (a, (b, (c, (d, (e, (f, g)))))) =
{ version = Option.value ~default:`V1 a ; signature = b ; issuer = c ;
this_update = d ; next_update = e ;
revoked_certs = (match f with None -> [] | Some xs -> xs) ;
extensions = (match g with None -> Extension.empty | Some xs -> xs) }
and g { version = a ; signature = b ; issuer = c ;
this_update = d ; next_update = e ; revoked_certs = f ;
extensions = g } =
let f = match f with [] -> None | xs -> Some xs
and g = if Extension.is_empty g then None else Some g
in
((if a = `V1 then None else Some a), (b, (c, (d, (e, (f, g))))))
in
map f g @@
sequence @@
(optional ~label:"version" @@ version)
@ (required ~label:"signature" @@ Algorithm.identifier)
@ (required ~label:"issuer" @@ Distinguished_name.Asn.name)
@ (required ~label:"thisUpdate" @@ Certificate.Asn.time)
@ (optional ~label:"nextUpdate" @@ Certificate.Asn.time)
@ (optional ~label:"revokedCertificates" @@ sequence_of revokedCertificate)
-@ (optional ~label:"crlExtensions" @@ explicit 0 Extension.Asn.extensions_der)
let certificateList =
let f (cl, sa, sv) =
if cl.signature <> sa then
parse_error "signatureAlgorithm != tbsCertList.signature"
else
{ tbs_crl = cl ; signature_algo = sa ; signature_val = sv }
and g { tbs_crl ; signature_algo ; signature_val } =
(tbs_crl, signature_algo, signature_val)
in
map f g @@
sequence3
(required ~label:"tbsCertList" @@ tBSCertList)
(required ~label:"signatureAlgorithm" @@ Algorithm.identifier)
(required ~label:"signatureValue" @@ bit_string_octets)
let (crl_of_octets, crl_to_octets) =
projections_of Asn.der certificateList
let (tbs_CRL_of_octets, tbs_CRL_to_octets) =
projections_of Asn.der tBSCertList
end
type t = {
raw : string ;
asn : crl ;
}
let guard p e = if p then Ok () else Error e
let ( let* ) = Result.bind
let decode_der raw =
let* asn = Asn_grammars.err_to_msg (Asn.crl_of_octets raw) in
Ok { raw ; asn }
let encode_der { raw ; _ } = raw
let issuer { asn ; _ } = asn.tbs_crl.issuer
let this_update { asn ; _ } = asn.tbs_crl.this_update
let next_update { asn ; _ } = asn.tbs_crl.next_update
let extensions { asn ; _ } = asn.tbs_crl.extensions
let revoked_certificates { asn ; _ } = asn.tbs_crl.revoked_certs
let crl_number { asn ; _ } =
match Extension.(find CRL_number asn.tbs_crl.extensions) with
| None -> None
| Some (_, x) -> Some x
let signature_algorithm { asn ; _ } =
Algorithm.to_signature_algorithm asn.signature_algo
let validate { raw ; asn } ?(allowed_hashes = Validation.sha2) pub =
let tbs_raw = Validation.raw_cert_hack raw in
Validation.validate_raw_signature asn.tbs_crl.issuer allowed_hashes
tbs_raw asn.signature_algo asn.signature_val pub
type verification_error = [
| Validation.signature_error
| `Issuer_subject_mismatch of Distinguished_name.t * Distinguished_name.t
| `Not_yet_valid of Distinguished_name.t * Ptime.t * Ptime.t
| `Next_update_scheduled of Distinguished_name.t * Ptime.t * Ptime.t
]
let pp_verification_error ppf = function
| #Validation.signature_error as e -> Validation.pp_signature_error ppf e
| `Issuer_subject_mismatch (issuer, subj) ->
Fmt.pf ppf "issuer %a does not match subject %a"
Distinguished_name.pp issuer Distinguished_name.pp subj
| `Not_yet_valid (issuer, now, created) ->
Fmt.pf ppf "CRL %a not yet valid, valid from %a, now %a"
Distinguished_name.pp issuer
(Ptime.pp_human ~tz_offset_s:0 ()) created
(Ptime.pp_human ~tz_offset_s:0 ()) now
| `Next_update_scheduled (issuer, now, scheduled) ->
Fmt.pf ppf "CRL %a next update already scheduled at %a, now %a"
Distinguished_name.pp issuer
(Ptime.pp_human ~tz_offset_s:0 ()) scheduled
(Ptime.pp_human ~tz_offset_s:0 ()) now
let verify ({ asn ; _ } as crl) ?allowed_hashes ?time cert =
let subj = Certificate.subject cert in
let* () =
guard
(Distinguished_name.equal asn.tbs_crl.issuer subj)
(`Issuer_subject_mismatch (asn.tbs_crl.issuer, subj))
in
let* () =
match time with
| None -> Ok ()
| Some x ->
let* () =
guard (Ptime.is_later ~than:asn.tbs_crl.this_update x)
(`Not_yet_valid (subj, x, asn.tbs_crl.this_update))
in
match asn.tbs_crl.next_update with
| None -> Ok ()
| Some y -> guard (Ptime.is_earlier ~than:y x)
(`Next_update_scheduled (subj, x, y))
in
validate ?allowed_hashes crl (Certificate.public_key cert)
let reason (revoked : revoked_cert) =
match Extension.(find Reason revoked.extensions) with
| Some (_, x) -> Some x
| None -> None
let is_revoked ?allowed_hashes ~issuer:super ~cert (crls : t list) =
List.exists (fun crl ->
if
Distinguished_name.equal (Certificate.subject super) (issuer crl)
then
match validate ?allowed_hashes crl (Certificate.public_key super) with
| Ok () ->
begin try
let entry = List.find
(fun r -> String.equal (Certificate.serial cert) r.serial)
(revoked_certificates crl)
in
match reason entry with
| None -> true
| Some `Remove_from_CRL -> false
| Some _ -> true
with Not_found -> false
end
| Error _ -> false
else
false)
crls
let sign_tbs (tbs : tBS_CRL) key =
let tbs_raw = Asn.tbs_CRL_to_octets tbs in
match Algorithm.to_signature_algorithm tbs.signature with
| None -> Error (`Msg "couldn't parse signature algorithm")
| Some (_, hash) ->
let scheme = Key_type.x509_default_scheme (Private_key.key_type key) in
let* signature_val = Private_key.sign hash ~scheme key (`Message tbs_raw) in
let asn = { tbs_crl = tbs ; signature_algo = tbs.signature ; signature_val } in
let raw = Asn.crl_to_octets asn in
Ok { asn ; raw }
let revoke
?digest
~issuer
~this_update ?next_update
?(extensions = Extension.empty)
revoked_certs
key =
let digest = Signing_request.default_digest digest key in
let signature =
let scheme = Key_type.x509_default_scheme (Private_key.key_type key) in
Algorithm.of_signature_algorithm scheme digest
in
let tbs_crl = {
version = `V2 ;
signature ;
issuer ;
this_update ; next_update ;
revoked_certs ;
extensions
}
in
sign_tbs tbs_crl key
let revoke_certificates (revoked : revoked_cert list) ~this_update ?next_update ({ asn ; _ } as crl) key =
let tbs = asn.tbs_crl in
let count = match crl_number crl with None -> 0 | Some x -> succ x in
let extensions = Extension.(add CRL_number (false, count) tbs.extensions) in
let tbs = {
tbs with revoked_certs = tbs.revoked_certs @ revoked ;
this_update ; next_update ;
extensions
}
in
sign_tbs tbs key
let revoke_certificate revoked ~this_update ?next_update crl key =
revoke_certificates [revoked] ~this_update ?next_update crl key

255
unikernel/duniverse/ocaml-x509/lib/distinguished_name.ml Normal file
View file

@ -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

10
unikernel/duniverse/ocaml-x509/lib/dune Normal file
View file

@ -0,0 +1,10 @@
(library
(name x509)
(public_name x509)
(private_modules asn_grammars registry authenticator certificate validation
public_key private_key crl distinguished_name algorithm
extension pem signing_request general_name host rc2 p12
key_type)
(libraries asn1-combinators fmt ptime mirage-crypto mirage-crypto-pk
gmap domain-name base64 logs mirage-crypto-ec kdf.pbkdf
mirage-crypto-rng ipaddr ohex))

695
unikernel/duniverse/ocaml-x509/lib/extension.ml Normal file
View 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

170
unikernel/duniverse/ocaml-x509/lib/general_name.ml Normal file
View file

@ -0,0 +1,170 @@
type _ k =
| Other : Asn.oid -> string list k
| Rfc_822 : string list k
| DNS : string list k
| X400_address : unit k
| Directory : Distinguished_name.t list k
| EDI_party : (string option * string) list k
| URI : string list k
| IP : string list k
| Registered_id : Asn.oid list k
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
| Rfc_822, Rfc_822 -> Eq | Rfc_822, _ -> Lt | _, Rfc_822 -> Gt
| DNS, DNS -> Eq | DNS, _ -> Lt | _, DNS -> Gt
| X400_address, X400_address -> Eq | X400_address, _ -> Lt | _, X400_address -> Gt
| Directory, Directory -> Eq | Directory, _ -> Lt | _, Directory -> Gt
| EDI_party, EDI_party -> Eq | EDI_party, _ -> Lt | _, EDI_party -> Gt
| URI, URI -> Eq | URI, _ -> Lt | _, URI -> Gt
| IP, IP -> Eq | IP, _ -> Lt | _, IP -> Gt
| Registered_id, Registered_id -> Eq | Registered_id, _ -> Lt | _, Registered_id -> Gt
| Other a, Other b -> match Asn.OID.compare a b with
| 0 -> Eq
| x when x < 0 -> Lt
| _ -> Gt
end
include Gmap.Make(K)
let pp_k : type a. a k -> Format.formatter -> a -> unit = fun k ppf v ->
let pp_strs = Fmt.(list ~sep:(any "; ") string) in
match k, v with
| Rfc_822, x -> Fmt.pf ppf "rfc822 %a" pp_strs x
| DNS, x ->
Fmt.pf ppf "dns %a" Fmt.(list ~sep:(any "; ") string) x
| X400_address, () -> Fmt.string ppf "x400 address"
| Directory, x ->
Fmt.pf ppf "directory %a"
Fmt.(list ~sep:(any "; ") Distinguished_name.pp) x
| EDI_party, xs ->
Fmt.pf ppf "edi party %a"
Fmt.(list ~sep:(any "; ")
(pair ~sep:(any ", ")
(option ~none:(any "") string) string)) xs
| URI, x -> Fmt.pf ppf "uri %a" pp_strs x
| IP, x -> Fmt.pf ppf "ip %a" Fmt.(list ~sep:(any ";") (fmt "%S")) x
| Registered_id, x ->
Fmt.pf ppf "registered id %a"
Fmt.(list ~sep:(any ";") Asn.OID.pp) x
| Other oid, x -> Fmt.pf ppf "other %a: %a" Asn.OID.pp oid pp_strs x
let pp ppf m = iter (fun (B (k, v)) -> pp_k k ppf v ; Fmt.sp ppf ()) m
let merge_values : type a. a k -> a -> a -> a = fun k v v' ->
match k, v, v' with
| Other _, a, b -> a @ b
| Registered_id, a, b -> a @ b
| IP, a, b -> a @ b
| URI, a, b -> a @ b
| EDI_party, a, b -> a @ b
| Directory, a, b -> a @ b
| X400_address, (), () -> ()
| DNS, a, b -> a @ b
| Rfc_822, a, b -> a @ b
module Asn = struct
open Asn.S
(* GeneralName is also pretty pervasive. *)
(* OID x ANY. Hunt down the alternatives.... *)
(* XXX
* Cross-check. NSS seems to accept *all* oids here and just assumes UTF8.
* *)
let another_name =
let open Registry in
let f = function
| (oid, `C1 n) -> (oid, n)
| (oid, `C2 n) -> (oid, n)
| (oid, `C3 _) -> (oid, "")
and g = function
| (oid, "") -> (oid, `C3 ())
| (oid, n ) when Name_extn.is_utf8_id oid -> (oid, `C1 n)
| (oid, n ) -> (oid, `C2 n) in
map f g @@
sequence2
(required ~label:"type-id" oid)
(required ~label:"value" @@
explicit 0
(choice3 utf8_string ia5_string null))
and or_address = null (* Horrible crap, need to fill it. *)
let dir_name =
let f = function | `C1 s -> s | `C2 s -> s | `C3 s -> s
| `C4 s -> s | `C5 s -> s | `C6 s -> s
and g s = `C1 s
in
Asn.S.map f g Distinguished_name.Asn.directory_name
let edi_party_name =
sequence2
(optional ~label:"nameAssigner" @@ implicit 0 dir_name)
(required ~label:"partyName" @@ implicit 1 dir_name)
let general_name =
let f = function
| `C1 (`C1 (oid, x)) -> B (Other oid, [ x ])
| `C1 (`C2 x) -> B (Rfc_822, [ x ])
| `C1 (`C3 x) -> B (DNS, [ x ])
| `C1 (`C4 _x) -> B (X400_address, ())
| `C1 (`C5 x) -> B (Directory, [ x ])
| `C1 (`C6 x) -> B (EDI_party, [ x ])
| `C2 (`C1 x) -> B (URI, [ x ])
| `C2 (`C2 x) -> B (IP, [ x ])
| `C2 (`C3 x) -> B (Registered_id, [ x ])
and g (B (k, v)) = match k, v with
| Other oid, [ x ] -> `C1 (`C1 (oid, x))
| Rfc_822, [ x ] -> `C1 (`C2 x)
| DNS, [ x ] -> `C1 (`C3 x)
| X400_address, () -> `C1 (`C4 ())
| Directory, [ x ] -> `C1 (`C5 x)
| EDI_party, [ x ] -> `C1 (`C6 x)
| URI, [ x ] -> `C2 (`C1 x)
| IP, [ x ] -> `C2 (`C2 x)
| Registered_id, [ x ] -> `C2 (`C3 x)
| _ -> Asn.S.error (`Parse "bad general name")
in
map f g @@
choice2
(choice6
(implicit 0 another_name)
(implicit 1 ia5_string)
(implicit 2 ia5_string)
(implicit 3 or_address)
(* Everybody uses this as explicit, contrary to x509 (?) *)
(explicit 4 Distinguished_name.Asn.name)
(implicit 5 edi_party_name))
(choice3
(implicit 6 ia5_string)
(implicit 7 octet_string)
(implicit 8 oid))
let gen_names =
let f exts =
List.fold_left (fun map (B (k, v)) ->
match find k map with
| None -> add k v map
| Some b -> add k (merge_values k b v) map)
empty exts
and g map =
List.flatten (List.map (fun (B (k, v)) ->
match k, v with
| Other oid, xs -> List.map (fun d -> B (Other oid, [ d ])) xs
| Registered_id, xs -> List.map (fun d -> B (Registered_id, [ d ])) xs
| IP, xs -> List.map (fun d -> B (IP, [ d ])) xs
| URI, xs -> List.map (fun d -> B (URI, [ d ])) xs
| EDI_party, xs -> List.map (fun d -> B (EDI_party, [ d ])) xs
| Directory, xs -> List.map (fun d -> B (Directory, [ d ])) xs
| X400_address, () -> [ B (X400_address, ()) ]
| DNS, xs -> List.map (fun d -> B (DNS, [ d ])) xs
| Rfc_822, xs -> List.map (fun d -> B (Rfc_822, [ d ])) xs)
(bindings map))
in
map f g @@ sequence_of general_name
end

40
unikernel/duniverse/ocaml-x509/lib/host.ml Normal file
View file

@ -0,0 +1,40 @@
type t = [ `Strict | `Wildcard ] * [ `host ] Domain_name.t
let pp_typ ppf = function
| `Strict -> Fmt.nop ppf ()
| `Wildcard -> Fmt.string ppf "*."
let pp ppf (typ, nam) =
Fmt.pf ppf "%a%a" pp_typ typ Domain_name.pp nam
module Set = struct
include Set.Make(struct
type nonrec t = t
let compare a b = match a, b with
| (`Strict, a), (`Strict, b)
| (`Wildcard, a), (`Wildcard, b) -> Domain_name.compare a b
| (`Strict, _), (`Wildcard, _) -> -1
| (`Wildcard, _), (`Strict, _) -> 1
end)
let pp ppf s =
Fmt.(list ~sep:(any ", ") pp) ppf (elements s)
end
let is_wildcard name =
match Domain_name.get_label name 0 with
| Ok "*" -> Some (Domain_name.drop_label_exn name)
| _ -> None
let host name =
match Domain_name.of_string name with
| Error _ -> None
| Ok dn ->
let wild, name = match is_wildcard dn with
| None -> `Strict, dn
| Some dn' -> `Wildcard, dn'
in
match Domain_name.host name with
| Error _ -> None
| Ok hostname -> Some (wild, hostname)

47
unikernel/duniverse/ocaml-x509/lib/key_type.ml Normal file
View file

@ -0,0 +1,47 @@
type t = [ `RSA | `ED25519 | `P256 | `P384 | `P521 ]
let strings =
[ ("rsa", `RSA) ; ("ed25519", `ED25519) ;
("p256", `P256) ; ("p384", `P384) ; ("p521", `P521) ]
let to_string kt = fst (List.find (fun (_, k) -> kt = k) strings)
let of_string s =
match List.assoc_opt (String.lowercase_ascii s) strings with
| Some kt -> Ok kt
| None ->
Error (`Msg (Fmt.str "unkown key type %s, supported are %a"
s Fmt.(list ~sep:(any ", ") string) (List.map fst strings)))
let pp ppf t = Fmt.string ppf (to_string t)
type signature_scheme = [ `RSA_PSS | `RSA_PKCS1 | `ECDSA | `ED25519 ]
let signature_scheme_to_string = function
| `RSA_PSS -> "RSA-PSS"
| `RSA_PKCS1 -> "RSA-PKCS1"
| `ECDSA -> "ECDSA"
| `ED25519 -> "ED25519"
let pp_signature_scheme ppf s = Fmt.string ppf (signature_scheme_to_string s)
let supports_signature_scheme key_typ scheme =
match key_typ, scheme with
| `RSA, (`RSA_PSS | `RSA_PKCS1) -> true
| `ED25519, `ED25519 -> true
| (`P256 | `P384 | `P521), `ECDSA -> true
| _ -> false
let opt_signature_scheme ?scheme kt =
match scheme with
| Some x -> x
| None -> match kt with
| `RSA -> `RSA_PSS
| `ED25519 -> `ED25519
| `P256 | `P384 | `P521 -> `ECDSA
(* the default of RSA keys should be PSS, but most deployed certificates still
use PKCS1 (and this library uses pkcs1 by default as well) *)
let x509_default_scheme = function
| `RSA -> `RSA_PKCS1
| x -> opt_signature_scheme x

704
unikernel/duniverse/ocaml-x509/lib/ocsp.ml Normal file
View file

@ -0,0 +1,704 @@
(* https://tools.ietf.org/html/rfc6960 *)
let version_v1 = 0
(*
CertID ::= SEQUENCE {
hashAlgorithm AlgorithmIdentifier,
issuerNameHash OCTET STRING, -- Hash of issuer's DN
issuerKeyHash OCTET STRING, -- Hash of issuer's public key
serialNumber CertificateSerialNumber }
*)
type cert_id = {
hashAlgorithm: Algorithm.t;
issuerNameHash: string;
issuerKeyHash: string;
serialNumber: string;
}
let create_cert_id ?(hash=`SHA1) issuer serialNumber =
let hashAlgorithm = Algorithm.of_hash hash in
let module Hash = (val (Digestif.module_of_hash' (hash :> Digestif.hash'))) in
let issuerNameHash =
Certificate.subject issuer
|> Distinguished_name.encode_der
|> Hash.(fun x -> to_raw_string (digest_string x))
in
let issuerKeyHash =
Public_key.fingerprint ~hash (Certificate.public_key issuer)
in
{hashAlgorithm;issuerNameHash;issuerKeyHash;serialNumber}
let cert_id_serial {serialNumber;_} = serialNumber
let pp_cert_id ppf {hashAlgorithm;issuerNameHash;issuerKeyHash;serialNumber} =
Fmt.pf ppf "CertID @[<1>{@ algo=%a;@ issuerNameHash=%a;@ issuerKeyHash=%a;@ serialNumber=%a@ }@]"
Algorithm.pp hashAlgorithm
Ohex.pp issuerNameHash
Ohex.pp issuerKeyHash
Ohex.pp serialNumber
module Asn_common = struct
open Asn.S
let cert_id =
let f (hashAlgorithm, issuerNameHash, issuerKeyHash, serialNumber) =
{hashAlgorithm; issuerNameHash; issuerKeyHash; serialNumber;}
in
let g {hashAlgorithm;issuerNameHash;issuerKeyHash;serialNumber;} =
(hashAlgorithm, issuerNameHash, issuerKeyHash, serialNumber)
in
map f g @@
sequence4
(required ~label:"hashAlgorithm" Algorithm.identifier)
(required ~label:"issuerNameHash" octet_string)
(required ~label:"issuerKeyHash" octet_string)
(required ~label:"serialNumber" Asn_grammars.serial)
end
let ( let* ) = Result.bind
module Request = struct
(*
Request ::= SEQUENCE {
reqCert CertID,
singleRequestExtensions [0] EXPLICIT Extensions OPTIONAL }
*)
type request = {
reqCert: cert_id;
singleRequestExtensions: Extension.t option;
}
let create_request ?singleRequestExtensions reqCert =
{reqCert;singleRequestExtensions}
let pp_request ppf {reqCert;singleRequestExtensions;} =
Fmt.pf ppf "Request @[<1>{@ reqCert=%a;@ singleRequestExtensions=%a;@ }@]"
pp_cert_id reqCert
(Fmt.option ~none:(Fmt.any "None") Extension.pp) singleRequestExtensions
(*
TBSRequest ::= SEQUENCE {
version [0] EXPLICIT Version DEFAULT v1,
requestorName [1] EXPLICIT GeneralName OPTIONAL,
requestList SEQUENCE OF Request,
requestExtensions [2] EXPLICIT Extensions OPTIONAL }
*)
type tbs_request = {
requestorName: General_name.b option;
requestList: request list;
requestExtensions: Extension.t option;
}
let create_tbs_request ?requestorName ?requestExtensions requests =
{ requestorName ; requestList=requests ; requestExtensions }
let pp_tbs_request ppf { requestorName ; requestList ; requestExtensions } =
let pp_general_name ppf x =
let open General_name in
match x with
| B (k, v) -> General_name.pp_k k ppf v
in
Fmt.pf ppf "TBSRequest @[<1>{@ requestorName=%a;@ requestList=[@ %a@ ];@ requestExtensions=%a@ }@]"
(Fmt.option ~none:(Fmt.any "None") pp_general_name) requestorName
(Fmt.list ~sep:Fmt.semi pp_request) requestList
(Fmt.option ~none:(Fmt.any "None") Extension.pp) requestExtensions
(*
Signature ::= SEQUENCE {
signatureAlgorithm AlgorithmIdentifier,
signature BIT STRING,
certs [0] EXPLICIT SEQUENCE OF Certificate
OPTIONAL}
*)
type signature = {
signatureAlgorithm: Algorithm.t;
signature: string;
certs: Certificate.t list option;
}
let pp_signature ppf {signatureAlgorithm;signature;certs;} =
Fmt.pf ppf "Signature @[<1>{@ signatureAlgorithm=%a;@ signature=%a;@ certs=%a}@]"
Algorithm.pp signatureAlgorithm
Ohex.pp signature
(Fmt.option ~none:(Fmt.any "None") @@
Fmt.brackets @@
Fmt.list ~sep:Fmt.semi Certificate.pp) certs
(*
OCSPRequest ::= SEQUENCE {
tbsRequest TBSRequest,
optionalSignature [0] EXPLICIT Signature OPTIONAL }
*)
type req = {
tbsRequest: tbs_request;
optionalSignature: signature option;
}
type t = {
raw : string ;
asn : req ;
}
let pp ppf { asn = { tbsRequest ; optionalSignature } ; _ } =
Fmt.pf ppf "OCSPRequest @[<1>{@ tbsRequest=%a;@ optionalSignature=%a@ }@]"
pp_tbs_request tbsRequest
(Fmt.option ~none:(Fmt.any "None") pp_signature) optionalSignature
let cert_ids { asn = { tbsRequest = { requestList ; _ } ; _ } ; _ } =
let cert_ids = List.map (fun {reqCert;_} -> reqCert) requestList in
cert_ids
let requestor_name { asn = { tbsRequest = { requestorName ; _ } ; _ } ; _ } =
requestorName
module Asn_ = Asn
module Asn = struct
open Asn_grammars
open Asn.S
let request =
let f (reqCert, singleRequestExtensions) =
{reqCert; singleRequestExtensions}
in
let g {reqCert; singleRequestExtensions} =
(reqCert, singleRequestExtensions)
in
map f g @@
sequence2
(required ~label:"reqCert" Asn_common.cert_id)
(optional ~label:"singleRequestExtensions" @@ explicit 0
Extension.Asn.extensions_der)
let tbs_request =
let f (version, requestorName, requestList, requestExtensions) =
match version with
| Some v when v <> version_v1 ->
Asn.S.parse_error "unsupported version %d" v
| _ ->
{ requestorName ; requestList ; requestExtensions }
in
let g { requestorName ; requestList ; requestExtensions } =
(None, requestorName, requestList, requestExtensions)
in
map f g @@
sequence4
(optional ~label:"version" @@ explicit 0 int)
(optional ~label:"requestorName" @@
explicit 1 General_name.Asn.general_name)
(required ~label:"requestList" @@ sequence_of request)
(optional ~label:"requestExtensions" @@ Extension.Asn.extensions_der)
let tbs_request_of_str,tbs_request_to_str =
projections_of Asn.der tbs_request
let signature =
let f (signatureAlgorithm,signature,certs) =
let certs = match certs with
| None -> None
| Some certs ->
let encode cert =
let raw = Certificate.Asn.certificate_to_octets cert in
Certificate.{raw; asn=cert}
in
Some (List.map encode certs)
in
{signatureAlgorithm;signature;certs}
in
let g {signatureAlgorithm;signature;certs} =
let certs = match certs with
| None -> None
| Some certs ->
Some (List.map (fun Certificate.{asn;_} -> asn) certs)
in
(signatureAlgorithm,signature,certs)
in
map f g @@
sequence3
(required ~label:"signatureAlgorithm" Algorithm.identifier)
(required ~label:"signature" bit_string_octets)
(optional ~label:"certs" @@ explicit 0 @@
sequence_of Certificate.Asn.certificate)
let ocsp_request =
let f (tbsRequest,optionalSignature) =
{tbsRequest;optionalSignature;}
in
let g {tbsRequest;optionalSignature;} =
(tbsRequest,optionalSignature)
in
map f g @@
sequence2
(required ~label:"tbsRequest" tbs_request)
(optional ~label:"optionalSignature" signature)
let (ocsp_request_of_octets, ocsp_request_to_octets) =
projections_of Asn.der ocsp_request
end
let decode_der raw =
let* asn = Asn.ocsp_request_of_octets raw in
Ok { asn ; raw }
let encode_der { raw ; _ } = raw
let create ?certs ?digest ?requestor_name:requestorName ?key cert_ids =
let requestList = List.map create_request cert_ids in
let tbsRequest = {
requestorName;
requestList;
requestExtensions=None;
}
in
let* optionalSignature =
match key with
| None -> Ok None
| Some key ->
let digest = Signing_request.default_digest digest key in
let scheme = Key_type.x509_default_scheme (Private_key.key_type key) in
let signatureAlgorithm = Algorithm.of_signature_algorithm scheme digest in
let tbs_der = Asn.tbs_request_to_str tbsRequest in
let* signature = Private_key.sign digest ~scheme key (`Message tbs_der) in
Ok (Some { signature ; signatureAlgorithm ; certs; })
in
let asn = { tbsRequest ; optionalSignature } in
let raw = Asn.ocsp_request_to_octets asn in
Ok { raw ; asn }
let validate { asn ; raw } ?(allowed_hashes = Validation.sha2) pub =
match asn.optionalSignature with
| None -> Error `No_signature
| Some sign ->
let tbs_raw = Validation.raw_cert_hack raw in
let dn =
let cn = "OCSP" in
[ Distinguished_name.(Relative_distinguished_name.singleton (CN cn)) ]
in
Validation.validate_raw_signature dn allowed_hashes tbs_raw
sign.signatureAlgorithm sign.signature pub
end
module Response = struct
(* OCSPResponseStatus ::= ENUMERATED {
* successful (0), -- Response has valid confirmations
* malformedRequest (1), -- Illegal confirmation request
* internalError (2), -- Internal error in issuer
* tryLater (3), -- Try again later
* -- (4) is not used
* sigRequired (5), -- Must sign the request
* unauthorized (6) -- Request unauthorized
* } *)
type status = [
| `Successful
| `MalformedRequest
| `InternalError
| `TryLater
| `SigRequired
| `Unauthorized
]
let status_to_int = function
| `Successful -> 0
| `MalformedRequest -> 1
| `InternalError -> 2
| `TryLater -> 3
| `SigRequired -> 5
| `Unauthorized -> 6
let status_of_int = function
| 0 -> `Successful
| 1 -> `MalformedRequest
| 2 -> `InternalError
| 3 -> `TryLater
| 5 -> `SigRequired
| 6 -> `Unauthorized
| x -> Asn.S.parse_error "Unknown status %d" x
let pp_status ppf = function
| `Successful -> Fmt.string ppf "Successful"
| `MalformedRequest -> Fmt.string ppf "MalformedRequest"
| `InternalError -> Fmt.string ppf "InternalError"
| `TryLater -> Fmt.string ppf "TryLater"
| `SigRequired -> Fmt.string ppf "SigRequired"
| `Unauthorized -> Fmt.string ppf "Unauthorized"
(* RevokedInfo ::= SEQUENCE {
* revocationTime GeneralizedTime,
* revocationReason [0] EXPLICIT CRLReason OPTIONAL } *)
type revoked_info = Ptime.t * Extension.reason option
let pp_revoked_info ppf (revocationTime,revocationReason) =
Fmt.pf ppf "RevokedInfo @[<1>{@ revocationTime=%a;@ revocationReason=%a;@ }@]"
Ptime.pp revocationTime
(Fmt.option ~none:(Fmt.any "None") @@ Extension.pp_reason)
revocationReason
(* CertStatus ::= CHOICE {
* good [0] IMPLICIT NULL,
* revoked [1] IMPLICIT RevokedInfo,
* unknown [2] IMPLICIT UnknownInfo } *)
type cert_status = [
| `Good
| `Revoked of revoked_info
| `Unknown
]
let pp_cert_status ppf = function
| `Good -> Fmt.pf ppf "Good"
| `Revoked info -> Fmt.pf ppf "Revoked of %a" pp_revoked_info info
| `Unknown -> Fmt.pf ppf "Unknown"
(* SingleResponse ::= SEQUENCE {
* certID CertID,
* certStatus CertStatus,
* thisUpdate GeneralizedTime,
* nextUpdate [0] EXPLICIT GeneralizedTime OPTIONAL,
* singleExtensions [1] EXPLICIT Extensions OPTIONAL } *)
type single_response = {
certID: cert_id;
certStatus: cert_status;
thisUpdate: Ptime.t;
nextUpdate: Ptime.t option;
singleExtensions: Extension.t option;
}
let create_single_response ?next_update:nextUpdate
?single_extensions:singleExtensions
certID certStatus thisUpdate =
{certID;certStatus;thisUpdate;nextUpdate;singleExtensions;}
let pp_single_response ppf {certID;certStatus;thisUpdate;nextUpdate;singleExtensions;} =
Fmt.pf ppf "SingleResponse @[<1>{@ certID=%a;@ certStatus=%a;@ thisUpdate=%a;@ nextUpdate=%a;@ singleExtensions=%a;@ }@]"
pp_cert_id certID
pp_cert_status certStatus
Ptime.pp thisUpdate
(Fmt.option ~none:(Fmt.any "None") @@ Ptime.pp) nextUpdate
(Fmt.option ~none:(Fmt.any "None") @@ Extension.pp) singleExtensions
let single_response_cert_id {certID;_} = certID
let single_response_status {certStatus;_} = certStatus
(* ResponderID ::= CHOICE {
* byName [1] Name,
* byKey [2] KeyHash }
* KeyHash ::= OCTET STRING -- SHA-1 hash of responder's public key
(excluding the tag and length fields)
*)
type responder_id = [
| `ByName of Distinguished_name.t
| `ByKey of string
]
let create_responder_id pubkey =
let pubkey_fp = Public_key.fingerprint ~hash:`SHA1 pubkey in
`ByKey pubkey_fp
let pp_responder_id ppf = function
| `ByName dn -> Fmt.pf ppf "ByName %a" Distinguished_name.pp dn
| `ByKey hash -> Fmt.pf ppf "ByKey %a" Ohex.pp hash
(* ResponseData ::= SEQUENCE {
* version [0] EXPLICIT Version DEFAULT v1,
* responderID ResponderID,
* producedAt GeneralizedTime,
* responses SEQUENCE OF SingleResponse,
* responseExtensions [1] EXPLICIT Extensions OPTIONAL } *)
type response_data = {
responderID: responder_id;
producedAt: Ptime.t;
responses: single_response list;
responseExtensions: Extension.t option;
}
let pp_response_data ppf { responderID ; producedAt ; responses ; responseExtensions } =
Fmt.pf ppf "ResponseData @[<1>{@ responderID=%a;@ producedAt=%a;@ responses=%a;@ responseExtensions=%a@ }@]"
pp_responder_id responderID
Ptime.pp producedAt
(Fmt.list ~sep:Fmt.semi @@ pp_single_response) responses
(Fmt.option ~none:(Fmt.any "None") @@ Extension.pp) responseExtensions
(* BasicOCSPResponse ::= SEQUENCE {
* tbsResponseData ResponseData,
* signatureAlgorithm AlgorithmIdentifier,
* signature BIT STRING,
* certs [0] EXPLICIT SEQUENCE OF Certificate OPTIONAL } *)
type basic_ocsp_response = {
tbsResponseData: response_data;
signatureAlgorithm: Algorithm.t;
signature: string;
certs: Certificate.t list option;
}
let pp_basic_ocsp_response ppf {tbsResponseData;signatureAlgorithm;signature;certs;} =
Fmt.pf ppf "BasicOCSPResponse @[<1>{@ tbsResponseData=%a;@ signatureAlgorithm=%a;@ signature=%a;@ certs=%a@ }@]"
pp_response_data tbsResponseData
Algorithm.pp signatureAlgorithm
Ohex.pp signature
(Fmt.option ~none:(Fmt.any "None") @@
Fmt.list ~sep:Fmt.semi @@ Certificate.pp) certs
(* ResponseBytes ::= SEQUENCE {
* responseType OBJECT IDENTIFIER,
* response OCTET STRING } *)
(* OCSPResponse ::= SEQUENCE {
* responseStatus OCSPResponseStatus,
* responseBytes [0] EXPLICIT ResponseBytes OPTIONAL } *)
type t = {
responseStatus: status;
responseBytes: (Asn.oid * basic_ocsp_response * string) option;
}
let pp ppf {responseStatus;responseBytes;} =
Fmt.pf ppf "OCSPResponse @[<1>{@ responseStatus=%a;@ responseBytes=%a@ }@]"
pp_status responseStatus
(Fmt.option ~none:(Fmt.any "None") @@
Fmt.pair ~sep:Fmt.comma Asn.OID.pp pp_basic_ocsp_response)
(match responseBytes with None -> None | Some (a, b, _) -> Some (a, b))
let status {responseStatus;_} = responseStatus
let responder_id = function
| {responseBytes=Some (_, {tbsResponseData={responderID;_};_}, _);_} ->
Ok responderID
| _ -> Error (`Msg "this response has no responseBytes")
let responses = function
| {responseBytes=Some (_, {tbsResponseData={responses;_};_}, _);_} ->
Ok responses
| _ -> Error (`Msg "this response has no responseBytes")
module Asn = struct
open Asn_grammars
open Asn.S
open Registry
let status : status Asn.t =
enumerated status_of_int status_to_int
let revoked_info =
sequence2
(required ~label:"revocationTime" generalized_time_no_frac_s)
(optional ~label:"revocationReason" @@ explicit 0 @@
Extension.Asn.reason_enumerated)
let cert_status : cert_status Asn.t =
let f = function
| `C1 () -> `Good
| `C2 ri -> `Revoked ri
| `C3 () -> `Unknown
in
let g = function
| `Good -> `C1 ()
| `Revoked ri -> `C2 ri
| `Unknown -> `C3 ()
in
map f g @@
choice3
(implicit 0 @@ null)
(implicit 1 @@ revoked_info)
(implicit 2 @@ null)
let single_response =
let f (certID,certStatus,thisUpdate,nextUpdate,singleExtensions) =
{certID;certStatus;thisUpdate;nextUpdate;singleExtensions;}
in
let g {certID;certStatus;thisUpdate;nextUpdate;singleExtensions;} =
(certID,certStatus,thisUpdate,nextUpdate,singleExtensions)
in
map f g @@
sequence5
(required ~label:"certID" @@ Asn_common.cert_id)
(required ~label:"certStatus" @@ cert_status)
(required ~label:"thisUpdate" @@ generalized_time_no_frac_s)
(optional ~label:"nextUpdate" @@ explicit 0 @@
generalized_time_no_frac_s)
(optional ~label:"singleExtensions" @@ explicit 1 @@
Extension.Asn.extensions_der)
let responder_id : responder_id Asn.t =
let f = function
| `C1 dn -> `ByName dn
| `C2 hash -> `ByKey hash
in
let g = function
| `ByName dn -> `C1 dn
| `ByKey hash -> `C2 hash
in
map f g @@
choice2 (explicit 1 Distinguished_name.Asn.name) (explicit 2 octet_string)
let response_data =
let f (version, responderID, producedAt, responses, responseExtensions) =
match version with
| Some v when v <> version_v1 ->
Asn.S.parse_error "unsupported version %d" v
| _ -> { responderID ; producedAt ; responses ; responseExtensions }
in
let g { responderID ; producedAt ; responses ; responseExtensions } =
(None, responderID, producedAt, responses, responseExtensions)
in
map f g @@
sequence5
(optional ~label:"version" @@ explicit 0 @@ int)
(required ~label:"responderID" responder_id)
(required ~label:"producedAt" generalized_time_no_frac_s)
(required ~label:"responses" @@ sequence_of single_response)
(optional ~label:"responseExtensions" @@ explicit 1 @@
Extension.Asn.extensions_der)
let response_data_of_str, response_data_to_str =
projections_of Asn.der response_data
let basic_ocsp_response =
let f (tbsResponseData,signatureAlgorithm,signature,certs) =
let certs = match certs with
| None -> None
| Some certs ->
let encode cert =
let raw = Certificate.Asn.certificate_to_octets cert in
Certificate.{raw; asn=cert}
in
Some (List.map encode certs)
in
{tbsResponseData;signatureAlgorithm;signature;certs}
in
let g {tbsResponseData;signatureAlgorithm;signature;certs} =
let certs = match certs with
| None -> None
| Some certs ->
Some (List.map (fun Certificate.{asn;_} -> asn) certs)
in
(tbsResponseData,signatureAlgorithm,signature,certs)
in
map f g @@
sequence4
(required ~label:"tbsResponseData" response_data)
(required ~label:"signatureAlgorithm" Algorithm.identifier)
(required ~label:"signature" bit_string_octets)
(optional ~label:"certs" @@ explicit 0 @@
sequence_of Certificate.Asn.certificate)
let basic_ocsp_response_of_str,basic_ocsp_response_to_str =
projections_of Asn.der basic_ocsp_response
let ocsp_basic_oid = Cert_extn.Private_internet_extensions.ad_ocsp_basic
let ocsp_response =
let f = function
| `Successful, None ->
parse_error "Successful status requires responseBytes"
| `Successful, Some (oid, response) ->
if Asn.OID.equal ocsp_basic_oid oid then
match basic_ocsp_response_of_str response with
| Error e -> error e
| Ok basic_response ->
{responseStatus=`Successful;
responseBytes=Some (oid, basic_response, response)}
else
parse_error "expected OID ad_ocsp_basic"
| (`InternalError
| `MalformedRequest
| `SigRequired
| `TryLater
|`Unauthorized) as s, None ->
{responseStatus=s;responseBytes=None}
| _, Some _ -> parse_error "Only Successful status supports non empty responseBytes"
in
let g {responseStatus;responseBytes} =
let responseBytes = match responseBytes with
| Some (oid, _basic_response, response) -> Some (oid, response)
| None -> None
in
(responseStatus,responseBytes)
in
map f g @@
sequence2
(required ~label:"responseStatus" status)
(optional ~label:"responseBytes" @@ explicit 0 @@
sequence2
(required ~label:"responseType" oid)
(required ~label:"response" octet_string))
let ocsp_response_of_str, ocsp_response_to_str =
projections_of Asn.der ocsp_response
end
let decode_der = Asn.ocsp_response_of_str
let encode_der = Asn.ocsp_response_to_str
let create_basic_ocsp_response ?digest ?certs
?response_extensions:responseExtensions key responderID producedAt
responses =
let digest = Signing_request.default_digest digest key in
let scheme = Key_type.x509_default_scheme (Private_key.key_type key) in
let signatureAlgorithm = Algorithm.of_signature_algorithm scheme digest in
let tbsResponseData = {
responderID;
producedAt;
responses;
responseExtensions;
} in
let resp_der = Asn.response_data_to_str tbsResponseData in
let* signature = Private_key.sign digest ~scheme key (`Message resp_der) in
Ok { tbsResponseData ; signatureAlgorithm ; signature;certs }
let create_success ?digest ?certs ?response_extensions
private_key responderID producedAt responses =
let* response =
create_basic_ocsp_response
?digest ?certs ?response_extensions private_key
responderID producedAt responses
in
let raw_resp = Asn.basic_ocsp_response_to_str response in
let responseBytes = Some (Asn.ocsp_basic_oid, response, raw_resp) in
Ok { responseStatus = `Successful ; responseBytes }
let create status =
let status = match status with
| `MalformedRequest -> `MalformedRequest
| `InternalError -> `InternalError
| `TryLater -> `TryLater
| `SigRequired -> `SigRequired
| `Unauthorized -> `Unauthorized
in
{responseStatus=status;responseBytes=None}
let validate t ?(allowed_hashes = Validation.sha2) ?now pub =
match t.responseBytes with
| None -> Error `No_signature
| Some (_oid, response, raw_resp) ->
let resp_der = Validation.raw_cert_hack raw_resp in
let dn =
let cn = "OCSP" in
[ Distinguished_name.(Relative_distinguished_name.singleton (CN cn)) ]
in
let* () =
Validation.validate_raw_signature dn allowed_hashes resp_der
response.signatureAlgorithm response.signature pub
in
match now with
| None -> Ok ()
| Some now ->
if
List.for_all (fun single_resp ->
Ptime.is_later ~than:single_resp.thisUpdate now &&
match single_resp.nextUpdate with
| None -> true
| Some until -> Ptime.is_earlier ~than:until now)
response.tbsResponseData.responses
then
Ok ()
else
Error `Time_invalid
end

468
unikernel/duniverse/ocaml-x509/lib/p12.ml Normal file
View file

@ -0,0 +1,468 @@
(* partial PKCS12 implementation, as defined in RFC 7292
- no public/private key mode, only password privacy and integrity
- algorithmidentifier those I need for openssl interop (looking at the p12 I have on my disk)
- require version being 3
some definitions from PKCS7 (RFC 2315) are implemented as well, as needed
*)
type content_info = Asn.oid * string
type digest_info = Algorithm.t * string
type mac_data = digest_info * string * int
type t = string * mac_data
module Asn = struct
open Asn_grammars
open Asn.S
open Registry
let encrypted_content_info =
let f (oid, algo, content) =
if Asn.OID.equal PKCS7.data oid then
(algo, content)
else
parse_error "expected OID PKCS7 data"
and g (algo, content) =
(PKCS7.data, algo, content)
in
Asn.S.map f g @@
sequence3
(required ~label:"content type" oid) (* here we assume data!? *)
(required ~label:"content encryption algorithm" Algorithm.identifier)
(optional ~label:"encrypted content" (implicit 0 octet_string))
let encrypted_data =
let f (v, eci) =
if v = 0 then eci else parse_error "unknown encrypted data version"
and g eci = 0, eci
in
map f g @@
sequence2
(required ~label:"version" int)
(required ~label:"encrypted content info" encrypted_content_info)
let content_info =
let f (oid, data) =
match data with
| None -> parse_error "found no value for content info"
| Some `C1 data when Asn.OID.equal PKCS7.data oid -> `Data data
| Some `C2 eci when Asn.OID.equal PKCS7.encrypted_data oid -> `Encrypted eci
| _ -> parse_error "couldn't match PKCS7 oid with choice"
and g = function
| `Data data -> PKCS7.data, Some (`C1 data)
| `Encrypted eci -> PKCS7.encrypted_data, Some (`C2 eci)
in
map f g @@
sequence2
(required ~label:"content type" oid)
(optional ~label:"content" (explicit 0
(choice2 octet_string encrypted_data)))
let digest_info =
sequence2
(required ~label:"digest algorithm" Algorithm.identifier)
(required ~label:"digest" octet_string)
let mac_data =
sequence3
(required ~label:"mac" digest_info)
(required ~label:"mac salt" octet_string)
(required ~label:"iterations" int)
let pfx =
let f (version, content_info, mac_data) =
if version = 3 then
match content_info, mac_data with
| `Data data, Some md -> data, md
| _, None -> parse_error "missing mac_data"
| _, _ -> parse_error "unsupported content_info"
else
parse_error "unsupported pfx version"
and g (content, mac_data) =
(3, `Data content, Some mac_data)
in
map f g @@
sequence3
(required ~label:"version" int)
(required ~label:"auth safe" content_info)
(* contentType is signedData in public-key integrity mode and data in
password integrity mode *)
(optional ~label:"mac data" mac_data) (* not present if public keys used *)
let pfx_of_cs, pfx_to_cs = projections_of Asn.der pfx
(* payload is a sequence of content_info *)
let authenticated_safe = sequence_of content_info
let auth_safe_of_cs, auth_safe_to_cs =
projections_of Asn.der authenticated_safe
let pkcs12_attribute =
sequence2
(required ~label:"attribute id" oid)
(required ~label:"attribute value" (set_of octet_string))
(* here:
key_bag = PKCS8 private key
pkcs8_shrouded_key_bag = encrypted private key info ==
sequence2 Algorithm octet_string
cert_bag =
sequence2
cert_id (PKCS9 cert_types <| 1 (X509) or 2 (SDSI))
expl 0 cert_value (DER-encoded certificate)
crl_bag = sequence2 crl_id (PKCS9 crl_types <| 1) (expl 0 crl (DER-encoded))
^^^---^^^ those we plan to support
secret_bag = sequence2 secret_type (expl 0 secret_value)
safe_contents_bag = (any of the above) safe_contents (recursive!)
*)
(* since asn1 does not yet support ANY defined BY, we develop a rather
complex grammar covering all supported bags *)
let safe_bag =
let cert_oid, crl_oid =
Asn.OID.(PKCS9.cert_types <| 1, PKCS9.crl_types <| 1)
in
let f (oid, (a, algo, data), attrs) =
match a, algo, data with
| `C1 v, Some a, `C1 data when Asn.OID.equal oid PKCS12.key_bag ->
let key = Private_key.Asn.reparse_private (v, a, data) in
`Private_key key, attrs
| `C2 id, None, `C2 data ->
if Asn.OID.equal oid PKCS12.cert_bag && Asn.OID.equal id cert_oid then
match Certificate.decode_der data with
| Error (`Msg e) -> error (`Parse e)
| Ok cert -> `Certificate cert, attrs
else if Asn.OID.equal oid PKCS12.crl_bag && Asn.OID.equal id crl_oid then
match Crl.decode_der data with
| Error (`Msg e) -> error (`Parse e)
| Ok crl -> `Crl crl, attrs
else
parse_error "crl bag with non-standard crl"
| `C3 algo, None, `C1 data when Asn.OID.equal oid PKCS12.pkcs8_shrouded_key_bag ->
`Encrypted_private_key (algo, data), attrs
| _ -> parse_error "safe bag OID not supported"
and g (v, attrs) =
let oid, d = match v with
| `Encrypted_private_key (algo, data) ->
PKCS12.pkcs8_shrouded_key_bag, (`C3 algo, None, `C1 data)
| `Private_key pk ->
let v, algo, data = Private_key.Asn.unparse_private pk in
PKCS12.key_bag, (`C1 v, Some algo, `C1 data)
| `Certificate cert -> PKCS12.cert_bag, (`C2 cert_oid, None, `C2 (Certificate.encode_der cert))
| `Crl crl -> PKCS12.crl_bag, (`C2 crl_oid, None, `C2 (Crl.encode_der crl))
in
(oid, d, attrs)
in
map f g @@
sequence3
(required ~label:"bag id" oid)
(required ~label:"bag value"
(explicit 0
(sequence3
(required ~label:"fst" (choice3 int oid Algorithm.identifier))
(optional ~label:"algorithm" Algorithm.identifier)
(required ~label:"data" (choice2 octet_string (explicit 0 octet_string))))))
(* (explicit 0 (* encrypted private key *)
(sequence2
(required ~label:"encryption algorithm" Algorithm.identifier)
(required ~label:"encrypted data" octet_string))) *)
(* (explicit 0 (* private key ] *)
(sequence3
(required ~label:"version" int)
(required ~label:"privateKeyAlgorithm" Algorithm.identifier)
(required ~label:"privateKey" octet_string))) *)
(* (explicit 0 (* cert / crl *)
(sequence2
(required ~label:"oid" oid)
(required ~label:"data" (explicit 0 octet_string)))) *)
(optional ~label:"bag attributes" (set_of pkcs12_attribute))
let safe_contents = sequence_of safe_bag
let safe_contents_of_cs, safe_contents_to_cs =
projections_of Asn.der safe_contents
end
let prepare_pw str =
let l = String.length str in
let cs = Bytes.make ((succ l) * 2) '\000' in
for i = 0 to pred l do
Bytes.set cs (succ (i * 2)) (String.get str i)
done;
Bytes.unsafe_to_string cs
let id len purpose =
let id = match purpose with
| `Encryption -> 1
| `Iv -> 2
| `Hmac -> 3
in
String.make len (Char.unsafe_chr id)
let v = function
| `MD5 | `SHA1 | `SHA224 | `SHA256 -> 512 / 8
| `SHA384 | `SHA512 -> 1024 / 8
let fill ~data ~out =
let len = Bytes.length out
and l = String.length data
in
let rec c off =
if off < len then begin
Bytes.blit_string data 0 out off (min (len - off) l);
c (off + l)
end
in
c 0
let fill_or_empty size data =
let l = String.length data in
if l = 0 then data
else
let len = size * ((l + size - 1) / size) in
let buf = Bytes.make len '\000' in
fill ~data ~out:buf;
Bytes.unsafe_to_string buf
let pbes algorithm purpose password salt iterations n =
let module Hash = (val (Digestif.module_of_hash' (algorithm :> Digestif.hash'))) in
let pw = prepare_pw password
and v = v algorithm
and u = Hash.digest_size
in
let diversifier = id v purpose in
let salt = fill_or_empty v salt in
let pass = fill_or_empty v pw in
let out = Bytes.make n '\000' in
let rec one off i =
let ai = ref Hash.(to_raw_string (digest_string (diversifier ^ i))) in
for _j = 1 to pred iterations do
ai := Hash.(to_raw_string (digest_string !ai));
done;
Bytes.blit_string !ai 0 out off (min (n - off) u);
if u >= n - off then () else
(* 6B *)
let b = Bytes.make v '\000' in
fill ~data:!ai ~out:b;
(* 6C *)
let i' = Bytes.create (String.length i) in
for j = 0 to pred (String.length i / v) do
let c = ref 1 in
for k = pred v downto 0 do
let idx = j * v + k in
c := (!c + String.get_uint8 i idx + Bytes.get_uint8 b k) land 0xFFFF;
Bytes.set_uint8 i' idx (!c land 0xFF);
c := !c lsr 8;
done;
done;
one (off + u) (Bytes.to_string i')
in
let i = salt ^ pass in
one 0 i;
Bytes.unsafe_to_string out
let split str off =
String.sub str 0 off,
String.sub str off (String.length str - off)
(* TODO PKCS5/7 padding is "k - (l mod k)" i.e. always > 0!
(and rc4 being a stream cipher has no padding!) *)
let unpad x =
(* TODO can there be bad padding in this scheme? *)
let l = String.length x in
if l > 0 then
let amount = String.get_uint8 x (pred l) in
let split_point = if l > amount then l - amount else l in
let data, pad = split x split_point in
let good = ref true in
for i = 0 to pred amount do
if String.get_uint8 pad i <> amount then good := false
done;
if !good then data else x
else
x
let pad bs x =
let l = String.length x in
let to_pad = bs - (l mod bs) in
let amount = String.make to_pad (Char.unsafe_chr to_pad) in
x ^ amount
let ( let* ) = Result.bind
(* there are 3 possibilities to encrypt / decrypt things:
- PKCS12 KDF (see above), with RC2/RC4/DES
- PKCS5 v1 (PBES, PBKDF1) -- not (yet?) supported
- PKCS5 v2 (PBES2, PBKDF2)
*)
let pkcs12_decrypt algo password data =
let open Algorithm in
let hash = `SHA1 in
let* salt, count, key_len, iv_len =
match algo with
| SHA_RC4_128 (s, i) -> Ok (s, i, 16, 0)
| SHA_RC4_40 (s, i) -> Ok (s, i, 5, 0)
| SHA_3DES_CBC (s, i) -> Ok (s, i, 24, 8)
| SHA_2DES_CBC (s, i) -> Ok (s, i, 16, 8) (* TODO 2des -> 3des keys (if relevant)*)
| SHA_RC2_128_CBC (s, i) -> Ok (s, i, 16, 8)
| SHA_RC2_40_CBC (s, i) -> Ok (s, i, 5, 8)
| _ -> Error (`Msg "unsupported algorithm")
in
let key = pbes hash `Encryption password salt count key_len
and iv = pbes hash `Iv password salt count iv_len
in
let open Mirage_crypto in
let* data =
match algo with
| SHA_RC2_40_CBC _ | SHA_RC2_128_CBC _ ->
Ok (Rc2.decrypt_cbc ~effective:(key_len * 8) ~key ~iv data)
| SHA_RC4_40 _ | SHA_RC4_128 _ ->
let key = ARC4.of_secret key in
let { ARC4.message ; _ } = ARC4.decrypt ~key data in
Ok message
| SHA_3DES_CBC _ ->
let key = DES.CBC.of_secret key in
Ok (DES.CBC.decrypt ~key ~iv data)
| _ -> Error (`Msg "encryption algorithm not supported")
in
Ok (unpad data)
let pkcs5_2_decrypt kdf enc password data =
let* dk_len, iv =
match enc with
| Algorithm.AES128_CBC iv -> Ok (16l, iv)
| Algorithm.AES192_CBC iv -> Ok (24l, iv)
| Algorithm.AES256_CBC iv -> Ok (32l, iv)
| _ -> Error (`Msg "unsupported encryption algorithm")
in
let* salt, count, prf =
match kdf with
| Algorithm.PBKDF2 (salt, iterations, _ (* todo handle keylength *), prf) ->
let* prf =
match Algorithm.to_hmac prf with
| Some prf -> Ok prf
| None -> Error (`Msg "unsupported PRF")
in
Ok (salt, iterations, prf)
| _ -> Error (`Msg "expected kdf being pbkdf2")
in
let key = Pbkdf.pbkdf2 ~prf ~password ~salt ~count ~dk_len in
let key = Mirage_crypto.AES.CBC.of_secret key in
let msg = Mirage_crypto.AES.CBC.decrypt ~key ~iv data in
Ok (unpad msg)
let pkcs5_2_encrypt (mac : [ `SHA1 | `SHA224 | `SHA256 | `SHA384 | `SHA512 ]) count algo password data =
let module Hash = (val (Digestif.module_of_hash' (mac :> Digestif.hash'))) in
let bs = Mirage_crypto.AES.CBC.block_size in
let iv = Mirage_crypto_rng.generate bs in
let enc, dk_len =
match algo with
| `AES128_CBC -> Algorithm.AES128_CBC iv, 16l
| `AES192_CBC -> Algorithm.AES192_CBC iv, 24l
| `AES256_CBC -> Algorithm.AES256_CBC iv, 32l
in
let salt = Mirage_crypto_rng.generate Hash.digest_size in
let key = Pbkdf.pbkdf2 ~prf:(mac :> Digestif.hash') ~password ~salt ~count ~dk_len in
let key = Mirage_crypto.AES.CBC.of_secret key in
let padded_data = pad bs data in
let enc_data =
Mirage_crypto.AES.CBC.encrypt ~key ~iv padded_data
in
let kdf = Algorithm.PBKDF2 (salt, count, None, Algorithm.of_hmac mac) in
Algorithm.PBES2 (kdf, enc), enc_data
let decrypt algo password data =
let open Algorithm in
match algo with
| SHA_RC4_128 _ | SHA_RC4_40 _
| SHA_3DES_CBC _ | SHA_2DES_CBC _
| SHA_RC2_128_CBC _ | SHA_RC2_40_CBC _ -> pkcs12_decrypt algo password data
| PBES2 (kdf, enc) -> pkcs5_2_decrypt kdf enc password data
| _ -> Error (`Msg "unsupported encryption algorithm")
let password_decrypt password (algo, data) =
match data with
| None -> Error (`Msg "no data to decrypt")
| Some data -> decrypt algo password data
let verify password (data, ((algorithm, digest), salt, iterations)) =
let* hash =
Option.to_result
~none:(`Msg "unsupported hash algorithm")
(Algorithm.to_hash algorithm)
in
let module Hash = (val (Digestif.module_of_hash' (hash :> Digestif.hash'))) in
let key =
pbes hash `Hmac password salt iterations Hash.digest_size
in
let computed = Hash.(to_raw_string (hmac_string ~key data)) in
if String.equal computed digest then begin
let* content = Asn_grammars.err_to_msg (Asn.auth_safe_of_cs data) in
let* safe_contents =
List.fold_left (fun acc c ->
let* acc = acc in
match c with
| `Data data -> Ok (data :: acc)
| `Encrypted data ->
let* data = password_decrypt password data in
Ok (data :: acc))
(Ok []) content
in
List.fold_left (fun acc cs ->
let* acc = acc in
let* bags = Asn_grammars.err_to_msg (Asn.safe_contents_of_cs cs) in
List.fold_left (fun acc bag ->
let* acc = acc in
match bag with
| `Certificate c, _ -> Ok (`Certificate c :: acc)
| `Crl c, _ -> Ok (`Crl c :: acc)
| `Private_key p, _ -> Ok (`Private_key p :: acc)
| `Encrypted_private_key (algo, enc_data), _ ->
let* data = decrypt algo password enc_data in
let* p =
Asn_grammars.err_to_msg (Private_key.Asn.private_of_octets data)
in
Ok (`Decrypted_private_key p :: acc))
(Ok acc) bags)
(Ok []) safe_contents
end else
Error (`Msg "invalid signature")
let create ?(mac = `SHA256) ?(algorithm = `AES256_CBC) ?(iterations = 2048) password certificates private_key =
let key_fp pub = Public_key.fingerprint pub in
let priv_fp = key_fp (Private_key.public private_key) in
let attributes = [ Registry.PKCS9.local_key_id, [ priv_fp ]] in
let maybe_attr c =
if String.equal priv_fp (key_fp (Certificate.public_key c)) then
Some attributes
else
None
in
let cert_sc =
Asn.safe_contents_to_cs (List.map (fun c -> `Certificate c, maybe_attr c) certificates)
and priv_sc =
let data = Private_key.Asn.private_to_octets private_key in
let algo, data = pkcs5_2_encrypt mac iterations algorithm password data in
Asn.safe_contents_to_cs [ `Encrypted_private_key (algo, data), Some attributes ]
in
let cert_sc_enc =
let algo, data = pkcs5_2_encrypt mac iterations algorithm password cert_sc in
algo, Some data
in
let auth_data =
Asn.auth_safe_to_cs [ `Encrypted cert_sc_enc ; `Data priv_sc ]
in
let module Hash = (val (Digestif.module_of_hash' (mac :> Digestif.hash'))) in
let mac_size = Hash.digest_size in
let salt = Mirage_crypto_rng.generate mac_size in
let key = pbes mac `Hmac password salt iterations mac_size in
let digest = Hash.(to_raw_string (hmac_string ~key auth_data)) in
auth_data, ((Algorithm.of_hash mac, digest), salt, iterations)
let decode_der cs = Asn_grammars.err_to_msg (Asn.pfx_of_cs cs)
let encode_der = Asn.pfx_to_cs

108
unikernel/duniverse/ocaml-x509/lib/pem.ml Normal file
View file

@ -0,0 +1,108 @@
let ( let* ) = Result.bind
module Cs = struct
open String
let null cs = length cs = 0
let open_begin = "-----BEGIN "
and open_end = "-----END "
and close = "-----"
let tok_of_line cs =
if null cs then
`Empty
else if get cs 0 = '#' then
`Empty
else if starts_with ~prefix:open_begin cs && ends_with ~suffix:close cs then
`Begin (sub cs 11 (length cs - 16))
else if starts_with ~prefix:open_end cs && ends_with ~suffix:close cs then
`End (sub cs 9 (length cs - 14))
else
`Data cs
let lines data =
List.map tok_of_line
(List.map
(fun line ->
let ll = length line in
if ll > 0 && get line (ll - 1) = '\r' then sub line 0 (ll - 1) else line)
(String.split_on_char '\n' data))
let combine ilines =
let rec accumulate t acc = function
| `Empty :: tail -> accumulate t acc tail
| `Data cs :: tail -> accumulate t (cs :: acc) tail
| `End t' :: tail ->
if String.equal t t' then
let data = match Base64.decode (concat "" (List.rev acc)) with
| Ok data -> Ok (t, data)
| Error e -> Error e
in
data, tail
else
Error (`Msg ("invalid end, expected " ^ t ^ ", found " ^ t')), tail
| _ :: tail -> Error (`Msg "invalid line, expected data or end"), tail
| [] -> Error (`Msg "end of input"), []
in
let rec block acc = function
| `Begin t :: tail ->
let body, tail = accumulate t [] tail in
block (body :: acc) tail
| _ :: xs -> block acc xs
| [] -> List.rev acc
in
block [] ilines
let parse_with_errors data = combine (lines data)
let unparse ~tag value =
let split_at_64 data =
let dlen = length data in
let rec go acc off =
if dlen - off <= 64 then
List.rev (sub data off (dlen - off) :: acc)
else
let chunk = sub data off 64 in
go (chunk :: acc) (off + 64)
in
go [] 0
in
let raw = Base64.encode_string value in
let pieces = split_at_64 raw in
let nl = "\n" in
let lines = List.flatten (List.map (fun x -> [ x ; nl ]) pieces)
in
let first = [ open_begin ; tag ; close ; nl ]
and last = [ open_end ; tag ; close ; nl ]
in
concat "" (first @ lines @ last)
end
let parse_with_errors, unparse = Cs.(parse_with_errors, unparse)
let parse data =
let entries, errors =
List.partition_map
(function Ok v -> Either.Left v | Error e -> Either.Right e)
(parse_with_errors data)
in
match errors with
| [] -> Ok entries
| first_error :: _ -> Error first_error
let exactly_one ~what = function
| [] -> Error (`Msg ("No " ^ what))
| [x] -> Ok x
| _ -> Error (`Msg ("Multiple " ^ what ^ "s"))
let foldM f data =
let wrap acc data =
let* datas' = acc in
let* data = f data in
Ok (data :: datas')
in
let* res = List.fold_left wrap (Ok []) data in
Ok (List.rev res)

289
unikernel/duniverse/ocaml-x509/lib/private_key.ml Normal file
View file

@ -0,0 +1,289 @@
let ( let* ) = Result.bind
type ecdsa = [
| `P256 of Mirage_crypto_ec.P256.Dsa.priv
| `P384 of Mirage_crypto_ec.P384.Dsa.priv
| `P521 of Mirage_crypto_ec.P521.Dsa.priv
]
type t = [
ecdsa
| `RSA of Mirage_crypto_pk.Rsa.priv
| `ED25519 of Mirage_crypto_ec.Ed25519.priv
]
let key_type = function
| `RSA _ -> `RSA
| `ED25519 _ -> `ED25519
| `P256 _ -> `P256
| `P384 _ -> `P384
| `P521 _ -> `P521
let generate ?seed ?(bits = 4096) typ =
let g = match seed with
| None -> None
| Some seed -> Some Mirage_crypto_rng.(create ~seed (module Fortuna))
in
match typ with
| `RSA -> `RSA (Mirage_crypto_pk.Rsa.generate ?g ~bits ())
| `ED25519 -> `ED25519 (fst (Mirage_crypto_ec.Ed25519.generate ?g ()))
| `P256 -> `P256 (fst (Mirage_crypto_ec.P256.Dsa.generate ?g ()))
| `P384 -> `P384 (fst (Mirage_crypto_ec.P384.Dsa.generate ?g ()))
| `P521 -> `P521 (fst (Mirage_crypto_ec.P521.Dsa.generate ?g ()))
let of_octets data =
let open Mirage_crypto_ec in
let ec_err e =
Result.map_error
(fun e -> `Msg (Fmt.to_to_string Mirage_crypto_ec.pp_error e))
e
in
function
| `RSA -> Error (`Msg "cannot decode an RSA key")
| `ED25519 ->
let* k = ec_err (Ed25519.priv_of_octets data) in
Ok (`ED25519 k)
| `P256 ->
let* k = ec_err (P256.Dsa.priv_of_octets data) in
Ok (`P256 k)
| `P384 ->
let* k = ec_err (P384.Dsa.priv_of_octets data) in
Ok (`P384 k)
| `P521 ->
let* k = ec_err (P521.Dsa.priv_of_octets data) in
Ok (`P521 k)
let of_string ?seed_or_data ?bits typ data =
match seed_or_data with
| None ->
begin match typ with
| `RSA -> Ok (generate ~seed:data ?bits `RSA)
| _ ->
let* data = Base64.decode data in
of_octets data typ
end
| Some `Seed ->
Ok (generate ~seed:data ?bits typ)
| Some `Data ->
let* data = Base64.decode data in
of_octets data typ
let public = function
| `RSA priv -> `RSA (Mirage_crypto_pk.Rsa.pub_of_priv priv)
| `ED25519 priv -> `ED25519 (Mirage_crypto_ec.Ed25519.pub_of_priv priv)
| `P256 priv -> `P256 (Mirage_crypto_ec.P256.Dsa.pub_of_priv priv)
| `P384 priv -> `P384 (Mirage_crypto_ec.P384.Dsa.pub_of_priv priv)
| `P521 priv -> `P521 (Mirage_crypto_ec.P521.Dsa.pub_of_priv priv)
let sign hash ?scheme key data =
let open Mirage_crypto_ec in
let hashed () = Public_key.hashed hash data
and ecdsa_to_str s = Algorithm.ecdsa_sig_to_octets s
in
let scheme = Key_type.opt_signature_scheme ?scheme (key_type key) in
try
match key, scheme with
| `RSA key, `RSA_PSS ->
let module H = (val (Digestif.module_of_hash' hash)) in
let module PSS = Mirage_crypto_pk.Rsa.PSS(H) in
let* d = hashed () in
Ok (PSS.sign ~key (`Digest d))
| `RSA key, `RSA_PKCS1 ->
let* d = hashed () in
Ok (Mirage_crypto_pk.Rsa.PKCS1.sign ~key ~hash (`Digest d))
| `ED25519 key, `ED25519 ->
begin match data with
| `Message m -> Ok (Ed25519.sign ~key m)
| `Digest _ -> Error (`Msg "Ed25519 only suitable with raw message")
end
| #ecdsa as key, `ECDSA ->
let* d = hashed () in
Ok (ecdsa_to_str (match key with
| `P256 key -> P256.Dsa.(sign ~key (Public_key.trunc byte_length d))
| `P384 key -> P384.Dsa.(sign ~key (Public_key.trunc byte_length d))
| `P521 key -> P521.Dsa.(sign ~key (Public_key.trunc byte_length d))))
| _ -> Error (`Msg "invalid key and signature scheme combination")
with
| Mirage_crypto_pk.Rsa.Insufficient_key ->
Error (`Msg "RSA key of insufficient length")
| Message_too_long -> Error (`Msg "message too long")
module Asn = struct
open Asn.S
open Mirage_crypto_pk
(* RSA *)
let other_prime_infos =
sequence_of @@
(sequence3
(required ~label:"prime" unsigned_integer)
(required ~label:"exponent" unsigned_integer)
(required ~label:"coefficient" unsigned_integer))
let rsa_private_key =
let integer = map Z_extra.of_octets_be Z_extra.to_octets_be unsigned_integer in
let f (v, (n, (e, (d, (p, (q, (dp, (dq, (q', other))))))))) =
match (v, other) with
| (0, None) ->
begin match Rsa.priv ~e ~d ~n ~p ~q ~dp ~dq ~q' with
| Ok p -> p
| Error (`Msg m) -> parse_error "bad RSA private key %s" m
end
| _ -> parse_error "multi-prime RSA keys not supported"
and g { Rsa.e; d; n; p; q; dp; dq; q' } =
(0, (n, (e, (d, (p, (q, (dp, (dq, (q', None))))))))) in
map f g @@
sequence @@
(required ~label:"version" int)
@ (required ~label:"modulus" integer) (* n *)
@ (required ~label:"publicExponent" integer) (* e *)
@ (required ~label:"privateExponent" integer) (* d *)
@ (required ~label:"prime1" integer) (* p *)
@ (required ~label:"prime2" integer) (* q *)
@ (required ~label:"exponent1" integer) (* dp *)
@ (required ~label:"exponent2" integer) (* dq *)
@ (required ~label:"coefficient" integer) (* qinv *)
-@ (optional ~label:"otherPrimeInfos" other_prime_infos)
(* For outside uses. *)
let (rsa_private_of_octets, rsa_private_to_octets) =
Asn_grammars.projections_of Asn.der rsa_private_key
(* PKCS8 *)
let (rsa_priv_of_str, rsa_priv_to_str) =
Asn_grammars.project_exn rsa_private_key
let ec_to_err = function
| Ok x -> x
| Error e -> parse_error "%a" Mirage_crypto_ec.pp_error e
let ed25519_of_str, ed25519_to_str =
Asn_grammars.project_exn octet_string
let ec_private_key =
let f (v, pk, nc, pub) =
if v <> 1 then
parse_error "bad version for ec Private key"
else
let curve = match nc with
| Some c -> Some (Algorithm.curve_of_oid c)
| None -> None
in
pk, curve, pub
and g (pk, curve, pub) =
let nc = match curve with
| None -> None | Some c -> Some (Algorithm.curve_to_oid c)
in
(1, pk, nc, pub)
in
Asn.S.map f g @@
sequence4
(required ~label:"version" int) (* ecPrivkeyVer1(1) *)
(required ~label:"privateKey" octet_string)
(* from rfc5480: choice3, but only namedCurve is allowed in PKIX *)
(optional ~label:"namedCurve" (explicit 0 oid))
(optional ~label:"publicKey" (explicit 1 bit_string))
let ec_of_str, ec_to_str =
Asn_grammars.project_exn ec_private_key
let reparse_ec_private curve priv =
let open Mirage_crypto_ec in
match curve with
| `SECP256R1 -> let* p = P256.Dsa.priv_of_octets priv in Ok (`P256 p)
| `SECP384R1 -> let* p = P384.Dsa.priv_of_octets priv in Ok (`P384 p)
| `SECP521R1 -> let* p = P521.Dsa.priv_of_octets priv in Ok (`P521 p)
(* external use (result) *)
let ec_priv_of_str =
let dec, _ = Asn_grammars.projections_of Asn.der ec_private_key in
fun cs ->
let* priv, curve, _pub = dec cs in
match curve with
| None -> Error (`Parse "no curve provided")
| Some c ->
Result.map_error
(fun e -> `Parse (Fmt.to_to_string Mirage_crypto_ec.pp_error e))
(reparse_ec_private c priv)
let ec_of_str ?curve cs =
let (priv, named_curve, _pub) = ec_of_str cs in
let nc =
match curve, named_curve with
| Some c, None -> c
| None, Some c -> c
| Some c, Some c' -> if c = c' then c else parse_error "conflicting curve"
| None, None -> parse_error "unknown curve"
in
ec_to_err (reparse_ec_private nc priv)
let ec_to_str ?curve ?pub key = ec_to_str (key, curve, pub)
let reparse_private pk =
match pk with
| (0, Algorithm.RSA, cs) -> `RSA (rsa_priv_of_str cs)
| (0, Algorithm.ED25519, cs) ->
let data = ed25519_of_str cs in
`ED25519 (ec_to_err (Mirage_crypto_ec.Ed25519.priv_of_octets data))
| (0, Algorithm.EC_pub curve, cs) -> ec_of_str ~curve cs
| _ -> parse_error "unknown private key info"
let unparse_private p =
let open Mirage_crypto_ec in
let open Algorithm in
let alg, cs =
match p with
| `RSA pk -> RSA, rsa_priv_to_str pk
| `ED25519 pk -> ED25519, ed25519_to_str (Ed25519.priv_to_octets pk)
| `P256 pk -> EC_pub `SECP256R1, ec_to_str (P256.Dsa.priv_to_octets pk)
| `P384 pk -> EC_pub `SECP384R1, ec_to_str (P384.Dsa.priv_to_octets pk)
| `P521 pk -> EC_pub `SECP521R1, ec_to_str (P521.Dsa.priv_to_octets pk)
in
(0, alg, cs)
let private_key_info =
map reparse_private unparse_private @@
sequence3
(required ~label:"version" int)
(required ~label:"privateKeyAlgorithm" Algorithm.identifier)
(required ~label:"privateKey" octet_string)
(* TODO: there's an
(optional ~label:"attributes" @@ implicit 0 (SET of Attributes)
which are defined in X.501; but nobody seems to use them anyways *)
let (private_of_octets, private_to_octets) =
Asn_grammars.projections_of Asn.der private_key_info
end
let decode_der cs =
Asn_grammars.err_to_msg (Asn.private_of_octets cs)
let encode_der = Asn.private_to_octets
let decode_pem cs =
let* data = Pem.parse cs in
let rsa_p (t, _) = String.equal "RSA PRIVATE KEY" t
and ec_p (t, _) = String.equal "EC PRIVATE KEY" t
and pk_p (t, _) = String.equal "PRIVATE KEY" t
in
let r, _ = List.partition rsa_p data
and ec, _ = List.partition ec_p data
and p, _ = List.partition pk_p data
in
let* k =
Pem.foldM (fun (_, k) ->
let* k = Asn_grammars.err_to_msg (Asn.rsa_private_of_octets k) in
Ok (`RSA k)) r
in
let* k' =
Pem.foldM (fun (_, k) ->
Asn_grammars.err_to_msg (Asn.ec_priv_of_str k)) ec
in
let* k'' =
Pem.foldM (fun (_, k) ->
Asn_grammars.err_to_msg (Asn.private_of_octets k)) p
in
Pem.exactly_one ~what:"private key" (k @ k' @ k'')
let encode_pem p =
Pem.unparse ~tag:"PRIVATE KEY" (Asn.private_to_octets p)

166
unikernel/duniverse/ocaml-x509/lib/public_key.ml Normal file
View file

@ -0,0 +1,166 @@
let ( let* ) = Result.bind
type ecdsa = [
| `P256 of Mirage_crypto_ec.P256.Dsa.pub
| `P384 of Mirage_crypto_ec.P384.Dsa.pub
| `P521 of Mirage_crypto_ec.P521.Dsa.pub
]
type t = [
| ecdsa
| `RSA of Mirage_crypto_pk.Rsa.pub
| `ED25519 of Mirage_crypto_ec.Ed25519.pub
]
module Asn_oid = Asn.OID
module Asn = struct
open Asn_grammars
open Asn.S
open Mirage_crypto_pk
let rsa_public_key =
let f (n, e) =
let n = Z_extra.of_octets_be n
and e = Z_extra.of_octets_be e in
match Rsa.pub ~e ~n with
| Ok p -> p
| Error (`Msg m) -> parse_error "bad RSA public key %s" m
and g ({ Rsa.n; e } : Rsa.pub) = (Z_extra.to_octets_be n, Z_extra.to_octets_be e) in
map f g @@
sequence2
(required ~label:"modulus" unsigned_integer)
(required ~label:"publicExponent" unsigned_integer)
let (rsa_public_of_octets, rsa_public_to_octets) =
projections_of Asn.der rsa_public_key
let rsa_pub_of_octets, rsa_pub_to_octets = project_exn rsa_public_key
let to_err = function
| Ok r -> r
| Error e ->
parse_error "failed to decode public EC key %a"
Mirage_crypto_ec.pp_error e
let reparse_pk =
let open Mirage_crypto_ec in
let open Algorithm in
function
| (RSA , cs) -> `RSA (rsa_pub_of_octets cs)
| (ED25519 , cs) -> `ED25519 (to_err (Ed25519.pub_of_octets cs))
| (EC_pub `SECP256R1, cs) -> `P256 (to_err (P256.Dsa.pub_of_octets cs))
| (EC_pub `SECP384R1, cs) -> `P384 (to_err (P384.Dsa.pub_of_octets cs))
| (EC_pub `SECP521R1, cs) -> `P521 (to_err (P521.Dsa.pub_of_octets cs))
| _ -> parse_error "unknown public key algorithm"
let unparse_pk =
let open Mirage_crypto_ec in
let open Algorithm in
function
| `RSA pk -> (RSA, rsa_pub_to_octets pk)
| `ED25519 pk -> (ED25519, Ed25519.pub_to_octets pk)
| `P256 pk -> (EC_pub `SECP256R1, P256.Dsa.pub_to_octets pk)
| `P384 pk -> (EC_pub `SECP384R1, P384.Dsa.pub_to_octets pk)
| `P521 pk -> (EC_pub `SECP521R1, P521.Dsa.pub_to_octets pk)
let pk_info_der =
map reparse_pk unparse_pk @@
sequence2
(required ~label:"algorithm" Algorithm.identifier)
(required ~label:"subjectPK" bit_string_octets)
let (pub_info_of_octets, pub_info_to_octets) =
projections_of Asn.der pk_info_der
end
let id k =
let data = match k with
| `RSA p -> Asn.rsa_public_to_octets p
| `ED25519 pk -> Mirage_crypto_ec.Ed25519.pub_to_octets pk
| `P256 pk -> Mirage_crypto_ec.P256.Dsa.pub_to_octets pk
| `P384 pk -> Mirage_crypto_ec.P384.Dsa.pub_to_octets pk
| `P521 pk -> Mirage_crypto_ec.P521.Dsa.pub_to_octets pk
in
Digestif.(to_raw_string SHA1 (digest_string SHA1 data))
let fingerprint ?(hash = `SHA256) pub =
let module Hash = (val (Digestif.module_of_hash' (hash :> Digestif.hash'))) in
Hash.(to_raw_string (digest_string (Asn.pub_info_to_octets pub)))
let key_type = function
| `RSA _ -> `RSA
| `ED25519 _ -> `ED25519
| `P256 _ -> `P256
| `P384 _ -> `P384
| `P521 _ -> `P521
let sig_alg = function
| #ecdsa -> `ECDSA
| `RSA _ -> `RSA
| `ED25519 _ -> `ED25519
let pp ppf k =
Fmt.string ppf (Key_type.to_string (key_type k));
Fmt.sp ppf ();
Ohex.pp ppf (fingerprint k)
let hashed hash data =
let module Hash = (val (Digestif.module_of_hash' hash)) in
match data with
| `Message msg -> Ok Hash.(to_raw_string (digest_string msg))
| `Digest d ->
let n = String.length d and m = Hash.digest_size in
if n = m then Ok d else Error (`Msg "digested data of invalid size")
let trunc len data =
if String.length data > len then
String.sub data 0 len
else
data
let verify hash ?scheme ~signature key data =
let open Mirage_crypto_ec in
let ok_if_true p = if p then Ok () else Error (`Msg "bad signature") in
let ecdsa_of_str cs =
Result.map_error (function `Parse s -> `Msg s)
(Algorithm.ecdsa_sig_of_octets cs)
in
let scheme = Key_type.opt_signature_scheme ?scheme (key_type key) in
match key, scheme with
| `RSA key, `RSA_PSS ->
let module H = (val (Digestif.module_of_hash' hash)) in
let module PSS = Mirage_crypto_pk.Rsa.PSS(H) in
let* d = hashed hash data in
ok_if_true (PSS.verify ~key ~signature (`Digest d))
| `RSA key, `RSA_PKCS1 ->
let hashp x = x = hash in
let* d = hashed hash data in
ok_if_true (Mirage_crypto_pk.Rsa.PKCS1.verify ~hashp ~key ~signature (`Digest d))
| `ED25519 key, `ED25519 ->
begin match data with
| `Message msg -> ok_if_true (Ed25519.verify ~key signature ~msg)
| `Digest _ -> Error (`Msg "Ed25519 only suitable with raw message")
end
| #ecdsa as key, `ECDSA ->
let* d = hashed hash data in
let* s = ecdsa_of_str signature in
ok_if_true
(match key with
| `P256 key -> P256.Dsa.verify ~key s (trunc P256.Dsa.byte_length d)
| `P384 key -> P384.Dsa.verify ~key s (trunc P384.Dsa.byte_length d)
| `P521 key -> P521.Dsa.verify ~key s (trunc P521.Dsa.byte_length d))
| _ -> Error (`Msg "invalid key and signature scheme combination")
let encode_der = Asn.pub_info_to_octets
let decode_der cs = Asn_grammars.err_to_msg (Asn.pub_info_of_octets cs)
let decode_pem cs =
let* data = Pem.parse cs in
let pks = List.filter (fun (t, _) -> String.equal "PUBLIC KEY" t) data in
let* keys = Pem.foldM (fun (_, k) -> decode_der k) pks in
Pem.exactly_one ~what:"public key" keys
let encode_pem v =
Pem.unparse ~tag:"PUBLIC KEY" (encode_der v)

175
unikernel/duniverse/ocaml-x509/lib/rc2.ml Normal file
View file

@ -0,0 +1,175 @@
let pitable = [|
0xd9; 0x78; 0xf9; 0xc4; 0x19; 0xdd; 0xb5; 0xed; 0x28; 0xe9; 0xfd; 0x79; 0x4a; 0xa0; 0xd8; 0x9d;
0xc6; 0x7e; 0x37; 0x83; 0x2b; 0x76; 0x53; 0x8e; 0x62; 0x4c; 0x64; 0x88; 0x44; 0x8b; 0xfb; 0xa2;
0x17; 0x9a; 0x59; 0xf5; 0x87; 0xb3; 0x4f; 0x13; 0x61; 0x45; 0x6d; 0x8d; 0x09; 0x81; 0x7d; 0x32;
0xbd; 0x8f; 0x40; 0xeb; 0x86; 0xb7; 0x7b; 0x0b; 0xf0; 0x95; 0x21; 0x22; 0x5c; 0x6b; 0x4e; 0x82;
0x54; 0xd6; 0x65; 0x93; 0xce; 0x60; 0xb2; 0x1c; 0x73; 0x56; 0xc0; 0x14; 0xa7; 0x8c; 0xf1; 0xdc;
0x12; 0x75; 0xca; 0x1f; 0x3b; 0xbe; 0xe4; 0xd1; 0x42; 0x3d; 0xd4; 0x30; 0xa3; 0x3c; 0xb6; 0x26;
0x6f; 0xbf; 0x0e; 0xda; 0x46; 0x69; 0x07; 0x57; 0x27; 0xf2; 0x1d; 0x9b; 0xbc; 0x94; 0x43; 0x03;
0xf8; 0x11; 0xc7; 0xf6; 0x90; 0xef; 0x3e; 0xe7; 0x06; 0xc3; 0xd5; 0x2f; 0xc8; 0x66; 0x1e; 0xd7;
0x08; 0xe8; 0xea; 0xde; 0x80; 0x52; 0xee; 0xf7; 0x84; 0xaa; 0x72; 0xac; 0x35; 0x4d; 0x6a; 0x2a;
0x96; 0x1a; 0xd2; 0x71; 0x5a; 0x15; 0x49; 0x74; 0x4b; 0x9f; 0xd0; 0x5e; 0x04; 0x18; 0xa4; 0xec;
0xc2; 0xe0; 0x41; 0x6e; 0x0f; 0x51; 0xcb; 0xcc; 0x24; 0x91; 0xaf; 0x50; 0xa1; 0xf4; 0x70; 0x39;
0x99; 0x7c; 0x3a; 0x85; 0x23; 0xb8; 0xb4; 0x7a; 0xfc; 0x02; 0x36; 0x5b; 0x25; 0x55; 0x97; 0x31;
0x2d; 0x5d; 0xfa; 0x98; 0xe3; 0x8a; 0x92; 0xae; 0x05; 0xdf; 0x29; 0x10; 0x67; 0x6c; 0xba; 0xc9;
0xd3; 0x00; 0xe6; 0xcf; 0xe1; 0x9e; 0xa8; 0x2c; 0x63; 0x16; 0x01; 0x3f; 0x58; 0xe2; 0x89; 0xa9;
0x0d; 0x38; 0x34; 0x1b; 0xab; 0x33; 0xff; 0xb0; 0xbb; 0x48; 0x0c; 0x5f; 0xb9; 0xb1; 0xcd; 0x2e;
0xc5; 0xf3; 0xdb; 0x47; 0xe5; 0xa5; 0x9c; 0x77; 0x0a; 0xa6; 0x20; 0x68; 0xfe; 0x7f; 0xc1; 0xad
|]
(* effective is sometimes named t1 *)
let tm effective =
let t8 = (effective + 7) / 8 in
(* RFC says (TM = 255 MOD 2^(8 + effective - 8*T8)) *)
let bits = 8 + effective - 8 * t8 in
(* likely there's a smarter way to do this *)
let rec c acc = function
| 0 -> acc
| n -> c ((acc lsl 1) + 1) (pred n)
in
t8, c 0 bits
(* L[i] is the i-th byte of the key; K[i] is the i-th 16-bit-word of the key *)
let key_expansion effective key =
(* result is a 128 byte key, where we need the words.. *)
let t = String.length key in
let l = Array.init 128 (fun idx -> if idx < t then String.get_uint8 key idx else 0) in
let t8, tm = tm effective in
for i = t to 127 do
l.(i) <- pitable.((l.(i - 1) + l.(i - t)) mod 256)
done;
l.(128 - t8) <- pitable.(l.(128 - t8) land tm);
for i = 127 - t8 downto 0 do
l.(i) <- pitable.(l.(i + 1) lxor l.(i + t8));
done;
Array.init 64 (fun idx -> l.(2 * idx) + 256 * l.(2 * idx + 1))
let mod16 f = 0xFFFF land f
let rol16 x k = mod16 ((x lsl k) lor (x lsr (16 - k)))
let ror16 x k = mod16 ((x lsr k) lor (x lsl (16 - k)))
let not16 x = mod16 (lnot x)
let s = Array.init 4 (function 0 -> 1 | 1 -> 2 | 2 -> 3 | 3 -> 5 | _ -> assert false)
let pmod a =
let b = 4 in
let r = a mod b in
if r < 0 then (r + b) mod b else r
(* only used for encryption which we don't support
let mix r i k j =
r.(i) <- mod16 (r.(i) + k.(j) + r.(pmod (i - 1)) land r.(pmod (i - 2)) +
(not16 r.(pmod (i - 1))) land r.(pmod (i - 3)));
let j = succ j in
r.(i) <- rol16 r.(i) s.(i);
j
let mix_round r k j =
let j' = mix r 0 k j in
let j'' = mix r 1 k j' in
let j''' = mix r 2 k j'' in
let j'''' = mix r 3 k j''' in
j''''
let mash r i k =
r.(i) <- mod16 (r.(i) + k.(r.(pmod (i - 1)) land 63))
let mash_round r k =
mash r 0 k;
mash r 1 k;
mash r 2 k;
mash r 3 k
let encrypt_one ~key ~data =
let r = Array.init 4 (fun idx -> Cstruct.LE.get_uint16 data (idx * 2)) in
let j = 0 in
let j = mix_round r key j in
let j = mix_round r key j in
let j = mix_round r key j in
let j = mix_round r key j in
let j = mix_round r key j in
mash_round r key;
let j = mix_round r key j in
let j = mix_round r key j in
let j = mix_round r key j in
let j = mix_round r key j in
let j = mix_round r key j in
let j = mix_round r key j in
mash_round r key;
let j = mix_round r key j in
let j = mix_round r key j in
let j = mix_round r key j in
let j = mix_round r key j in
let _j = mix_round r key j in
let out = Cstruct.create 8 in
Cstruct.LE.set_uint16 out 0 r.(0);
Cstruct.LE.set_uint16 out 2 r.(1);
Cstruct.LE.set_uint16 out 4 r.(2);
Cstruct.LE.set_uint16 out 6 r.(3);
out
*)
let r_mix r i k j =
r.(i) <- ror16 r.(i) s.(i);
r.(i) <- mod16 (r.(i) - k.(j) -
(r.(pmod (i - 1)) land r.(pmod (i - 2))) -
(not16 r.(pmod (i - 1)) land (r.(pmod (i - 3)))));
pred j
let r_mix_round r k j =
let j' = r_mix r 3 k j in
let j'' = r_mix r 2 k j' in
let j''' = r_mix r 1 k j'' in
let j'''' = r_mix r 0 k j''' in
j''''
let r_mash r i k =
r.(i) <- mod16 (r.(i) - k.(r.(pmod (i - 1)) land 63))
let r_mash_round r k =
r_mash r 3 k;
r_mash r 2 k;
r_mash r 1 k;
r_mash r 0 k
let decrypt_one ~key ~data ?(off = 0) dst =
let r = Array.init 4 (fun idx -> String.get_uint16_le data (off + idx * 2)) in
let j = 63 in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
r_mash_round r key;
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
r_mash_round r key;
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let j = r_mix_round r key j in
let _j = r_mix_round r key j in
Bytes.set_uint16_le dst (off + 0) r.(0);
Bytes.set_uint16_le dst (off + 2) r.(1);
Bytes.set_uint16_le dst (off + 4) r.(2);
Bytes.set_uint16_le dst (off + 6) r.(3)
let decrypt_cbc ?(effective = 128) ~key ~iv data =
let block = 8 in
let key = key_expansion effective key in
let l = String.length data in
let dst = Bytes.create l in
for i = 0 to pred ((l + pred block) / block) do
decrypt_one ~key ~data ~off:(i * block) dst
done;
Mirage_crypto.Uncommon.unsafe_xor_into iv ~src_off:0 dst ~dst_off:0 block;
Mirage_crypto.Uncommon.unsafe_xor_into data ~src_off:0 dst ~dst_off:block (l - block);
Bytes.unsafe_to_string dst

320
unikernel/duniverse/ocaml-x509/lib/registry.ml Normal file
View file

@ -0,0 +1,320 @@
(*
* Object Identifiers: magic numbers with a tie. Some OIDs also have an MBA.
*
* http://www.alvestrand.no/objectid/
* http://oid-info.com/
*)
open Asn.OID
let pkix = base 1 3 <| 6 <| 1 <| 5 <| 5 <| 7
let usa = base 1 2 <| 840
let rsadsi = usa <| 113549
let pkcs = rsadsi <| 1
let us_govt = base 2 16 <| 840 <| 1 <| 101
let nist_alg = us_govt <| 3 <| 4
let hash_algs = nist_alg <| 2
(* PKCS1 *)
and md5 = rsadsi <| 2 <| 5
and sha1 = base 1 3 <| 14 <| 3 <| 2 <| 26
and sha1_rsa_encryption = base 1 3 <| 14 <| 3 <| 2 <| 29
(* rfc5758 *)
let sha256 = hash_algs <| 1
and sha384 = hash_algs <| 2
and sha512 = hash_algs <| 3
and sha224 = hash_algs <| 4
module ANSI_X9_62 = struct
let ansi_x9_62 = usa <| 10045
let ecdsa_sha1 = ansi_x9_62 <| 1
let prime_field = ecdsa_sha1 <| 1
and characteristic_2_field = ecdsa_sha1 <| 2
let key_type = ansi_x9_62 <| 2
let ec_pub_key = key_type <| 1
let signatures = ansi_x9_62 <| 4
let field_type = signatures <| 1
and ecdsa_sha2 = signatures <| 3
let ecdsa_sha224 = ecdsa_sha2 <| 1
and ecdsa_sha256 = ecdsa_sha2 <| 2
and ecdsa_sha384 = ecdsa_sha2 <| 3
and ecdsa_sha512 = ecdsa_sha2 <| 4
(* from RFC 5480 *)
let certicom = base 1 3 <| 132 <| 0
let curves = ansi_x9_62 <| 3 <| 1
let secp224r1 = certicom <| 33
let secp256r1 = curves <| 7
let secp384r1 = certicom <| 34
let secp521r1 = certicom <| 35
end
module PKCS1 = struct
let pkcs1 = pkcs <| 1
let rsa_encryption = pkcs1 <| 1
and md5_rsa_encryption = pkcs1 <| 4
and sha1_rsa_encryption = pkcs1 <| 5
and rsaes_oaep = pkcs1 <| 7
and rsassa_pss = pkcs1 <| 10
and sha256_rsa_encryption = pkcs1 <| 11
and sha384_rsa_encryption = pkcs1 <| 12
and sha512_rsa_encryption = pkcs1 <| 13
and sha224_rsa_encryption = pkcs1 <| 14
end
module RFC8410 = struct
let thawte = base 1 3 <| 101
let x25519 = thawte <| 110
and x448 = thawte <| 111
and ed25519 = thawte <| 112
and ed448 = thawte <| 113
end
module PKCS2 = struct
let pkcs2 = rsadsi <| 2
let md4 = pkcs2 <| 4
and hmac_sha1 = pkcs2 <| 7
and hmac_sha224 = pkcs2 <| 8
and hmac_sha256 = pkcs2 <| 9
and hmac_sha384 = pkcs2 <| 10
and hmac_sha512 = pkcs2 <| 11
end
module PKCS5 = struct
let pkcs5 = pkcs <| 5
let pbe_md2_des_cbc = pkcs5 <| 1
and pbe_md5_des_cbc = pkcs5 <| 3
and pbe_md2_rc2_cbc = pkcs5 <| 4
and pbe_md5_rc2_cbc = pkcs5 <| 6
and pbe_md5_xor = pkcs5 <| 9
and pbe_sha1_des_cbc = pkcs5 <| 10
and pbe_sha1_rc2_cbc = pkcs5 <| 11
and pbkdf2 = pkcs5 <| 12
and pbes2 = pkcs5 <| 13
and pbmac1 = pkcs5 <| 14
let aes = nist_alg <| 1
let aes128_cbc = aes <| 2
and aes192_cbc = aes <| 22
and aes256_cbc = aes <| 42
end
module PKCS7 = struct
let pkcs7 = pkcs <| 7
let data = pkcs7 <| 1
and signed_data = pkcs7 <| 2
and enveloped_data = pkcs7 <| 3
and signed_and_enveloped_data = pkcs7 <| 4
and digested_data = pkcs7 <| 5
and encrypted_data = pkcs7 <| 6
end
module PKCS9 = struct
let pkcs9 = pkcs <| 9
let email = pkcs9 <| 1
and unstructured_name = pkcs9 <| 2
and content_type = pkcs9 <| 3
and message_digest = pkcs9 <| 4
and signing_time = pkcs9 <| 5
and challenge_password = pkcs9 <| 7
and unstructured_address = pkcs9 <| 8
and signing_description = pkcs9 <| 13
and extension_request = pkcs9 <| 14
and smime_capabilities = pkcs9 <| 15
and smime_oid_registry = pkcs9 <| 16
and friendly_name = pkcs9 <| 20
and local_key_id = pkcs9 <| 21
and cert_types = pkcs9 <| 22
and crl_types = pkcs9 <| 23
end
module PKCS12 = struct
let pkcs12 = pkcs <| 12
let bagtypes = pkcs12 <| 10 <| 1
let key_bag = bagtypes <| 1
and pkcs8_shrouded_key_bag = bagtypes <| 2
and cert_bag = bagtypes <| 3
and crl_bag = bagtypes <| 4
and secret_bag = bagtypes <| 5
and safe_contents_bag = bagtypes <| 6
let pbe_ids = pkcs12 <| 1
let pbe_with_SHA_and_128Bit_RC4 = pbe_ids <| 1
and pbe_with_SHA_and_40Bit_RC4 = pbe_ids <| 2
and pbe_with_SHA_and_3_KeyTripleDES_CBC = pbe_ids <| 3
and pbe_with_SHA_and_2_KeyTripleDES_CBC = pbe_ids <| 4
and pbe_with_SHA_and_128Bit_RC2_CBC = pbe_ids <| 5
and pbe_with_SHA_and_40Bit_RC2_CBC = pbe_ids <| 6
end
module X520 = struct
let x520 = base 2 5 <| 4
let object_class = x520 <| 0
and aliased_entry_name = x520 <| 1
and knowldgeinformation = x520 <| 2
and common_name = x520 <| 3
and surname = x520 <| 4
and serial_number = x520 <| 5
and country_name = x520 <| 6
and locality_name = x520 <| 7
and state_or_province_name = x520 <| 8
and street_address = x520 <| 9
and organization_name = x520 <| 10
and organizational_unit_name = x520 <| 11
and title = x520 <| 12
and description = x520 <| 13
and search_guide = x520 <| 14
and business_category = x520 <| 15
and postal_address = x520 <| 16
and postal_code = x520 <| 17
and post_office_box = x520 <| 18
and physical_delivery_office_name = x520 <| 19
and telephone_number = x520 <| 20
and telex_number = x520 <| 21
and teletex_terminal_identifier = x520 <| 22
and facsimile_telephone_number = x520 <| 23
and x121_address = x520 <| 24
and internationa_isdn_number = x520 <| 25
and registered_address = x520 <| 26
and destination_indicator = x520 <| 27
and preferred_delivery_method = x520 <| 28
and presentation_address = x520 <| 29
and supported_application_context = x520 <| 30
and member = x520 <| 31
and owner = x520 <| 32
and role_occupant = x520 <| 33
and see_also = x520 <| 34
and user_password = x520 <| 35
and user_certificate = x520 <| 36
and ca_certificate = x520 <| 37
and authority_revocation_list = x520 <| 38
and certificate_revocation_list = x520 <| 39
and cross_certificate_pair = x520 <| 40
and name = x520 <| 41
and given_name = x520 <| 42
and initials = x520 <| 43
and generation_qualifier = x520 <| 44
and unique_identifier = x520 <| 45
and dn_qualifier = x520 <| 46
and enhanced_search_guide = x520 <| 47
and protocol_information = x520 <| 48
and distinguished_name = x520 <| 49
and unique_member = x520 <| 50
and house_identifier = x520 <| 51
and supported_algorithms = x520 <| 52
and delta_revocation_list = x520 <| 53
and attribute_certificate = x520 <| 58
and pseudonym = x520 <| 65
end
let ucl_data_networks = base 0 9 <| 2342 <| 19200300
let directory_pilot = ucl_data_networks <| 100 <| 1
(* The single rfc4519 oid rfc5280 requires us to be aware of.... *)
let domain_component = directory_pilot <| 25
(* rfc4514 oid required for compliance *)
let userid = directory_pilot <| 1
module Cert_extn = struct
let ce = base 2 5 <| 29
let authority_key_identifier_old = ce <| 1
and primary_key_attributes_old = ce <| 2
and certificate_policies_1 = ce <| 3
and primary_key_usage_restriction = ce <| 4
and subject_directory_attributes = ce <| 9
and subject_key_identifier = ce <| 14
and key_usage = ce <| 15
and private_key_usage_period = ce <| 16
and subject_alternative_name = ce <| 17
and issuer_alternative_name = ce <| 18
and basic_constraints = ce <| 19
and crl_number = ce <| 20
and reason_code = ce <| 21
and hold_instruction_code = ce <| 23
and invalidity_date = ce <| 24
and delta_crl_indicator = ce <| 27
and issuing_distribution_point = ce <| 28
and certificate_issuer = ce <| 29
and name_constraints = ce <| 30
and crl_distribution_points = ce <| 31
and certificate_policies_2 = ce <| 32
and policy_mappings = ce <| 33
and authority_key_identifier = ce <| 35
and policy_constraints = ce <| 36
and extended_key_usage = ce <| 37
and freshest_crl = ce <| 46
and inhibit_any_policy = ce <| 54
(* https://tools.ietf.org/html/rfc5280#section-4.2.2.1 *)
module Private_internet_extensions = struct
let pe = pkix <| 1
let authority_info_access = pe <| 1
let ad = pkix <| 48
let ad_ca_issuer = ad <| 2
let ad_ocsp = ad <| 1
let ad_ocsp_basic = ad_ocsp <| 1
end
module Extended_usage = struct
let any = extended_key_usage <| 0
let key_purpose = pkix <| 3
let server_auth = key_purpose <| 1
and client_auth = key_purpose <| 2
and code_signing = key_purpose <| 3
and email_protection = key_purpose <| 4
and ipsec_end_system = key_purpose <| 5
and ipsec_tunnel = key_purpose <| 6
and ipsec_user = key_purpose <| 7
and time_stamping = key_purpose <| 8
and ocsp_signing = key_purpose <| 9
end
module Cert_policy = struct
let qt = pkix <| 2
let cps = qt <| 1
let unotice = qt <| 2
let any_policy = certificate_policies_2 <| 0
end
end
module Name_extn = struct
(* For the rarely-used feature of GeneralName: AnotherName. *)
let id_other_name = pkix <| 8
(* rfc6120 *)
let xmpp_addr = id_other_name <| 5
(* rfc4985 *)
let srv_name = id_other_name <| 7 (* an IA5String _Service.Name *)
let venezuela = base 2 16 <| 862
let venezuela_1 = venezuela <| 2 <| 1
and venezuela_2 = venezuela <| 2 <| 2
let is_utf8_id oid =
List.mem oid [ xmpp_addr ; venezuela_1 ; venezuela_2 ]
end

238
unikernel/duniverse/ocaml-x509/lib/signing_request.ml Normal file
View file

@ -0,0 +1,238 @@
let ( let* ) = Result.bind
module Ext = struct
type _ k =
| Password : string k
| Name : string k
| Extensions : Extension.t k
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
| Password, Password -> Eq | Password, _ -> Lt | _, Password -> Gt
| Name, Name -> Eq | Name, _ -> Lt | _, Name -> Gt
| Extensions, Extensions -> Eq
end
include Gmap.Make(K)
let pp_one : type a. a k -> Format.formatter -> a -> unit = fun k ppf v ->
match k, v with
| Password, pass -> Fmt.pf ppf "password %s" pass
| Name, name -> Fmt.pf ppf "name %s" name
| Extensions, ext -> Fmt.pf ppf "extensions %a" Extension.pp ext
let pp ppf m = iter (fun (B (k, v)) -> pp_one k ppf v ; Fmt.sp ppf ()) m
end
type request_info = {
subject : Distinguished_name.t ;
public_key : Public_key.t ;
extensions : Ext.t ;
}
type request = {
info : request_info ;
signature_algorithm : Algorithm.t ;
signature : string
}
type t = {
asn : request ;
raw : string ;
}
module Asn = struct
open Asn_grammars
open Asn.S
open Registry
let attributes =
let f = function[@ocaml.warning "-8"]
| (oid, [`C1 p]) when oid = PKCS9.challenge_password -> Ext.B (Password, p)
| (oid, [`C1 n]) when oid = PKCS9.unstructured_name -> Ext.B (Name, n)
| (oid, [`C2 es]) when oid = PKCS9.extension_request -> Ext.B (Extensions, es)
and g (Ext.B (k, v)) : Asn.oid * [ `C1 of string | `C2 of Extension.t ] list = match k, v with
| Ext.Password, v -> (PKCS9.challenge_password, [`C1 v])
| Ext.Name, v -> (PKCS9.unstructured_name, [`C1 v])
| Ext.Extensions, v -> (PKCS9.extension_request, [`C2 v])
in
map f g @@
sequence2
(required ~label:"attr type" oid)
(required ~label:"attr value"
(set_of (choice2
utf8_string
Extension.Asn.extensions_der)))
let request_info =
let f = function
| (0, subject, public_key, extensions) ->
let extensions =
List.fold_left (fun map (Ext.B (k, v)) ->
match Ext.add_unless_bound k v map with
| None -> parse_error "request extension %a already bound"
(Ext.pp_one k) v
| Some b -> b)
Ext.empty extensions
in
{ subject ; public_key ; extensions }
| _ ->
parse_error "unknown certificate request info"
and g { subject ; public_key ; extensions } =
let extensions = Ext.bindings extensions in
(0, subject, public_key, extensions)
in
map f g @@
sequence4
(required ~label:"version" int)
(required ~label:"subject" Distinguished_name.Asn.name)
(required ~label:"subjectPKInfo" Public_key.Asn.pk_info_der)
(required ~label:"attributes" @@ implicit 0 (set_of attributes))
let request_info_of_str, request_info_to_str =
projections_of Asn.der request_info
let signing_request =
let f = fun (info, signature_algorithm, signature) ->
{ info ; signature_algorithm ; signature }
and g = fun { info ; signature_algorithm ; signature } ->
(info, signature_algorithm, signature)
in
map f g @@
sequence3
(required ~label:"certificationRequestInfo" request_info)
(required ~label:"signatureAlgorithm" Algorithm.identifier)
(required ~label:"signature" bit_string_octets)
let signing_request_of_str, signing_request_to_str =
projections_of Asn.der signing_request
end
let info { asn ; _ } = asn.info
let signature_algorithm { asn ; _ } =
Algorithm.to_signature_algorithm asn.signature_algorithm
let hostnames csr =
let info = info csr in
let subj =
match Distinguished_name.common_name info.subject with
| None -> Host.Set.empty
| Some x ->
match Host.host x with
| Some (typ, n) -> Host.Set.singleton (typ, n)
| None -> Host.Set.empty
in
match Ext.(find Extensions info.extensions) with
| None -> subj
| Some exts -> match Extension.hostnames exts with
| Some names -> names
| None -> subj
let validate_signature allowed_hashes { asn ; raw } =
let raw_data = Validation.raw_cert_hack raw in
Validation.validate_raw_signature asn.info.subject allowed_hashes raw_data
asn.signature_algorithm asn.signature asn.info.public_key
let decode_der ?(allowed_hashes = Validation.sha2) cs =
let* csr = Asn_grammars.err_to_msg (Asn.signing_request_of_str cs) in
let csr = { raw = cs ; asn = csr } in
let* () =
Result.map_error
(fun e -> `Msg (Fmt.to_to_string Validation.pp_signature_error e))
(validate_signature allowed_hashes csr)
in
Ok csr
let encode_der { raw ; _ } = raw
let decode_pem cs =
let* data = Pem.parse cs in
let crs =
List.filter (fun (t, _) -> String.equal "CERTIFICATE REQUEST" t) data
in
let* csrs = Pem.foldM (fun (_, cs) -> decode_der cs) crs in
Pem.exactly_one ~what:"certificate request" csrs
let encode_pem v =
Pem.unparse ~tag:"CERTIFICATE REQUEST" (encode_der v)
let digest_of_key = function
| `RSA _ -> `SHA256
| `ED25519 _ -> `SHA512
| `P256 _ -> `SHA256
| `P384 _ -> `SHA384
| `P521 _ -> `SHA512
let default_digest digest key =
match digest with None -> digest_of_key key | Some x -> x
let create subject ?digest ?(extensions = Ext.empty) (key : Private_key.t) =
let hash = default_digest digest key in
let public_key = Private_key.public key in
let info : request_info = { subject ; public_key ; extensions } in
let info_str = Asn.request_info_to_str info in
let scheme = Key_type.x509_default_scheme (Private_key.key_type key) in
let* signature = Private_key.sign hash ~scheme key (`Message info_str) in
let signature_algorithm = Algorithm.of_signature_algorithm scheme hash in
let asn = { info ; signature_algorithm ; signature } in
let raw = Asn.signing_request_to_str asn in
Ok { asn ; raw }
let sign signing_request
~valid_from ~valid_until
?(allowed_hashes = Validation.sha2)
?digest
?serial
?(extensions = Extension.empty)
?(subject = signing_request.asn.info.subject)
key issuer =
let hash = default_digest digest key in
let serial = match serial with
| Some s -> s
| None ->
(* we generate a positive integer, asn1-encoded: so if the high bit is
set, we prepend a 0 byte *)
(* if it starts with 0x00 followed by 0xNN with NN <= 0x7f, we prepend
0x7f to make the integer valid *)
let s = Mirage_crypto_rng.generate 10 in
let start = String.get_uint8 s 0 in
if start > 0x7f then
"\x00" ^ s
else if start = 0x00 && String.get_uint8 s 1 <= 0x7f then
"\x7f" ^ s
else
s
in
let* () = validate_signature allowed_hashes signing_request in
let signature_algo =
let scheme = Key_type.x509_default_scheme (Private_key.key_type key) in
Algorithm.of_signature_algorithm scheme hash
and info = signing_request.asn.info
in
let tbs_cert : Certificate.tBSCertificate = {
version = `V3 ;
serial ;
signature = signature_algo ;
issuer = issuer ;
validity = (valid_from, valid_until) ;
subject ;
pk_info = info.public_key ;
issuer_id = None ;
subject_id = None ;
extensions
} in
let tbs_raw = Certificate.Asn.tbs_certificate_to_octets tbs_cert in
let scheme = Key_type.x509_default_scheme (Private_key.key_type key) in
let* signature_val = Private_key.sign hash ~scheme key (`Message tbs_raw) in
let asn = {
Certificate.tbs_cert ;
signature_algo ;
signature_val ;
} in
let raw = Certificate.Asn.certificate_to_octets asn in
Ok { Certificate.asn ; raw }

520
unikernel/duniverse/ocaml-x509/lib/validation.ml Normal file
View file

@ -0,0 +1,520 @@
let ( let* ) = Result.bind
let sha2 = [ `SHA256 ; `SHA384 ; `SHA512 ]
let all_hashes = [ `MD5 ; `SHA1 ; `SHA224 ] @ sha2
let src = Logs.Src.create "x509.validation" ~doc:"X509 validation"
module Log = (val Logs.src_log src : Logs.LOG)
type signature_error = [
| `Bad_signature of Distinguished_name.t * string
| `Bad_encoding of Distinguished_name.t * string * string
| `Hash_not_allowed of Distinguished_name.t * [ `MD5 | `SHA1 | `SHA224 | `SHA256 | `SHA384 | `SHA512 ]
| `Unsupported_keytype of Distinguished_name.t * Public_key.t
| `Unsupported_algorithm of Distinguished_name.t * string
| `Msg of string
]
let pp_signature_error ppf = function
| `Bad_signature (subj, msg) ->
Fmt.pf ppf "failed to verify signature of %a: %s"
Distinguished_name.pp subj msg
| `Bad_encoding (subj, err, sig_) ->
Fmt.pf ppf "bad signature encoding of %a, ASN error %s:@.%a"
Distinguished_name.pp subj err Ohex.pp sig_
| `Hash_not_allowed (subj, hash) ->
Fmt.pf ppf "hash algorithm %a is not allowed, but %a is signed using it"
Certificate.pp_hash hash Distinguished_name.pp subj
| `Unsupported_keytype (subj, pk) ->
Fmt.pf ppf "unsupported key used to sign %a: %a" Distinguished_name.pp subj
Public_key.pp pk
| `Unsupported_algorithm (subj, alg) ->
Fmt.pf ppf "unsupported algorithm used to sign %a: %s"
Distinguished_name.pp subj alg
| `Msg msg -> Fmt.string ppf msg
let maybe_validate_hostname cert = function
| None -> true
| Some x -> Certificate.supports_hostname cert x
let maybe_validate_ip cert = function
| None -> true
| Some ip -> Certificate.supports_ip cert ip
let issuer_matches_subject
{ Certificate.asn = parent ; _ } { Certificate.asn = cert ; _ } =
Distinguished_name.equal parent.tbs_cert.subject cert.tbs_cert.issuer
let is_self_signed cert = issuer_matches_subject cert cert
let validate_raw_signature subject allowed_hashes msg sig_alg signature pk =
match Algorithm.to_signature_algorithm sig_alg with
| Some (scheme, siga) ->
(* we check that siga is a member of allowed_hashes, to ensure not
using a weak one. *)
if not (List.mem siga allowed_hashes) then
Error (`Hash_not_allowed (subject, siga))
else if not (Key_type.supports_signature_scheme (Public_key.key_type pk) scheme) then
Error (`Unsupported_keytype (subject, pk))
else
let* () =
Result.map_error (function `Msg m -> `Bad_signature (subject, m))
(Public_key.verify siga ~scheme ~signature pk (`Message msg))
in
if not (List.mem siga sha2) then
Log.warn (fun m -> m "%a signature uses %a, a weak hash algorithm"
Distinguished_name.pp subject Certificate.pp_hash siga);
Ok ()
| None ->
Error (`Unsupported_algorithm (subject, Algorithm.to_string sig_alg))
let shift str off =
String.sub str off (String.length str - off)
(* XXX should return the tbs_cert blob from the parser, this is insane *)
let raw_cert_hack raw =
(* we only support definite-length *)
let loff = 1 in
let snd = String.get_uint8 raw loff in
let lenl = 2 + if 0x80 land snd = 0 then 0 else 0x7F land snd in
(* cut away the SEQUENCE and LENGTH from outer sequence (tbs, sigalg, sig) *)
let cert_buf = shift raw lenl in
let rec l acc idx last =
if idx = last then
acc
else
l (acc lsl 8 + String.get_uint8 cert_buf idx) (succ idx) last
in
let cert_len_byte = String.get_uint8 cert_buf loff in
let cert_len =
(* two cases: *)
if 0x80 land cert_len_byte = 0 then
(* length < 127: highest bit is zero and lower 7 bits encode the length *)
2 + (0x7F land cert_len_byte)
else
(* length > 127: highest bit is 1 and lower 7 bits encode the bytes used
to encode the length *)
let len_len = 2 + 0x7F land cert_len_byte in
len_len + (l 0 2 len_len)
in
String.sub cert_buf 0 cert_len
let validate_signature allowed_hashes { Certificate.asn = trusted ; _ } { Certificate.asn ; raw } =
let tbs_raw = raw_cert_hack raw in
validate_raw_signature asn.tbs_cert.subject allowed_hashes tbs_raw
asn.signature_algo asn.signature_val trusted.tbs_cert.pk_info
let validate_time time { Certificate.asn = cert ; _ } =
match time with
| None -> true
| Some now ->
let (not_before, not_after) = cert.tbs_cert.validity in
Ptime.(is_later ~than:not_before now && is_earlier ~than:not_after now)
let version_matches_extensions { Certificate.asn = cert ; _ } =
let tbs = cert.tbs_cert in
match tbs.version, Extension.is_empty tbs.extensions with
| (`V1 | `V2), true -> true
| (`V1 | `V2), _ -> false
| `V3, _ -> true
let validate_path_len pathlen { Certificate.asn = cert ; _ } =
(* X509 V1/V2 certificates do not contain X509v3 extensions! *)
(* thus, we cannot check the path length. this will only ever happen for trust anchors: *)
(* intermediate CAs are checked by is_cert_valid, which checks that the CA extensions are there *)
(* whereas trust anchor are ok with getting V1/2 certificates *)
(* TODO: make it configurable whether to accept V1/2 certificates at all *)
let exts = cert.tbs_cert.extensions in
match cert.tbs_cert.version, Extension.(find Basic_constraints exts) with
| (`V1 | `V2), _ -> true
| `V3, Some (_ , (true, None)) -> true
| `V3, Some (_ , (true, Some n)) -> n >= pathlen
| _ -> false
let validate_ca_extensions { Certificate.asn = cert ; _ } =
let exts = cert.tbs_cert.extensions in
(* comments from RFC5280 *)
(* 4.2.1.9 Basic Constraints *)
(* Conforming CAs MUST include this extension in all CA certificates used *)
(* to validate digital signatures on certificates and MUST mark the *)
(* extension as critical in such certificates *)
(* unfortunately, there are 8 CA certs (including the one which
signed google.com) which are _NOT_ marked as critical *)
( match Extension.(find Basic_constraints exts) with
| Some (_ , (true, _)) -> true
| _ -> false ) &&
(* 4.2.1.3 Key Usage *)
(* Conforming CAs MUST include key usage extension *)
(* CA Cert (cacert.org) does not *)
( match Extension.(find Key_usage exts) with
(* When present, conforming CAs SHOULD mark this extension as critical *)
(* yeah, you wish... *)
| Some (_, usage) -> List.mem `Key_cert_sign usage
| _ -> false ) &&
(* if we require this, we cannot talk to github.com
(* 4.2.1.12. Extended Key Usage
If a certificate contains both a key usage extension and an extended
key usage extension, then both extensions MUST be processed
independently and the certificate MUST only be used for a purpose
consistent with both extensions. If there is no purpose consistent
with both extensions, then the certificate MUST NOT be used for any
purpose. *)
( match extn_ext_key_usage cert with
| Some (_, Ext_key_usage usages) -> List.mem Any usages
| _ -> true ) &&
*)
(* Name Constraints - name constraints should match servername *)
(* check criticality *)
Extension.for_all (fun (Extension.B (k, v)) ->
match k with
| Extension.Key_usage -> true
| Extension.Basic_constraints -> true
| _ -> not (Extension.critical k v) )
exts
let validate_server_extensions cert =
Extension.for_all (fun (Extension.B (k, v)) ->
match k, v with
| Extension.Basic_constraints, (_, (true, _)) ->
if is_self_signed cert then
(Log.warn (fun m -> m "allowing self-signed certificate with BasicConstraints CA true");
true)
else
false
| Extension.Basic_constraints, (_, (false, _)) -> true
| Extension.Key_usage, _ -> true
| Extension.Ext_key_usage, _ -> true
| Extension.Subject_alt_name, _ -> true
| Extension.Policies, (crit, ps) -> not crit || List.mem `Any ps
(* we've to deal with _all_ extensions marked critical! *)
| _, _ -> not (Extension.critical k v))
cert.Certificate.asn.tbs_cert.extensions
let valid_trust_anchor_extensions cert =
match cert.Certificate.asn.tbs_cert.version with
| `V1 | `V2 -> true
| `V3 -> validate_ca_extensions cert
let ext_authority_matches_subject trusted cert =
match Extension.(find Authority_key_id (Certificate.extensions cert),
find Subject_key_id (Certificate.extensions trusted))
with
| (_, None) | (None, _) -> true (* not mandatory *)
| Some (_, (Some auth, _, _)), Some (_, au) -> String.equal auth au
(* TODO: check exact rules in RFC5280 *)
| Some (_, (None, _, _)), _ -> true (* not mandatory *)
(* t -> t list (* set *) -> t list list *)
let rec build_paths fst rst =
match
List.filter
(fun x -> Distinguished_name.equal (Certificate.issuer fst) (Certificate.subject x))
rst
with
| [] -> [[fst]]
| xs ->
let tails =
List.fold_left
(fun acc x -> acc @ build_paths x (List.filter (fun y -> x <> y) rst))
[[]]
xs
in
List.map (fun x -> fst :: x) tails
type ca_error = [
| signature_error
| `CAIssuerSubjectMismatch of Certificate.t
| `CAInvalidVersion of Certificate.t
| `CACertificateExpired of Certificate.t * Ptime.t option
| `CAInvalidExtensions of Certificate.t
]
let pp_ca_error ppf = function
| #signature_error as e -> pp_signature_error ppf e
| `CAIssuerSubjectMismatch c ->
Fmt.pf ppf "CA certificate %a: issuer does not match subject" Certificate.pp c
| `CAInvalidVersion c ->
Fmt.pf ppf "CA certificate %a: version 3 is required for extensions" Certificate.pp c
| `CAInvalidExtensions c ->
Fmt.pf ppf "CA certificate %a: invalid CA extensions" Certificate.pp c
| `CACertificateExpired (c, now) ->
let pp_pt = Ptime.pp_human ~tz_offset_s:0 () in
Fmt.pf ppf "CA certificate %a: expired (now %a)" Certificate.pp c
Fmt.(option ~none:(any "no timestamp provided") pp_pt) now
type leaf_validation_error = [
| `LeafCertificateExpired of Certificate.t * Ptime.t option
| `LeafInvalidIP of Certificate.t * Ipaddr.t option
| `LeafInvalidName of Certificate.t * [`host] Domain_name.t option
| `LeafInvalidVersion of Certificate.t
| `LeafInvalidExtensions of Certificate.t
]
let pp_leaf_validation_error ppf = function
| `LeafCertificateExpired (c, now) ->
let pp_pt = Ptime.pp_human ~tz_offset_s:0 () in
Fmt.pf ppf "leaf certificate %a expired (now %a)" Certificate.pp c
Fmt.(option ~none:(any "no timestamp provided") pp_pt) now
| `LeafInvalidIP (c, ip) ->
Fmt.pf ppf "leaf certificate %a does not contain the IP %a (IPs present: %a)String"
Certificate.pp c Fmt.(option ~none:(any "none") Ipaddr.pp) ip
Fmt.(list ~sep:(any ", ") Ipaddr.pp) (Certificate.ips c |> Ipaddr.Set.elements)
| `LeafInvalidName (c, n) ->
Fmt.pf ppf "leaf certificate %a does not contain the name %a"
Certificate.pp c Fmt.(option ~none:(any "none") Domain_name.pp) n
| `LeafInvalidVersion c ->
Fmt.pf ppf "leaf certificate %a: version 3 is required for extensions" Certificate.pp c
| `LeafInvalidExtensions c ->
Fmt.pf ppf "leaf certificate %a: invalid server extensions" Certificate.pp c
type chain_validation_error = [
| `IntermediateInvalidExtensions of Certificate.t
| `IntermediateCertificateExpired of Certificate.t * Ptime.t option
| `IntermediateInvalidVersion of Certificate.t
| `ChainIssuerSubjectMismatch of Certificate.t * Certificate.t
| `ChainAuthorityKeyIdSubjectKeyIdMismatch of Certificate.t * Certificate.t
| `ChainInvalidPathlen of Certificate.t * int
| `EmptyCertificateChain
| `NoTrustAnchor of Certificate.t
| `Revoked of Certificate.t
]
let pp_chain_validation_error ppf = function
| `IntermediateInvalidExtensions c ->
Fmt.pf ppf "intermediate certificate %a: invalid extensions" Certificate.pp c
| `IntermediateCertificateExpired (c, now) ->
let pp_pt = Ptime.pp_human ~tz_offset_s:0 () in
Fmt.pf ppf "intermediate certificate %a expired (now %a)" Certificate.pp c
Fmt.(option ~none:(any "no timestamp provided") pp_pt) now
| `IntermediateInvalidVersion c ->
Fmt.pf ppf "intermediate certificate %a: version 3 is required for extensions"
Certificate.pp c
| `ChainIssuerSubjectMismatch (c, parent) ->
Fmt.pf ppf "invalid chain: issuer of %a does not match subject of %a"
Certificate.pp c Certificate.pp parent
| `ChainAuthorityKeyIdSubjectKeyIdMismatch (c, parent) ->
Fmt.pf ppf "invalid chain: authority key id extension of %a does not match subject key id extension of %a"
Certificate.pp c Certificate.pp parent
| `ChainInvalidPathlen (c, pathlen) ->
Fmt.pf ppf "invalid chain: the path length of %a is smaller than the required path length %d"
Certificate.pp c pathlen
| `EmptyCertificateChain -> Fmt.string ppf "certificate chain is empty"
| `NoTrustAnchor c ->
Fmt.pf ppf "no trust anchor found for %a" Certificate.pp c
| `Revoked c ->
Fmt.pf ppf "certificate %a is revoked" Certificate.pp c
type chain_error = [
| signature_error
| leaf_validation_error
| chain_validation_error
]
let pp_chain_error ppf = function
| #signature_error as e -> pp_signature_error ppf e
| #leaf_validation_error as l -> pp_leaf_validation_error ppf l
| #chain_validation_error as c -> pp_chain_validation_error ppf c
type fingerprint_validation_error = [
| `InvalidFingerprint of Certificate.t * string * string
]
let pp_fingerprint_validation_error ppf = function
| `InvalidFingerprint (c, c_fp, fp) ->
Fmt.pf ppf "fingerprint for %a (computed %a) does not match, expected %a"
Certificate.pp c Ohex.pp c_fp Ohex.pp fp
type validation_error = [
| signature_error
| leaf_validation_error
| fingerprint_validation_error
| `EmptyCertificateChain
| `InvalidChain
]
let pp_validation_error ppf = function
| #signature_error as e -> pp_signature_error ppf e
| #leaf_validation_error as l -> pp_leaf_validation_error ppf l
| #fingerprint_validation_error as f -> pp_fingerprint_validation_error ppf f
| `EmptyCertificateChain ->
Fmt.string ppf "provided certificate chain is empty"
| `InvalidChain -> Fmt.string ppf "invalid certificate chain"
type r = ((Certificate.t list * Certificate.t) option, validation_error) result
(* TODO RFC 5280: A certificate MUST NOT include more than one
instance of a particular extension. *)
let is_cert_valid now cert =
match
validate_time now cert,
version_matches_extensions cert,
validate_ca_extensions cert
with
| (true, true, true) -> Ok ()
| (false, _, _) -> Error (`IntermediateCertificateExpired (cert, now))
| (_, false, _) -> Error (`IntermediateInvalidVersion cert)
| (_, _, false) -> Error (`IntermediateInvalidExtensions cert)
let is_ca_cert_valid allowed_hashes now cert =
match
is_self_signed cert,
version_matches_extensions cert,
validate_signature allowed_hashes cert cert,
validate_time now cert,
valid_trust_anchor_extensions cert
with
| (true, true, Ok (), true, true) -> Ok ()
| (false, _, _, _, _) -> Error (`CAIssuerSubjectMismatch cert)
| (_, false, _, _, _) -> Error (`CAInvalidVersion cert)
| (_, _, Error e, _, _) -> Error e
| (_, _, _, false, _) -> Error (`CACertificateExpired (cert, now))
| (_, _, _, _, false) -> Error (`CAInvalidExtensions cert)
let valid_ca ?(allowed_hashes = all_hashes) ?time cacert =
is_ca_cert_valid allowed_hashes time cacert
let is_server_cert_valid ip host now cert =
match
validate_time now cert,
maybe_validate_ip cert ip,
maybe_validate_hostname cert host,
version_matches_extensions cert,
validate_server_extensions cert
with
| (true, true, true, true, true) -> Ok ()
| (false, _, _, _, _) -> Error (`LeafCertificateExpired (cert, now))
| (_, false, _, _, _) -> Error (`LeafInvalidIP (cert, ip))
| (_, _, false, _, _) -> Error (`LeafInvalidName (cert, host))
| (_, _, _, false, _) -> Error (`LeafInvalidVersion cert)
| (_, _, _, _, false) -> Error (`LeafInvalidExtensions cert)
let signs hash pathlen trusted cert =
match
issuer_matches_subject trusted cert,
ext_authority_matches_subject trusted cert,
validate_signature hash trusted cert,
validate_path_len pathlen trusted
with
| (true, true, Ok (), true) -> Ok ()
| (false, _, _, _) -> Error (`ChainIssuerSubjectMismatch (trusted, cert))
| (_, false, _, _) -> Error (`ChainAuthorityKeyIdSubjectKeyIdMismatch (trusted, cert))
| (_, _, Error e, _) -> Error e
| (_, _, _, false) -> Error (`ChainInvalidPathlen (trusted, pathlen))
let issuer trusted cert =
List.filter (fun p -> issuer_matches_subject p cert) trusted
let rec validate_anchors revoked hash pathlen cert = function
| [] -> Error (`NoTrustAnchor cert)
| x::xs -> match signs hash pathlen x cert with
| Ok _ -> if revoked ~issuer:x ~cert then Error (`Revoked cert) else Ok x
| Error _ -> validate_anchors revoked hash pathlen cert xs
let verify_single_chain now ?(revoked = fun ~issuer:_ ~cert:_ -> false) hash anchors chain =
let rec climb pathlen = function
| cert :: issuer :: certs ->
let* () = is_cert_valid now issuer in
let* () = if revoked ~issuer ~cert then Error (`Revoked cert) else Ok () in
let* () = signs hash pathlen issuer cert in
climb (succ pathlen) (issuer :: certs)
| [c] ->
let anchors = issuer anchors c in
validate_anchors revoked hash pathlen c anchors
| [] -> Error `EmptyCertificateChain
in
climb 0 chain
let verify_chain ?ip ~host ~time ?revoked ?(allowed_hashes = sha2) ~anchors = function
| [] -> Error `EmptyCertificateChain
| server :: certs ->
let now = time () in
let anchors = List.filter (validate_time now) anchors in
let* () = is_server_cert_valid ip host now server in
verify_single_chain now ?revoked allowed_hashes anchors (server :: certs)
let rec any_m e f = function
| [] -> Error e
| c::cs -> match f c with
| Ok ta -> Ok (Some (c, ta))
| Error _ -> any_m e f cs
let verify_chain_of_trust ?ip ~host ~time ?revoked ?(allowed_hashes = sha2) ~anchors = function
| [] -> Error `EmptyCertificateChain
| server :: certs ->
let now = time () in
(* verify server! *)
let* () = is_server_cert_valid ip host now server in
(* build all paths *)
let paths = build_paths server certs
and anchors = List.filter (validate_time now) anchors
in
(* exists there one which is good? *)
any_m `InvalidChain (verify_single_chain now ?revoked allowed_hashes anchors) paths
let valid_cas ?(allowed_hashes = all_hashes) ?time cas =
List.filter (fun cert ->
Result.is_ok (is_ca_cert_valid allowed_hashes time cert))
cas
let fingerprint_verification ?ip host now fingerprint fp = function
| [] -> Error `EmptyCertificateChain
| server::_ ->
let computed_fingerprint = fp server in
if String.equal computed_fingerprint fingerprint then
match
validate_time now server,
maybe_validate_hostname server host,
maybe_validate_ip server ip
with
| true , true , true -> Ok None
| false, _ , _ -> Error (`LeafCertificateExpired (server, now))
| _ , false, _ -> Error (`LeafInvalidName (server, host))
| _ , _ , false -> Error (`LeafInvalidIP (server, ip))
else
Error (`InvalidFingerprint (server, computed_fingerprint, fingerprint))
let trust_key_fingerprint ?ip ~host ~time ~hash ~fingerprint =
let now = time () in
let fp cert = Public_key.fingerprint ~hash (Certificate.public_key cert) in
fingerprint_verification ?ip host now fingerprint fp
let trust_cert_fingerprint ?ip ~host ~time ~hash ~fingerprint =
let now = time () in
let fp = Certificate.fingerprint hash in
fingerprint_verification ?ip host now fingerprint fp
(* RFC5246 says 'root certificate authority MAY be omitted' *)
(* TODO: how to deal with
2.16.840.1.113730.1.1 - Netscape certificate type
2.16.840.1.113730.1.12 - SSL server name
2.16.840.1.113730.1.13 - Netscape certificate comment *)
(* stuff from 4366 (TLS extensions):
- root CAs
- client cert url *)
(* Future TODO Certificate Revocation Lists and OCSP (RFC6520)
2.16.840.1.113730.1.2 - Base URL
2.16.840.1.113730.1.3 - Revocation URL
2.16.840.1.113730.1.4 - CA Revocation URL
2.16.840.1.113730.1.7 - Renewal URL
2.16.840.1.113730.1.8 - Netscape CA policy URL
2.5.4.38 - id-at-authorityRevocationList
2.5.4.39 - id-at-certificateRevocationList
do not forget about 'authority information access' (private internet extension -- 4.2.2 of 5280) *)
(* Future TODO: Policies
2.5.29.32 - Certificate Policies
2.5.29.33 - Policy Mappings
2.5.29.36 - Policy Constraints
*)
(* Future TODO: anything with subject_id and issuer_id ? seems to be not used by anybody *)

27
unikernel/duniverse/ocaml-x509/lib/x509.ml Normal file
View file

@ -0,0 +1,27 @@
module Host = Host
module Key_type = Key_type
module Public_key = Public_key
module Private_key = Private_key
module Distinguished_name = Distinguished_name
module General_name = General_name
module Certificate = Certificate
module Validation = Validation
module Extension = Extension
module Signing_request = Signing_request
module CRL = Crl
module Authenticator = Authenticator
module PKCS12 = P12
module OCSP = Ocsp

1248
unikernel/duniverse/ocaml-x509/lib/x509.mli Normal file
View file

File diff suppressed because it is too large Load diff