This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
704
unikernel/duniverse/ocaml-x509/lib/ocsp.ml
Normal file
704
unikernel/duniverse/ocaml-x509/lib/ocsp.ml
Normal 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
|
||||
Loading…
Add table
Add a link
Reference in a new issue