84 lines
3.3 KiB
OCaml
84 lines
3.3 KiB
OCaml
|
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))
|