reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

vmmp_request

Browse source
This commit is contained in:
Hannes Mehnert 2018-10-28 22:14:39 +01:00
parent 40519afbb7
commit 34291dbe65
6 changed files with 264 additions and 299 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

93
app/vmm_cli.ml
View file

@ -1,8 +1,40 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Astring
open Vmm_core
let setup_log style_renderer level = let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer (); Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level; Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
let create_vm force image cpuid requested_memory argv block_device network compression =
let open Rresult.R.Infix in
(Bos.OS.File.read (Fpath.v image) >>= fun s ->
Ok (Cstruct.of_string s)) >>| fun image ->
let vmimage = match compression with
| 0 -> `Hvt_amd64, image
| level ->
let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
`Hvt_amd64_compressed, Cstruct.of_string img
and argv = match argv with [] -> None | xs -> Some xs
in
let vm_config = { cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in
if force then `Vm_force_create vm_config else `Vm_create vm_config
let policy vms memory cpus block bridges =
let bridges = match bridges with
| xs ->
let add m v =
let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
String.Map.add n v m
in
List.fold_left add String.Map.empty xs
and cpuids = IS.of_list cpus
in
{ vms ; cpuids ; memory ; block ; bridges }
open Cmdliner open Cmdliner
let setup_log = let setup_log =
@ -44,13 +76,68 @@ let bridge =
| [ name ] -> `Ok (`Internal name) | [ name ] -> `Ok (`Internal name)
| _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')" | _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
in in
(parse, Vmm_core.pp_bridge) (parse, pp_bridge)
let vm_c = let vm_c =
let parse s = `Ok (Vmm_core.id_of_string s) let parse s = `Ok (id_of_string s)
in in
(parse, Vmm_core.pp_id) (parse, pp_id)
let opt_vm_name = let opt_vm_name =
let doc = "name of virtual machine." in let doc = "name of virtual machine." in
Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc) Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc)
let compress_level =
let doc = "Compression level (0 for no compression)" in
Arg.(value & opt int 4 & info [ "compression-level" ] ~doc)
let force =
let doc = "force VM creation." in
Arg.(value & flag & info [ "f" ; "force" ] ~doc)
let cpus =
let doc = "CPUs to allow" in
Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
let vms =
let doc = "Number of VMs to allow" in
Arg.(required & pos 0 (some int) None & info [] ~doc)
let block_size =
let doc = "Block storage to allow" in
Arg.(value & opt (some int) None & info [ "block" ] ~doc)
let mem =
let doc = "Memory to allow" in
Arg.(value & opt int 512 & info [ "mem" ] ~doc)
let bridge =
let doc = "Bridge to allow" in
Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc)
let cpu =
let doc = "CPUid" in
Arg.(value & opt int 0 & info [ "cpu" ] ~doc)
let args =
let doc = "Boot arguments" in
Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
let block =
let doc = "Block device name" in
Arg.(value & opt (some string) None & info [ "block" ] ~doc)
let net =
let doc = "Network device" in
Arg.(value & opt_all string [] & info [ "net" ] ~doc)
let timestamp_c =
let parse s = match Ptime.of_rfc3339 s with
| Ok (t, _, _) -> `Ok t
| Error _ -> `Error "couldn't parse timestamp"
in
(parse, Ptime.pp_rfc3339 ())
let since =
let doc = "Since" in
Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc)

105
app/vmmc_bistro.ml
View file

@ -2,10 +2,6 @@
open Lwt.Infix open Lwt.Infix
open Astring
open Vmm_core
let version = `AV2 let version = `AV2
let process fd = let process fd =
@ -52,7 +48,7 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
Vmm_lwt.read_from_file key >>= fun key_cs -> Vmm_lwt.read_from_file key >>= fun key_cs ->
let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in
let tmpkey = Nocrypto.Rsa.generate 4096 in let tmpkey = Nocrypto.Rsa.generate 4096 in
let name = string_of_id id in let name = Vmm_core.string_of_id id in
let extensions = let extensions =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None)) ; (true, `Basic_constraints (false, None))
@ -88,48 +84,26 @@ let jump endp cert key ca name cmd =
| Ok () -> `Ok () | Ok () -> `Ok ()
| Error (`Msg m) -> `Error (false, m) | Error (`Msg m) -> `Error (false, m)
let info_ _ endp cert key ca name = jump endp cert key ca name (`Vm_cmd `Vm_info) let info_ _ endp cert key ca name =
jump endp cert key ca name (`Vm_cmd `Vm_info)
let policy _ endp cert key ca name = jump endp cert key ca name (`Policy_cmd `Policy_info) let info_policy _ endp cert key ca name =
jump endp cert key ca name (`Policy_cmd `Policy_info)
let remove_policy _ endp cert key ca name = let remove_policy _ endp cert key ca name =
jump endp cert key ca name (`Policy_cmd `Policy_remove) jump endp cert key ca name (`Policy_cmd `Policy_remove)
let add_policy _ endp cert key ca name vms memory cpus block bridges = let add_policy _ endp cert key ca name vms memory cpus block bridges =
let bridges = match bridges with let p = Vmm_cli.policy vms memory cpus block bridges in
| xs -> jump endp cert key ca name (`Policy_cmd (`Policy_add p))
let add m v =
let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
String.Map.add n v m
in
List.fold_left add String.Map.empty xs
and cpuids = IS.of_list cpus
in
let policy = { vms ; cpuids ; memory ; block ; bridges } in
jump endp cert key ca name (`Policy_cmd (`Policy_add policy))
let destroy _ endp cert key ca name = let destroy _ endp cert key ca name =
jump endp cert key ca name (`Vm_cmd `Vm_destroy) jump endp cert key ca name (`Vm_cmd `Vm_destroy)
let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network = let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network compression =
let image' = match Bos.OS.File.read (Fpath.v image) with match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
| Ok data -> data | Ok cmd -> jump endp cert key ca name (`Vm_cmd cmd)
| Error (`Msg s) -> invalid_arg s | Error (`Msg msg) -> `Error (false, msg)
in
let argv = match boot_params with
| [] -> None
| xs -> Some xs
(* TODO we could do the compression btw *)
and vmimage = `Hvt_amd64, Cstruct.of_string image'
in
let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in
let cmd =
if force then
`Vm_force_create vm_config
else
`Vm_create vm_config
in
jump endp cert key ca name (`Vm_cmd cmd)
let console _ endp cert key ca name since = let console _ endp cert key ca name since =
jump endp cert key ca name (`Console_cmd (`Console_subscribe since)) jump endp cert key ca name (`Console_cmd (`Console_subscribe since))
@ -164,10 +138,6 @@ let destination =
Arg.(required & pos 0 (some host_port) None & info [] ~docv:"destination" Arg.(required & pos 0 (some host_port) None & info [] ~docv:"destination"
~doc:"the destination hostname:port to connect to") ~doc:"the destination hostname:port to connect to")
let force =
let doc = "force VM creation." in
Arg.(value & flag & info [ "f" ; "force" ] ~doc)
let image = let image =
let doc = "File of virtual machine image." in let doc = "File of virtual machine image." in
Arg.(required & pos 2 (some file) None & info [] ~doc) Arg.(required & pos 2 (some file) None & info [] ~doc)
@ -209,74 +179,27 @@ let policy_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Shows information about policies."] `P "Shows information about policies."]
in in
Term.(ret (const policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), Term.(ret (const info_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
Term.info "policy" ~doc ~man Term.info "policy" ~doc ~man
let cpus =
let doc = "CPUs to allow" in
Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
let vms =
let doc = "Number of VMs to allow" in
Arg.(required & pos 0 (some int) None & info [] ~doc)
let block =
let doc = "Block storage to allow" in
Arg.(value & opt (some int) None & info [ "block" ] ~doc)
let mem =
let doc = "Memory to allow" in
Arg.(value & opt int 512 & info [ "mem" ] ~doc)
let bridge =
let doc = "Bridge to allow" in
Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc)
let add_policy_cmd = let add_policy_cmd =
let doc = "Add a policy" in let doc = "Add a policy" in
let man = let man =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Adds a policy."] `P "Adds a policy."]
in in
Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ vms $ mem $ cpus $ block $ bridge)), Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
Term.info "add_policy" ~doc ~man Term.info "add_policy" ~doc ~man
let cpu =
let doc = "CPUid" in
Arg.(value & opt int 0 & info [ "cpu" ] ~doc)
let args =
let doc = "Boot arguments" in
Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
let block =
let doc = "Block device name" in
Arg.(value & opt (some string) None & info [ "block" ] ~doc)
let net =
let doc = "Network device" in
Arg.(value & opt_all string [] & info [ "net" ] ~doc)
let create_cmd = let create_cmd =
let doc = "creates a virtual machine" in let doc = "creates a virtual machine" in
let man = let man =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Creates a virtual machine."] `P "Creates a virtual machine."]
in in
Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net $ compress_level)),
Term.info "create" ~doc ~man Term.info "create" ~doc ~man
let timestamp_c =
let parse s = match Ptime.of_rfc3339 s with
| Ok (t, _, _) -> `Ok t
| Error _ -> `Error "couldn't parse timestamp"
in
(parse, Ptime.pp_rfc3339 ())
let since =
let doc = "Since" in
Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc)
let console_cmd = let console_cmd =
let doc = "console of a VM" in let doc = "console of a VM" in
let man = let man =

104
app/vmmc_local.ml
View file

@ -2,10 +2,6 @@
open Lwt.Infix open Lwt.Infix
open Astring
open Vmm_core
let version = `AV2 let version = `AV2
let process fd = let process fd =
@ -62,46 +58,23 @@ let jump opt_socket name cmd =
let info_ _ opt_socket name = jump opt_socket name (`Vm_cmd `Vm_info) let info_ _ opt_socket name = jump opt_socket name (`Vm_cmd `Vm_info)
let policy _ opt_socket name = jump opt_socket name (`Policy_cmd `Policy_info) let info_policy _ opt_socket name =
jump opt_socket name (`Policy_cmd `Policy_info)
let remove_policy _ opt_socket name = let remove_policy _ opt_socket name =
jump opt_socket name (`Policy_cmd `Policy_remove) jump opt_socket name (`Policy_cmd `Policy_remove)
let add_policy _ opt_socket name vms memory cpus block bridges = let add_policy _ opt_socket name vms memory cpus block bridges =
let bridges = match bridges with let p = Vmm_cli.policy vms memory cpus block bridges in
| xs -> jump opt_socket name (`Policy_cmd (`Policy_add p))
let add m v =
let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
String.Map.add n v m
in
List.fold_left add String.Map.empty xs
and cpuids = IS.of_list cpus
in
let policy = { vms ; cpuids ; memory ; block ; bridges } in
jump opt_socket name (`Policy_cmd (`Policy_add policy))
let destroy _ opt_socket name = let destroy _ opt_socket name =
jump opt_socket name (`Vm_cmd `Vm_destroy) jump opt_socket name (`Vm_cmd `Vm_destroy)
let create _ opt_socket force name image cpuid requested_memory boot_params block_device network = let create _ opt_socket force name image cpuid requested_memory boot_params block_device network compression =
let image' = match Bos.OS.File.read (Fpath.v image) with match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
| Ok data -> data | Ok cmd -> jump opt_socket name (`Vm_cmd cmd)
| Error (`Msg s) -> invalid_arg s | Error (`Msg msg) -> `Error (false, msg)
in
let argv = match boot_params with
| [] -> None
| xs -> Some xs
(* TODO we could do the compression btw *)
and vmimage = `Hvt_amd64, Cstruct.of_string image'
in
let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in
let cmd =
if force then
`Vm_force_create vm_config
else
`Vm_create vm_config
in
jump opt_socket name (`Vm_cmd cmd)
let console _ opt_socket name since = let console _ opt_socket name since =
jump opt_socket name (`Console_cmd (`Console_subscribe since)) jump opt_socket name (`Console_cmd (`Console_subscribe since))
@ -124,10 +97,6 @@ let socket =
let doc = "Socket to connect to" in let doc = "Socket to connect to" in
Arg.(value & opt (some string) None & info [ "socket" ] ~doc) Arg.(value & opt (some string) None & info [ "socket" ] ~doc)
let force =
let doc = "force VM creation." in
Arg.(value & flag & info [ "f" ; "force" ] ~doc)
let image = let image =
let doc = "File of virtual machine image." in let doc = "File of virtual machine image." in
Arg.(required & pos 1 (some file) None & info [] ~doc) Arg.(required & pos 1 (some file) None & info [] ~doc)
@ -169,74 +138,27 @@ let policy_cmd =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Shows information about policies."] `P "Shows information about policies."]
in in
Term.(ret (const policy $ setup_log $ socket $ opt_vm_name)), Term.(ret (const info_policy $ setup_log $ socket $ opt_vm_name)),
Term.info "policy" ~doc ~man Term.info "policy" ~doc ~man
let cpus =
let doc = "CPUs to allow" in
Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
let vms =
let doc = "Number of VMs to allow" in
Arg.(required & pos 0 (some int) None & info [] ~doc)
let block =
let doc = "Block storage to allow" in
Arg.(value & opt (some int) None & info [ "block" ] ~doc)
let mem =
let doc = "Memory to allow" in
Arg.(value & opt int 512 & info [ "mem" ] ~doc)
let bridge =
let doc = "Bridge to allow" in
Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc)
let add_policy_cmd = let add_policy_cmd =
let doc = "Add a policy" in let doc = "Add a policy" in
let man = let man =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Adds a policy."] `P "Adds a policy."]
in in
Term.(ret (const add_policy $ setup_log $ socket $ opt_vm_name $ vms $ mem $ cpus $ block $ bridge)), Term.(ret (const add_policy $ setup_log $ socket $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
Term.info "add_policy" ~doc ~man Term.info "add_policy" ~doc ~man
let cpu =
let doc = "CPUid" in
Arg.(value & opt int 0 & info [ "cpu" ] ~doc)
let args =
let doc = "Boot arguments" in
Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
let block =
let doc = "Block device name" in
Arg.(value & opt (some string) None & info [ "block" ] ~doc)
let net =
let doc = "Network device" in
Arg.(value & opt_all string [] & info [ "net" ] ~doc)
let create_cmd = let create_cmd =
let doc = "creates a virtual machine" in let doc = "creates a virtual machine" in
let man = let man =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Creates a virtual machine."] `P "Creates a virtual machine."]
in in
Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net $ compress_level)),
Term.info "create" ~doc ~man Term.info "create" ~doc ~man
let timestamp_c =
let parse s = match Ptime.of_rfc3339 s with
| Ok (t, _, _) -> `Ok t
| Error _ -> `Error "couldn't parse timestamp"
in
(parse, Ptime.pp_rfc3339 ())
let since =
let doc = "Since" in
Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc)
let console_cmd = let console_cmd =
let doc = "console of a VM" in let doc = "console of a VM" in
let man = let man =
@ -272,13 +194,13 @@ let help_cmd =
let doc = "display help about vmmc" in let doc = "display help about vmmc" in
let man = let man =
[`S "DESCRIPTION"; [`S "DESCRIPTION";
`P "Prints help about conex commands and subcommands"] `P "Prints help about albatross local client commands and subcommands"]
in in
Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ topic)), Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ topic)),
Term.info "help" ~doc ~man Term.info "help" ~doc ~man
let default_cmd = let default_cmd =
let doc = "VMM client" in let doc = "VMM local client" in
let man = [ let man = [
`S "DESCRIPTION" ; `S "DESCRIPTION" ;
`P "$(tname) connects to vmmd via a local socket" ] `P "$(tname) connects to vmmd via a local socket" ]

246
app/vmmp_request.ml
View file

@ -1,134 +1,180 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *) (* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Vmm_provision open Vmm_provision
open Vmm_asn
open Rresult.R.Infix open Rresult.R.Infix
open Vmm_asn let version = `AV2
let vm_csr key name image cpuid requested_memory argv block_device network force compression = let csr priv name cmd =
let vm_config = let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (version, cmd))) ]
let vmimage = match compression with
| 0 -> `Hvt_amd64, image
| level ->
let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
`Hvt_amd64_compressed, Cstruct.of_string img
and argv = match argv with [] -> None | xs -> Some xs
in
Vmm_core.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage }
in
let cmd = if force then `Vm_force_create vm_config else `Vm_create vm_config in
let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, `Vm_cmd cmd))) ]
and name = [ `CN name ] and name = [ `CN name ]
in in
X509.CA.request name ~extensions:[`Extensions exts] key X509.CA.request name ~extensions:[`Extensions exts] priv
let jump _ name key image mem cpu args block net force compression = let jump id cmd =
Nocrypto_entropy_unix.initialize () ; Nocrypto_entropy_unix.initialize () ;
let name = Vmm_core.string_of_id id in
match match
priv_key key name >>= fun key -> priv_key None name >>= fun priv ->
(Bos.OS.File.read (Fpath.v image) >>= fun s -> let csr = csr priv name cmd in
Ok (Cstruct.of_string s)) >>= fun image ->
let csr = vm_csr key name image cpu mem args block net force compression in
let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in
Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc) Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
with with
| Ok () -> `Ok () | Ok () -> `Ok ()
| Error (`Msg m) -> `Error (false, m) | Error (`Msg m) -> `Error (false, m)
(* (c) 2017 Hannes Mehnert, all rights reserved *) let info_ _ name = jump name (`Vm_cmd `Vm_info)
(*
open Vmm_provision
open Vmm_asn
open Rresult.R.Infix let info_policy _ name =
jump name (`Policy_cmd `Policy_info)
open Astring let remove_policy _ name =
jump name (`Policy_cmd `Policy_remove)
let subca_csr key name cpus memory vms block bridges = let add_policy _ name vms memory cpus block bridges =
let cpuids = Vmm_core.IS.of_list cpus let p = Vmm_cli.policy vms memory cpus block bridges in
and bridges = List.fold_left (fun acc b -> match b with jump name (`Policy_cmd (`Policy_add p))
| `Internal name -> String.Map.add name b acc
| `External (name, _, _, _, _) -> String.Map.add name b acc)
String.Map.empty bridges
in
let policy = Vmm_core.{ vms ; cpuids ; memory ; block ; bridges } in
let cmd = `Policy_cmd (`Policy_add policy) in
let exts =
[ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, cmd))) ]
and name = [ `CN name ]
in
X509.CA.request name ~extensions:[`Extensions exts] key
let jump _ name key vms mem cpus block bridges = let destroy _ name =
Nocrypto_entropy_unix.initialize () ; jump name (`Vm_cmd `Vm_destroy)
match
priv_key key name >>= fun key -> let create _ force name image cpuid requested_memory boot_params block_device network compression =
let csr = subca_csr key name cpus mem vms block bridges in match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in | Ok cmd -> jump name (`Vm_cmd cmd)
Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc) | Error (`Msg msg) -> `Error (false, msg)
with
| Ok () -> `Ok () let console _ name since =
| Error (`Msg m) -> `Error (false, m) jump name (`Console_cmd (`Console_subscribe since))
let stats _ name =
jump name (`Stats_cmd `Stats_subscribe)
let event_log _ name since =
jump name (`Log_cmd (`Log_subscribe since))
let help _ man_format cmds = function
| None -> `Help (`Pager, None)
| Some t when List.mem t cmds -> `Help (man_format, Some t)
| Some _ -> List.iter print_endline cmds; `Ok ()
open Cmdliner open Cmdliner
open Vmm_cli open Vmm_cli
let cpus =
let doc = "CPUids to provision" in
Arg.(value & opt_all int [] & info [ "cpu" ] ~doc)
let vms =
let doc = "Number of VMs to provision" in
Arg.(required & pos 1 (some int) None & info [] ~doc)
let block =
let doc = "Block storage to provision" in
Arg.(value & opt (some int) None & info [ "block" ] ~doc)
let bridge =
let doc = "Bridge to provision" in
Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)),
Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1
*)
open Cmdliner
open Vmm_cli
let cpu =
let doc = "CPUid" in
Arg.(required & pos 3 (some int) None & info [] ~doc)
let image = let image =
let doc = "Image file to provision" in let doc = "File of virtual machine image." in
Arg.(required & pos 1 (some file) None & info [] ~doc) Arg.(required & pos 1 (some file) None & info [] ~doc)
let args = let vm_name =
let doc = "Boot arguments" in let doc = "Name virtual machine." in
Arg.(value & opt_all string [] & info [ "arg" ] ~doc) Arg.(required & pos 0 (some vm_c) None & info [] ~doc)
let block = let destroy_cmd =
let doc = "Block device name" in let doc = "destroys a virtual machine" in
Arg.(value & opt (some string) None & info [ "block" ] ~doc) let man =
[`S "DESCRIPTION";
`P "Destroy a virtual machine."]
in
Term.(ret (const destroy $ setup_log $ vm_name)),
Term.info "destroy" ~doc ~man
let net = let remove_policy_cmd =
let doc = "Network device" in let doc = "removes a policy" in
Arg.(value & opt_all string [] & info [ "net" ] ~doc) let man =
[`S "DESCRIPTION";
`P "Removes a policy."]
in
Term.(ret (const remove_policy $ setup_log $ opt_vm_name)),
Term.info "remove_policy" ~doc ~man
let force = let info_cmd =
let doc = "Force creation (destroy VM with same name if it exists)" in let doc = "information about VMs" in
Arg.(value & flag & info [ "force" ] ~doc) let man =
[`S "DESCRIPTION";
`P "Shows information about VMs."]
in
Term.(ret (const info_ $ setup_log $ opt_vm_name)),
Term.info "info" ~doc ~man
let compress_level = let policy_cmd =
let doc = "Compression level (0 for no compression)" in let doc = "active policies" in
Arg.(value & opt int 4 & info [ "compression-level" ] ~doc) let man =
[`S "DESCRIPTION";
`P "Shows information about policies."]
in
Term.(ret (const info_policy $ setup_log $ opt_vm_name)),
Term.info "policy" ~doc ~man
let cmd = let add_policy_cmd =
Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)), let doc = "Add a policy" in
Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" let man =
[`S "DESCRIPTION";
`P "Adds a policy."]
in
Term.(ret (const add_policy $ setup_log $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
Term.info "add_policy" ~doc ~man
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 let create_cmd =
let doc = "creates a virtual machine" in
let man =
[`S "DESCRIPTION";
`P "Creates a virtual machine."]
in
Term.(ret (const create $ setup_log $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net $ compress_level)),
Term.info "create" ~doc ~man
let console_cmd =
let doc = "console of a VM" in
let man =
[`S "DESCRIPTION";
`P "Shows console output of a VM."]
in
Term.(ret (const console $ setup_log $ vm_name $ since)),
Term.info "console" ~doc ~man
let stats_cmd =
let doc = "statistics of VMs" in
let man =
[`S "DESCRIPTION";
`P "Shows statistics of VMs."]
in
Term.(ret (const stats $ setup_log $ opt_vm_name)),
Term.info "stats" ~doc ~man
let log_cmd =
let doc = "Event log" in
let man =
[`S "DESCRIPTION";
`P "Shows event log of VM."]
in
Term.(ret (const event_log $ setup_log $ opt_vm_name $ since)),
Term.info "log" ~doc ~man
let help_cmd =
let topic =
let doc = "The topic to get help on. `topics' lists the topics." in
Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
in
let doc = "display help about vmmc" in
let man =
[`S "DESCRIPTION";
`P "Prints help about albatross local client commands and subcommands"]
in
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ topic)),
Term.info "help" ~doc ~man
let default_cmd =
let doc = "VMM local client" in
let man = [
`S "DESCRIPTION" ;
`P "$(tname) connects to vmmd via a local socket" ]
in
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man
let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
let () =
match Term.eval_choice default_cmd cmds
with `Ok () -> exit 0 | _ -> exit 1

13
src/vmm_tls.ml
View file

@ -42,19 +42,6 @@ let wire_command_of_cert version cert =
else else
Ok wire 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 extract_policies version chain = let extract_policies version chain =
List.fold_left (fun acc cert -> List.fold_left (fun acc cert ->
match acc, wire_command_of_cert version cert with match acc, wire_command_of_cert version cert with

2
src/vmm_tls.mli
View file

@ -6,5 +6,5 @@ val wire_command_of_cert : Vmm_commands.version -> X509.t ->
val handle : val handle :
'a -> Vmm_commands.version -> 'a -> Vmm_commands.version ->
X509.t list -> X509.t list ->
(string list * (Vmm_core.id * Vmm_core.policy) list * Vmm_commands.t, (Vmm_core.id * (Vmm_core.id * Vmm_core.policy) list * Vmm_commands.t,
[> `Msg of string ]) Result.result [> `Msg of string ]) Result.result