move stuff around

This commit is contained in:
Hannes Mehnert 2018-10-25 16:55:54 +02:00
parent 85a507db54
commit 01f933702d
33 changed files with 231 additions and 227 deletions

View file

@ -1,9 +1,22 @@
# Albatross: Managing virtual machines
# Albatross: orchestrate and manage MirageOS unikernels
[![Build Status](https://travis-ci.org/hannesm/albatross.svg?branch=master)](https://travis-ci.org/hannesm/albatross)
A set of binaries to manage, provision, and deploy virtual machine images. This
is very much work in progress, don't expect anything stable.
A set of binaries to manage, provision, and deploy MirageOS unikernels.
Some daemons are supposed to run in the host system, communicating via Unix domain sockets:
- `vmmd`: privileged to create and destroy unikernels (also creates tap devices and attaches these to bridges)
- `vmmd_console`: reads the console output of unikernels (via a fifo passed from `vmmd`)
- `vmmd_log`: event log
- `vmmd_stats`: statistics (`getrusage`, ifstat, BHyve debug counters) gathering
- `vmmd_tls`: authenticates and proxies commands carried by a client certificate
- `vmmd_influx`: reports statistics from stats to influx listener
Command-line applications for local and remote management are provided as well
- `vmmc_local`: executes a command locally via Unix domain sockets
- `vmmc_remote`: connects to `vmm_tls_endpoint` and executes command
- `vmmc_bistro`: command line utility to execute a command remotely: request, sign, remote (do not use in production, requires CA key on host)
- `vmmp_request`: creates a certificate signing request containing a command
- `vmmp_sign`: signs a certificate signing request
Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation
and an overview.

24
_tags
View file

@ -1,20 +1,24 @@
true : bin_annot, safe_string, principal, color(always)
true : warn(+A-4-44-48)
true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration cstruct)
true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decompress asn1-combinators)
"src" : include
<src/vmm_compress.ml>: package(decompress)
<src/vmm_asn.{ml,mli}>: package(asn1-combinators)
<src/vmm_lwt.{ml,mli}>: package(lwt lwt.unix)
<src/vmm_tls_lwt.{ml,mli}>: package(lwt tls.lwt)
<src/vmm_tls.{ml,mli}>: package(x509)
<src/vmm_vmmd.{ml,mli}>: package(ptime.clock.os)
<app/*>: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress)
<app/vmm_client.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
<app/vmm_tls_endpoint.{ml,native,byte}>: package(tls.lwt)
<app/vmm_prometheus_stats.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
<app/*>: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix)
<app/vmmd.{ml,native,byte}>: package(ptime.clock.os)
<app/vmmd_console.{ml,native,byte}>: package(ptime.clock.os)
<app/vmmd_log.{ml,native,byte}>: package(ptime.clock.os)
<app/vmmd_tls.{ml,native,byte}>: package(tls.lwt ptime.clock.os)
<app/vmmd_stats.{ml,native,byte}>: link_vmm_stats, package(asn1-combinators)
<provision/*>: package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt decompress)
<app/vmmc_remote.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
<app/vmmp_request.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)
<app/vmmp_sign.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)
<app/vmm_provision.{ml}>: package(nocrypto.unix ptime.clock.os x509)
<stats/vmm_stats_lwt.{ml,native,byte}>: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt decompress)
<stats/vmm_stats_once.{ml,native,byte}>: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt decompress)

0
app/vmmc_bistro.ml Normal file
View file

View file

@ -326,7 +326,7 @@ let default_cmd =
`P "$(tname) connects to vmmd via a local socket" ]
in
Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man
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 ]

View file

@ -14,6 +14,12 @@ let client cas host port cert priv_key =
let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in
X509_lwt.authenticator auth >>= fun authenticator ->
Lwt.catch (fun () ->
(* TODO TLS certificate verification and gethostbyname:
- allow IP address and hostname
- if IP is specified, use it (and no TLS name verification - or SubjAltName with IP?)
- if hostname is specified
- no ip: gethostbyname
- ip: connecto to ip and verify hostname *)
Lwt_unix.gethostbyname host >>= fun host_entry ->
let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in
let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in
@ -88,7 +94,7 @@ let cmd =
`P "$(tname) connects to a server and initiates a TLS handshake" ]
in
Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination),
Term.info "vmm_client" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.info "vmmd_remote" ~version:"%%VERSION_NUM%%" ~doc ~man
let () =
match Term.eval cmd

View file

@ -189,6 +189,6 @@ let socket =
let cmd =
Term.(ret (const jump $ setup_log $ socket)),
Term.info "vmm_console" ~version:"%%VERSION_NUM%%"
Term.info "vmmd_console" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -328,7 +328,7 @@ let cmd =
`P "$(tname) connects to a vmm stats socket, pulls statistics and pushes them via TCP to influxdb" ]
in
Term.(pure run_client $ setup_log $ socket $ influx $ opt_vmname),
Term.info "vmm_influxdb_stats" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.info "vmmd_influx" ~version:"%%VERSION_NUM%%" ~doc ~man
let () =
match Term.eval cmd

View file

@ -14,7 +14,9 @@
open Lwt.Infix
let t = ref (Vmm_stats.empty ())
open Vmm_stats_pure
let t = ref (empty ())
let pp_sockaddr ppf = function
| Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
@ -29,7 +31,7 @@ let handle s addr () =
Logs.err (fun m -> m "exception while reading") ;
Lwt.return pids
| Ok wire ->
match Vmm_stats.handle !t s wire with
match handle !t s wire with
| Error (`Msg msg) ->
Vmm_lwt.write_wire s (fst wire, `Failure msg) >>= fun _ ->
Lwt.return pids
@ -56,17 +58,17 @@ let handle s addr () =
loop [] >>= fun vmids ->
Vmm_lwt.safe_close s >|= fun () ->
Logs.warn (fun m -> m "disconnect, dropping %d vms!" (List.length vmids)) ;
let t' = Vmm_stats.remove_vmids !t vmids in
let t' = remove_vmids !t vmids in
t := t'
let rec timer interval () =
let t', outs = Vmm_stats.tick !t in
let t', outs = tick !t in
t := t' ;
Lwt_list.iter_p (fun (s, name, stat) ->
Vmm_lwt.write_wire s stat >>= function
| Ok () -> Lwt.return_unit
| Error `Exception ->
t := Vmm_stats.remove_entry !t name ;
t := remove_entry !t name ;
Vmm_lwt.safe_close s)
outs >>= fun () ->
Lwt_unix.sleep interval >>= fun () ->
@ -113,6 +115,6 @@ let interval =
let cmd =
Term.(ret (const jump $ setup_log $ socket $ interval)),
Term.info "vmm_stats" ~version:"%%VERSION_NUM%%"
Term.info "vmmd_stats" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -167,6 +167,6 @@ let port =
let cmd =
Term.(ret (const jump $ setup_log $ cacert $ cert $ key $ port)),
Term.info "vmm_tls_endpoint" ~version:"%%VERSION_NUM%%"
Term.info "vmmd_tls" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,5 +1,78 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Rresult.R.Infix
open Vmm_asn
let vm_csr key name image cpuid requested_memory argv block_device network force compression =
let vm_config =
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 ]
in
X509.CA.request name ~extensions:[`Extensions exts] key
let jump _ name key image mem cpu args block net force compression =
Nocrypto_entropy_unix.initialize () ;
match
priv_key key name >>= fun key ->
(Bos.OS.File.read (Fpath.v image) >>= fun s ->
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
Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
with
| Ok () -> `Ok ()
| Error (`Msg m) -> `Error (false, m)
open Cmdliner
let cpu =
let doc = "CPUid" in
Arg.(required & pos 3 (some int) None & info [] ~doc)
let image =
let doc = "Image file to provision" in
Arg.(required & pos 1 (some file) None & info [] ~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 force =
let doc = "Force creation (destroy VM with same name if it exists)" in
Arg.(value & flag & info [ "force" ] ~doc)
let compress_level =
let doc = "Compression level (0 for no compression)" in
Arg.(value & opt int 4 & info [ "compression-level" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)),
Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Vmm_asn
@ -77,6 +150,6 @@ let bridge =
let cmd =
Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)),
Term.info "vmm_req_delegation" ~version:"%%VERSION_NUM%%"
Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -67,6 +67,56 @@ let key =
let cmd =
Term.(ret (const jump $ setup_log $ db $ cacert $ key $ csr $ days)),
Term.info "vmm_sign" ~version:"%%VERSION_NUM%%"
Term.info "vmmp_sign" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Rresult.R.Infix
let s_exts =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Server_auth]) ]
let jump _ name db days sname sdays =
Nocrypto_entropy_unix.initialize () ;
match
priv_key ~bits:4096 None name >>= fun key ->
let name = [ `CN name ] in
let csr = X509.CA.request name key in
sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
priv_key None sname >>= fun skey ->
let sname = [ `CN sname ] in
let csr = X509.CA.request sname skey in
sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
with
| Ok () -> `Ok ()
| Error (`Msg e) -> `Error (false, e)
open Cmdliner
let days =
let doc = "Number of days" in
Arg.(value & opt int 3650 & info [ "days" ] ~doc)
let db =
let doc = "Database" in
Arg.(required & pos 1 (some string) None & info [] ~doc)
let sname =
let doc = "Server name" in
Arg.(value & opt string "server" & info [ "server" ] ~doc)
let sday =
let doc = "Server validity" in
Arg.(value & opt int 365 & info [ "server-days" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ nam $ db $ days $ sname $ sday)),
Term.info "vmmp_sign" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -19,8 +19,8 @@ let () =
flag ["link"; "library"; "ocaml"; "native"; "use_vmm_stats"]
(S ([A "-cclib"; A "-lvmm_stats_stubs"]));
flag ["link"; "ocaml"; "link_vmm_stats"]
(S ([A "stats/libvmm_stats_stubs.a"] @ vmm_lib));
dep ["link"; "ocaml"; "use_vmm_stats"] ["stats/libvmm_stats_stubs.a"];
dep ["link"; "ocaml"; "link_vmm_stats"] ["stats/libvmm_stats_stubs.a"];
(S ([A "app/libvmm_stats_stubs.a"] @ vmm_lib));
dep ["link"; "ocaml"; "use_vmm_stats"] ["app/libvmm_stats_stubs.a"];
dep ["link"; "ocaml"; "link_vmm_stats"] ["app/libvmm_stats_stubs.a"];
| _ -> ()
end

11
opam
View file

@ -1,12 +1,12 @@
opam-version: "1.2"
opam-version: "2.0"
maintainer: "Hannes Mehnert <hannes@mehnert.org>"
authors: ["Hannes Mehnert <hannes@mehnert.org>"]
homepage: "https://github.com/hannesm/vmm"
dev-repo: "https://github.com/hannesm/vmm.git"
bug-reports: "https://github.com/hannesm/vmm/issues"
available: [ ocaml-version >= "4.05.0"]
homepage: "https://github.com/hannesm/albatross"
dev-repo: "git+https://github.com/hannesm/albatross.git"
bug-reports: "https://github.com/hannesm/albatross/issues"
depends: [
"ocaml" {>= "4.05.0"}
"ocamlfind" {build}
"ocamlbuild" {build}
"topkg" {build}
@ -32,3 +32,4 @@ depends: [
build: [
[ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ]
]
synopsis: "Albatross - orchestrate and manage MirageOS unikernels"

View file

@ -23,15 +23,15 @@ for f in albatross_log \
do install -U $basedir/packaging/rc.d/$f $rootdir/usr/local/etc/rc.d/$f; done
# stage albatross app binaries
for f in vmmd vmm_log vmm_console; do
for f in vmmd vmmd_log vmmd_console; do
install -U $basedir/_build/app/$f.native \
$rootdir/usr/local/libexec/albatross/$f; done
install -U $basedir/_build/stats/vmm_stats_lwt.native \
$rootdir/usr/local/libexec/albatross/vmm_stats_lwt
install -U $basedir/_build/app/vmmd_stats.native \
$rootdir/usr/local/libexec/albatross/vmmd_stats
install -U $basedir/_build/app/vmmc.native \
$rootdir/usr/local/sbin/vmmc
install -U $basedir/_build/app/vmm_local.native \
$rootdir/usr/local/sbin/vmm_local
# create +MANIFEST
flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + |

View file

@ -29,7 +29,7 @@ start_cmd="albatross_console_start"
: ${albatross_console_user:="albatross"}
pidfile="/var/run/albatross_console.pid"
procname="/usr/local/libexec/albatross/vmm_console"
procname="/usr/local/libexec/albatross/vmmd_console"
albatross_console_start () {
/usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_console_user}" \

View file

@ -30,7 +30,7 @@ start_precmd="albatross_log_precmd"
: ${albatross_log_user:="albatross"}
pidfile="/var/run/albatross_log.pid"
procname="/usr/local/libexec/albatross/vmm_log"
procname="/usr/local/libexec/albatross/vmmd_log"
logfile="/var/log/albatross"
albatross_log_precmd () {

View file

@ -29,7 +29,7 @@ start_cmd="albatross_stat_start"
: ${albatross_stat_user:="albatross"}
pidfile="/var/run/albatross_stat.pid"
procname="/usr/local/libexec/albatross/vmm_stats_lwt"
procname="/usr/local/libexec/albatross/vmmd_stats"
albatross_stat_start () {
/usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_stat_user}" \

View file

@ -1,7 +1,2 @@
description = "VM Manager"
version = "%%VERSION_NUM%%"
requires = "rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration asn1-combinators lwt tls.lwt decompress"
archive(byte) = "vmm.cma"
archive(native) = "vmm.cmxa"
plugin(byte) = "vmm.cma"
plugin(native) = "vmm.cmxs"

View file

@ -6,18 +6,15 @@ open Topkg
let () =
Pkg.describe "albatross" @@ fun _ ->
Ok [
Pkg.mllib "src/albatross.mllib" ;
Pkg.bin "app/vmmd" ;
Pkg.bin "app/vmm_console" ;
Pkg.bin "app/vmm_log" ;
Pkg.bin "app/vmm_client" ;
Pkg.bin "app/vmm_tls_endpoint" ;
Pkg.bin "app/vmmc" ;
Pkg.bin "provision/vmm_req_delegation" ;
Pkg.bin "provision/vmm_req_vm" ;
Pkg.bin "provision/vmm_sign" ;
Pkg.bin "provision/vmm_gen_ca" ;
(* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *)
Pkg.bin "stats/vmm_stats_lwt" ;
Pkg.bin "app/vmm_influxdb_stats" ;
Pkg.bin "app/vmmd_console" ;
Pkg.bin "app/vmmd_log" ;
Pkg.bin "app/vmmd_stats" ;
Pkg.bin "app/vmmd_tls" ;
Pkg.bin "app/vmmd_influx" ;
Pkg.bin "app/vmmc_local" ;
Pkg.bin "app/vmmc_remote" ;
Pkg.bin "app/vmmc_bistro" ;
Pkg.bin "app/vmmp_request" ;
Pkg.bin "app/vmmp_sign" ;
]

View file

@ -1,50 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Rresult.R.Infix
let s_exts =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Server_auth]) ]
let jump _ name db days sname sdays =
Nocrypto_entropy_unix.initialize () ;
match
priv_key ~bits:4096 None name >>= fun key ->
let name = [ `CN name ] in
let csr = X509.CA.request name key in
sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
priv_key None sname >>= fun skey ->
let sname = [ `CN sname ] in
let csr = X509.CA.request sname skey in
sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays)
with
| Ok () -> `Ok ()
| Error (`Msg e) -> `Error (false, e)
open Cmdliner
let days =
let doc = "Number of days" in
Arg.(value & opt int 3650 & info [ "days" ] ~doc)
let db =
let doc = "Database" in
Arg.(required & pos 1 (some string) None & info [] ~doc)
let sname =
let doc = "Server name" in
Arg.(value & opt string "server" & info [ "server" ] ~doc)
let sday =
let doc = "Server validity" in
Arg.(value & opt int 365 & info [ "server-days" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ nam $ db $ days $ sname $ sday)),
Term.info "vmm_gen_ca" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,73 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Rresult.R.Infix
open Vmm_asn
let vm_csr key name image cpuid requested_memory argv block_device network force compression =
let vm_config =
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 ]
in
X509.CA.request name ~extensions:[`Extensions exts] key
let jump _ name key image mem cpu args block net force compression =
Nocrypto_entropy_unix.initialize () ;
match
priv_key key name >>= fun key ->
(Bos.OS.File.read (Fpath.v image) >>= fun s ->
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
Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
with
| Ok () -> `Ok ()
| Error (`Msg m) -> `Error (false, m)
open Cmdliner
let cpu =
let doc = "CPUid" in
Arg.(required & pos 3 (some int) None & info [] ~doc)
let image =
let doc = "Image file to provision" in
Arg.(required & pos 1 (some file) None & info [] ~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 force =
let doc = "Force creation (destroy VM with same name if it exists)" in
Arg.(value & flag & info [ "force" ] ~doc)
let compress_level =
let doc = "Compression level (0 for no compression)" in
Arg.(value & opt int 4 & info [ "compression-level" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)),
Term.info "vmm_req_vm" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,12 +0,0 @@
Vmm_asn
Vmm_lwt
Vmm_tls_lwt
Vmm_tls
Vmm_vmmd
Vmm_commands
Vmm_core
Vmm_resources
Vmm_trie
Vmm_unix
Vmm_compress
Vmm_ring

View file

@ -440,14 +440,16 @@ let log_disk =
(required ~label:"version" version)
(required ~label:"entry" log_entry))
let log_disk_of_cstruct, log_disk_to_cstruct = projections_of log_disk
let log_disk_of_cstruct, log_disk_to_cstruct =
let c = Asn.codec Asn.der log_disk in
(Asn.decode c, Asn.encode c)
let log_to_disk version entry =
log_disk_to_cstruct (version, entry)
let logs_of_disk version buf =
let rec next acc buf =
match Asn.decode (Asn.codec Asn.der log_disk) buf with
match log_disk_of_cstruct buf with
| Ok ((version', entry), cs) ->
let acc' =
if Vmm_commands.version_eq version version' then
@ -471,13 +473,3 @@ let cert_extension =
let cert_extension_of_cstruct, cert_extension_to_cstruct =
projections_of cert_extension
let wire_command_of_cert version cert =
match X509.Extension.unsupported cert oid with
| None -> R.error_msgf "albatross OID is not present in certificate (%a)" Asn.OID.pp oid
| Some (_, data) ->
cert_extension_of_cstruct data >>= fun (v, wire) ->
if not (version_eq v version) then
R.error_msgf "unexpected version %a (expected %a)" pp_version v pp_version version
else
Ok wire

View file

@ -25,6 +25,3 @@ type cert_extension = Vmm_commands.version * Vmm_commands.t
val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result
val cert_extension_to_cstruct : cert_extension -> Cstruct.t
val wire_command_of_cert : Vmm_commands.version -> X509.t ->
(Vmm_commands.t, [> `Msg of string ]) result

View file

@ -177,16 +177,6 @@ let translate_tap vm tap =
| [ (_, b) ] -> Some b
| _ -> None
let name cert = X509.common_name_to_string cert
(* 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)
module Stats = struct
type rusage = {
utime : (int64 * int) ;

View file

@ -80,10 +80,6 @@ type vm = {
val pp_vm : vm Fmt.t
val translate_tap : vm -> string -> string option
val name : X509.t -> string
val separate_chain : 'a list -> ('a * 'a list, [> `Msg of string ]) result
module Stats : sig
type rusage = {
utime : int64 * int;

View file

@ -1,8 +1,29 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Rresult
open Rresult.R.Infix
open Vmm_core
let name cert = X509.common_name_to_string cert
(* 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 *)
@ -28,7 +49,7 @@ let handle _addr version chain =
(* 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)! *)
Vmm_asn.wire_command_of_cert version leaf >>= fun wire ->
wire_command_of_cert version leaf >>= fun wire ->
(* we only allow some commands via certificate *)
match wire with
| `Console_cmd (`Console_subscribe _)

View file

@ -1,5 +1,8 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
val wire_command_of_cert : Vmm_commands.version -> X509.t ->
(Vmm_commands.t, [> `Msg of string ]) result
val handle :
'a -> Vmm_commands.version ->
X509.t list ->

View file

@ -1 +0,0 @@
vmm_stats_stubs.o