albatross/src/vmm_x509.ml

open Rresult.R.Infix

open Vmm_core

let asn_version = `AV1

(* 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 chain =
  separate_chain chain >>= fun (leaf, chain) ->
  let prefix = List.map name chain in
  let name = prefix @ [ name leaf ] 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 chain)) ;
  (* TODO here: inspect top-level-cert of chain.
     may need to create bridges and/or block device subdirectory (zfs create) *)
  (* let login_hdr, login_ev = Log.hdr name, `Login addr in *)
  Vmm_asn.command_of_cert asn_version leaf >>= function
  | `Info -> Ok (`Info name)
  | `Create_vm ->
    (* TODO: update acl *)
    Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config ->
    `Create_vm vm_config
  | `Force_create_vm ->
    (* TODO: update acl *)
    Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config ->
    `Force_create_vm vm_config
  | `Destroy_vm -> Ok (`Destroy_vm name)
  | `Statistics -> Ok (`Statistics name)
  | `Console -> Ok (`Console name)
  | `Log -> Ok (`Log name)
  | `Crl -> Ok `Crl
  | `Create_block ->
    Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name ->
    Vmm_asn.block_size_of_cert asn_version leaf >>| fun block_size ->
    `Create_block (block_name, block_size)
  | `Destroy_block ->
    Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name ->
    `Destroy_block block_name