72 lines
2.8 KiB
OCaml
72 lines
2.8 KiB
OCaml
(* (c) 2018 Hannes Mehnert, all rights reserved *)
|
|
|
|
open Rresult
|
|
open Rresult.R.Infix
|
|
|
|
(* we skip all non-albatross certificates *)
|
|
let name chain =
|
|
List.fold_left (fun acc cert ->
|
|
match X509.Extension.unsupported cert Vmm_asn.oid with
|
|
| None -> acc
|
|
| Some _ ->
|
|
let data = X509.common_name_to_string cert in
|
|
(* if the common name is empty, skip [useful for vmmc_bistro at least]
|
|
TODO: document properly and investigate potential security issue with
|
|
multi-tenant system (likely ca should ensure to never sign a delegation
|
|
with empty common name) *)
|
|
if data = "" then acc else data :: acc)
|
|
[] chain
|
|
|
|
(* this separates the leaf and top-level certificate from the chain,
|
|
and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA')
|
|
in which subCA' signed leaf *)
|
|
let separate_chain = function
|
|
| [] -> Error (`Msg "empty chain")
|
|
| [ leaf ] -> Ok (leaf, [])
|
|
| leaf :: xs -> Ok (leaf, List.rev xs)
|
|
|
|
let wire_command_of_cert version cert =
|
|
match X509.Extension.unsupported cert Vmm_asn.oid with
|
|
| None -> R.error_msgf "albatross OID is not present in certificate (%a)" Asn.OID.pp Vmm_asn.oid
|
|
| Some (_, data) ->
|
|
Vmm_asn.cert_extension_of_cstruct data >>= fun (v, wire) ->
|
|
if not (Vmm_commands.version_eq v version) then
|
|
R.error_msgf "unexpected version %a (expected %a)"
|
|
Vmm_commands.pp_version v
|
|
Vmm_commands.pp_version version
|
|
else
|
|
Ok wire
|
|
|
|
(* let check_policy =
|
|
(* get names and static resources *)
|
|
List.fold_left (fun acc ca ->
|
|
acc >>= fun acc ->
|
|
Vmm_asn.delegation_of_cert asn_version ca >>= fun res ->
|
|
let name = id ca in
|
|
Ok ((name, res) :: acc))
|
|
(Ok []) chain >>= fun policies ->
|
|
(* check static policies *)
|
|
Logs.debug (fun m -> m "now checking static policies") ;
|
|
check_policies vm_config (List.map snd policies) >>= fun () ->
|
|
*)
|
|
|
|
let handle _addr version chain =
|
|
separate_chain chain >>= fun (leaf, rest) ->
|
|
let name = name chain in
|
|
Logs.debug (fun m -> m "leaf is %s, chain %a"
|
|
(X509.common_name_to_string leaf)
|
|
Fmt.(list ~sep:(unit " -> ") string)
|
|
(List.map X509.common_name_to_string rest)) ;
|
|
(* TODO: inspect top-level-cert of chain. *)
|
|
(* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
|
|
(* TODO: update policies (parse chain for policy, and apply them)! *)
|
|
wire_command_of_cert version leaf >>= fun wire ->
|
|
(* we only allow some commands via certificate *)
|
|
match wire with
|
|
| `Console_cmd (`Console_subscribe _)
|
|
| `Stats_cmd `Stats_subscribe
|
|
| `Log_cmd (`Log_subscribe _)
|
|
| `Vm_cmd _
|
|
| `Policy_cmd _ -> Ok (name, wire) (* TODO policy_cmd is special (via delegation chain) *)
|
|
| _ -> Error (`Msg "unexpected command")
|