albatross/src/vmm_x509.ml

54 lines
1.9 KiB
OCaml
Raw Normal View History

2018-10-13 23:02:52 +00:00
open Astring
open Rresult.R.Infix
open Vmm_core
let asn_version = `AV1
2018-10-14 00:18:33 +00:00
(* 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 () ->
2018-10-13 23:02:52 +00:00
*)
2018-10-14 00:18:33 +00:00
let handle addr chain =
separate_chain chain >>= fun (leaf, chain) ->
2018-10-13 23:02:52 +00:00
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)
2018-10-13 23:02:52 +00:00
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) *)
2018-10-13 23:02:52 +00:00
(* let login_hdr, login_ev = Log.hdr name, `Login addr in *)
2018-10-14 00:18:33 +00:00
Vmm_asn.command_of_cert asn_version leaf >>= function
| `Info -> Ok (`Info name)
2018-10-13 23:02:52 +00:00
| `Create_vm ->
(* TODO: update acl *)
2018-10-14 00:18:33 +00:00
Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config ->
`Create_vm vm_config
2018-10-13 23:02:52 +00:00
| `Force_create_vm ->
(* TODO: update acl *)
2018-10-14 00:18:33 +00:00
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