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) [![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 A set of binaries to manage, provision, and deploy MirageOS unikernels.
is very much work in progress, don't expect anything stable. 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 Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation
and an overview. and an overview.

24
_tags
View file

@ -1,20 +1,24 @@
true : bin_annot, safe_string, principal, color(always) true : bin_annot, safe_string, principal, color(always)
true : warn(+A-4-44-48) 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" : 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_lwt.{ml,mli}>: package(lwt lwt.unix)
<src/vmm_tls_lwt.{ml,mli}>: package(lwt tls.lwt) <src/vmm_tls_lwt.{ml,mli}>: package(lwt tls.lwt)
<src/vmm_tls.{ml,mli}>: package(x509) <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/*>: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix)
<app/vmm_client.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt) <app/vmmd.{ml,native,byte}>: package(ptime.clock.os)
<app/vmm_tls_endpoint.{ml,native,byte}>: package(tls.lwt) <app/vmmd_console.{ml,native,byte}>: package(ptime.clock.os)
<app/vmm_prometheus_stats.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt) <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" ] `P "$(tname) connects to vmmd via a local socket" ]
in in
Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), 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 ] 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 let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in
X509_lwt.authenticator auth >>= fun authenticator -> X509_lwt.authenticator auth >>= fun authenticator ->
Lwt.catch (fun () -> 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 -> Lwt_unix.gethostbyname host >>= fun host_entry ->
let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in 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 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" ] `P "$(tname) connects to a server and initiates a TLS handshake" ]
in in
Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination), 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 () = let () =
match Term.eval cmd match Term.eval cmd

View file

@ -189,6 +189,6 @@ let socket =
let cmd = let cmd =
Term.(ret (const jump $ setup_log $ socket)), 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 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" ] `P "$(tname) connects to a vmm stats socket, pulls statistics and pushes them via TCP to influxdb" ]
in in
Term.(pure run_client $ setup_log $ socket $ influx $ opt_vmname), 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 () = let () =
match Term.eval cmd match Term.eval cmd

View file

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

View file

@ -167,6 +167,6 @@ let port =
let cmd = let cmd =
Term.(ret (const jump $ setup_log $ cacert $ cert $ key $ port)), 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 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,5 +1,78 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *) (* (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_provision
open Vmm_asn open Vmm_asn
@ -77,6 +150,6 @@ let bridge =
let cmd = let cmd =
Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)), 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 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -67,6 +67,56 @@ let key =
let cmd = let cmd =
Term.(ret (const jump $ setup_log $ db $ cacert $ key $ csr $ days)), 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 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"] flag ["link"; "library"; "ocaml"; "native"; "use_vmm_stats"]
(S ([A "-cclib"; A "-lvmm_stats_stubs"])); (S ([A "-cclib"; A "-lvmm_stats_stubs"]));
flag ["link"; "ocaml"; "link_vmm_stats"] flag ["link"; "ocaml"; "link_vmm_stats"]
(S ([A "stats/libvmm_stats_stubs.a"] @ vmm_lib)); (S ([A "app/libvmm_stats_stubs.a"] @ vmm_lib));
dep ["link"; "ocaml"; "use_vmm_stats"] ["stats/libvmm_stats_stubs.a"]; dep ["link"; "ocaml"; "use_vmm_stats"] ["app/libvmm_stats_stubs.a"];
dep ["link"; "ocaml"; "link_vmm_stats"] ["stats/libvmm_stats_stubs.a"]; dep ["link"; "ocaml"; "link_vmm_stats"] ["app/libvmm_stats_stubs.a"];
| _ -> () | _ -> ()
end end

11
opam
View file

@ -1,12 +1,12 @@
opam-version: "1.2" opam-version: "2.0"
maintainer: "Hannes Mehnert <hannes@mehnert.org>" maintainer: "Hannes Mehnert <hannes@mehnert.org>"
authors: ["Hannes Mehnert <hannes@mehnert.org>"] authors: ["Hannes Mehnert <hannes@mehnert.org>"]
homepage: "https://github.com/hannesm/vmm" homepage: "https://github.com/hannesm/albatross"
dev-repo: "https://github.com/hannesm/vmm.git" dev-repo: "git+https://github.com/hannesm/albatross.git"
bug-reports: "https://github.com/hannesm/vmm/issues" bug-reports: "https://github.com/hannesm/albatross/issues"
available: [ ocaml-version >= "4.05.0"]
depends: [ depends: [
"ocaml" {>= "4.05.0"}
"ocamlfind" {build} "ocamlfind" {build}
"ocamlbuild" {build} "ocamlbuild" {build}
"topkg" {build} "topkg" {build}
@ -32,3 +32,4 @@ depends: [
build: [ build: [
[ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ] [ "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 do install -U $basedir/packaging/rc.d/$f $rootdir/usr/local/etc/rc.d/$f; done
# stage albatross app binaries # 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 \ install -U $basedir/_build/app/$f.native \
$rootdir/usr/local/libexec/albatross/$f; done $rootdir/usr/local/libexec/albatross/$f; done
install -U $basedir/_build/stats/vmm_stats_lwt.native \ install -U $basedir/_build/app/vmmd_stats.native \
$rootdir/usr/local/libexec/albatross/vmm_stats_lwt $rootdir/usr/local/libexec/albatross/vmmd_stats
install -U $basedir/_build/app/vmmc.native \ install -U $basedir/_build/app/vmm_local.native \
$rootdir/usr/local/sbin/vmmc $rootdir/usr/local/sbin/vmm_local
# create +MANIFEST # create +MANIFEST
flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + | flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + |

View file

@ -29,7 +29,7 @@ start_cmd="albatross_console_start"
: ${albatross_console_user:="albatross"} : ${albatross_console_user:="albatross"}
pidfile="/var/run/albatross_console.pid" pidfile="/var/run/albatross_console.pid"
procname="/usr/local/libexec/albatross/vmm_console" procname="/usr/local/libexec/albatross/vmmd_console"
albatross_console_start () { albatross_console_start () {
/usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_console_user}" \ /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"} : ${albatross_log_user:="albatross"}
pidfile="/var/run/albatross_log.pid" pidfile="/var/run/albatross_log.pid"
procname="/usr/local/libexec/albatross/vmm_log" procname="/usr/local/libexec/albatross/vmmd_log"
logfile="/var/log/albatross" logfile="/var/log/albatross"
albatross_log_precmd () { albatross_log_precmd () {

View file

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

View file

@ -1,7 +1,2 @@
description = "VM Manager" description = "VM Manager"
version = "%%VERSION_NUM%%" 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 () = let () =
Pkg.describe "albatross" @@ fun _ -> Pkg.describe "albatross" @@ fun _ ->
Ok [ Ok [
Pkg.mllib "src/albatross.mllib" ;
Pkg.bin "app/vmmd" ; Pkg.bin "app/vmmd" ;
Pkg.bin "app/vmm_console" ; Pkg.bin "app/vmmd_console" ;
Pkg.bin "app/vmm_log" ; Pkg.bin "app/vmmd_log" ;
Pkg.bin "app/vmm_client" ; Pkg.bin "app/vmmd_stats" ;
Pkg.bin "app/vmm_tls_endpoint" ; Pkg.bin "app/vmmd_tls" ;
Pkg.bin "app/vmmc" ; Pkg.bin "app/vmmd_influx" ;
Pkg.bin "provision/vmm_req_delegation" ; Pkg.bin "app/vmmc_local" ;
Pkg.bin "provision/vmm_req_vm" ; Pkg.bin "app/vmmc_remote" ;
Pkg.bin "provision/vmm_sign" ; Pkg.bin "app/vmmc_bistro" ;
Pkg.bin "provision/vmm_gen_ca" ; Pkg.bin "app/vmmp_request" ;
(* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *) Pkg.bin "app/vmmp_sign" ;
Pkg.bin "stats/vmm_stats_lwt" ;
Pkg.bin "app/vmm_influxdb_stats" ;
] ]

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:"version" version)
(required ~label:"entry" log_entry)) (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 = let log_to_disk version entry =
log_disk_to_cstruct (version, entry) log_disk_to_cstruct (version, entry)
let logs_of_disk version buf = let logs_of_disk version buf =
let rec next acc 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) -> | Ok ((version', entry), cs) ->
let acc' = let acc' =
if Vmm_commands.version_eq version version' then if Vmm_commands.version_eq version version' then
@ -471,13 +473,3 @@ let cert_extension =
let cert_extension_of_cstruct, cert_extension_to_cstruct = let cert_extension_of_cstruct, cert_extension_to_cstruct =
projections_of cert_extension 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_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result
val cert_extension_to_cstruct : cert_extension -> Cstruct.t 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 | [ (_, b) ] -> Some b
| _ -> None | _ -> 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 module Stats = struct
type rusage = { type rusage = {
utime : (int64 * int) ; utime : (int64 * int) ;

View file

@ -80,10 +80,6 @@ type vm = {
val pp_vm : vm Fmt.t val pp_vm : vm Fmt.t
val translate_tap : vm -> string -> string option 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 module Stats : sig
type rusage = { type rusage = {
utime : int64 * int; utime : int64 * int;

View file

@ -1,8 +1,29 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *) (* (c) 2018 Hannes Mehnert, all rights reserved *)
open Rresult
open Rresult.R.Infix 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 = (* let check_policy =
(* get names and static resources *) (* get names and static resources *)
@ -28,7 +49,7 @@ let handle _addr version chain =
(* TODO: inspect top-level-cert of chain. *) (* TODO: inspect top-level-cert of chain. *)
(* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
(* TODO: update policies (parse chain for policy, and apply them)! *) (* 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 *) (* we only allow some commands via certificate *)
match wire with match wire with
| `Console_cmd (`Console_subscribe _) | `Console_cmd (`Console_subscribe _)

View file

@ -1,5 +1,8 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *) (* (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 : val handle :
'a -> Vmm_commands.version -> 'a -> Vmm_commands.version ->
X509.t list -> X509.t list ->

View file

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