Merge pull request #15 from hannesm/new-order

New order
This commit is contained in:
Hannes Mehnert 2018-10-28 23:44:21 +01:00 committed by GitHub
commit 0ce16cbf6b
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
68 changed files with 4449 additions and 4487 deletions

View file

@ -5,6 +5,6 @@ S provision
B _build/**
PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex cstruct.ppx duration
PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex duration
PKG ptime ptime.clock.os ipaddr.unix decompress
PKG lwt.unix

3
.ocamlinit Normal file
View file

@ -0,0 +1,3 @@
#require "cstruct, asn1-combinators, astring, fmt, ipaddr, rresult, lwt, x509, tls, hex, bos, decompress, tls.lwt"
#directory "_build/src"
#load "albatross.cma"

View file

@ -7,8 +7,8 @@ env:
- PACKAGE="albatross"
- TESTS=false
matrix:
- OCAML_VERSION=4.04
- OCAML_VERSION=4.05
- OCAML_VERSION=4.06
- OCAML_VERSION=4.07
notifications:
email: false

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_ca`: certificate authority operations: sign, generate (and revoke)
Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation
and an overview.
@ -14,13 +27,12 @@ is used on top to (more gracefully) handle multiple connection, and to have a
watching thread (in `waitpid(2)`) for every virtual machine started by vmmd.
To install Albatross, run `opam pin add albatross
https://github.com/hannesm/albatross`. On FreeBSD, `opam pin add
solo5-kernel-ukvm --dev` is needed as well.
https://github.com/hannesm/albatross`.
The following elaborates on how to get the software up and running, following by
provisioning and deploying some unikernels. There is a *server* (`SRV`)
component which needs six binaries: vmm_console, vmm_log, vmm_stats_lwt, vmmd,
ukvm-bin.none, and ukvm-bin.net; a `CA` machine (which should be air-gapped, or
solo6-hvt.none, and solo5-hvt.net; a `CA` machine (which should be air-gapped, or
at least use some hardware token) for provisioning which needs vmm_sign, and
vmm_gen_ca; and a *development* (`DEV`) machine which has a fully featured OCaml
and MirageOS environment. Each step is prefixed with the machine it is supposed
@ -63,15 +75,15 @@ steps to produce the remaining required binaries:
CA> COPY cacert.pem server.pem server.key SRV:
DEV> git clone https://github.com/mirage/mirage-skeleton.git
DEV> cd mirage-skeleton/tutorial/hello
DEV> mirage configure -t ukvm
DEV> mirage configure -t hvt
DEV> mirage build
DEV> mv ukvm-bin /tmp/ukvm-bin.none
DEV> cd ../device-usage/network
DEV> mirage configure -t ukvm
DEV> mv solo5-hvt /tmp/solo5-hvt.none
DEV> cd ../../device-usage/network
DEV> mirage configure -t hvt
DEV> mirage build
DEV> mv ukvm-bin /tmp/ukvm-bin.net
DEV> mv solo5-hvt /tmp/solo5-hvt.net
DEV> cd ../../..
DEV> COPY /tmp/ukvm-bin.none /tmp/ukvm-bin.net SRV:/var/db/albatross
DEV> COPY /tmp/solo5-hvt.none /tmp/solo5-hvt.net SRV:/var/db/albatross
DEV> COPY vmm_console vmm_log vmm_stats_lwt vmmd SRV:/opt/bin/
```
@ -104,7 +116,7 @@ able to collect statistics unless running as a privileged user, the following
```
[albatross=10]
add path 'vmm/ukvm*' mode 0660 group albatross
add path 'vmm/solo5*' mode 0660 group albatross
```
Also need to activate by adding `devfs_system_ruleset="albatross"` to
@ -140,12 +152,12 @@ This produced in the first step two files, `admin.req` and `admin.key`, and in
the second step two more files, `dev.db` and `admin.pem`.
```
DEV> vmm_req_vm hello mirage-skeleton/tutorial/hello/hello.ukvm 12 1
DEV> vmm_req_vm hello mirage-skeleton/tutorial/hello/hello.hvt 12 1
DEV> vmm_sign dev.db dev.pem dev.key hello.req
```
This generates a private key `hello.key` and a certificate signing request named
`hello.req` including the virtual machine image `hello.ukvm`, which gets 12MB
`hello.req` including the virtual machine image `hello.hvt`, which gets 12MB
memory and CPU id 1. The second command used the `dev.key` to sign the signing
request and output a `hello.pem`.

29
_tags
View file

@ -1,20 +1,25 @@
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_wire.{ml,mli}>: package(ppx_cstruct)
<src/vmm_asn.{ml,mli}>: package(asn1-combinators)
<src/vmm_lwt.{ml,mli}>: package(lwt lwt.unix)
<src/vmm_tls.{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_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/vmmd.{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/vmmc_bistro.{ml,native,byte}>: package(nocrypto tls.lwt nocrypto.lwt)
<app/vmmp_request.{ml,native,byte}>: package(nocrypto.unix ptime.clock.os x509)
<app/vmmp_ca.{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)

147
app/vmm_cli.ml Normal file
View file

@ -0,0 +1,147 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Astring
open Vmm_core
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
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
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let host_port : (string * int) Arg.converter =
let parse s =
match Astring.String.cut ~sep:":" s with
| None -> `Error "broken: no port specified"
| Some (hostname, port) ->
try
`Ok (hostname, int_of_string port)
with
Not_found -> `Error "failed to parse port"
in
parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p
let bridge =
let parse s =
match Astring.String.cuts ~sep:"/" s with
| [ name ; fst ; lst ; gw ; nm ] ->
begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with
| Some fst, Some lst, Some gw ->
(try
let nm = int_of_string nm in
if nm > 0 && nm <= 32 then
let net = Ipaddr.V4.Prefix.make nm gw in
if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then
`Ok (`External (name, fst, lst, gw, nm))
else
`Error "first or last IP are not in subnet"
else
`Error "netmask must be > 0 and <= 32"
with Failure _ -> `Error "couldn't parse netmask")
| _ -> `Error "couldn't parse IP address"
end
| [ name ] -> `Ok (`Internal name)
| _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
in
(parse, pp_bridge)
let vm_c =
let parse s = `Ok (id_of_string s)
in
(parse, pp_id)
let opt_vm_name =
let doc = "name of virtual machine." in
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 vm_mem =
let doc = "Memory to assign" in
Arg.(value & opt int 32 & info [ "mem" ] ~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)

View file

@ -1,189 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
open Vmm_core
let my_version = `WV0
let command = ref 1
let process db hdr data =
let open Vmm_wire in
let open Rresult.R.Infix in
if not (version_eq hdr.version my_version) then
Logs.err (fun m -> m "unknown wire protocol version")
else
let r =
match hdr.tag with
| x when x = Client.stat_msg_tag ->
Client.decode_stat data >>= fun (ru, vmm, ifd) ->
Logs.app (fun m -> m "statistics: %a %a %a"
pp_rusage ru
Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string uint64)) vmm
Fmt.(list ~sep:(unit ", ") pp_ifdata) ifd) ;
Ok ()
| x when x = Client.log_msg_tag ->
Client.decode_log data >>= fun log ->
Logs.app (fun m -> m "log: %a" (Vmm_core.Log.pp db) log) ;
Ok ()
| x when x = Client.console_msg_tag ->
Client.decode_console data >>= fun (name, ts, msg) ->
Logs.app (fun m -> m "console %s: %a %s" (translate_serial db name) (Ptime.pp_human ~tz_offset_s:0 ()) ts msg) ;
Ok ()
| x when x = Client.info_msg_tag ->
Client.decode_info data >>= fun vms ->
List.iter (fun (name, cmd, pid, taps) ->
Logs.app (fun m -> m "info %s: %s %d taps %a" (translate_serial db name)
cmd pid Fmt.(list ~sep:(unit ", ") string) taps))
vms ;
Ok ()
| x when x = fail_tag ->
decode_str data >>= fun (msg, _) ->
Logs.err (fun m -> m "failed %s" msg) ;
Ok ()
| x when x = success_tag ->
decode_str data >>= fun (msg, _) ->
Logs.app (fun m -> m "success %s" msg) ;
Ok ()
| x -> Rresult.R.error_msgf "unknown header tag %02X" x
in
match r with
| Ok () -> ()
| Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg)
let rec read_tls_write_cons db t =
Vmm_tls.read_tls t >>= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while reading %s" msg) ;
read_tls_write_cons db t
| Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit
| Ok (hdr, data) ->
process db hdr data ;
read_tls_write_cons db t
let rec read_cons_write_tls db t =
Lwt.catch (fun () ->
Lwt_io.read_line Lwt_io.stdin >>= fun line ->
let cmd, arg = match Astring.String.cut ~sep:" " line with
| None -> line, None
| Some (a, b) -> a, Some (translate_name db b)
in
match Vmm_core.cmd_of_string cmd with
| None -> Logs.err (fun m -> m "unknown command") ; read_cons_write_tls db t
| Some cmd ->
let out = Vmm_wire.Client.cmd ?arg cmd !command my_version in
command := succ !command ;
Vmm_tls.write_tls t out >>= function
| Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return_unit
| Ok () ->
Logs.debug (fun m -> m "wrote %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
read_cons_write_tls db t)
(fun e ->
Logs.err (fun m -> m "exception %s in read_cons_write_tls" (Printexc.to_string e)) ;
Lwt.return_unit)
let client cas host port cert priv_key db =
Nocrypto_entropy_lwt.initialize () >>= fun () ->
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 () ->
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
Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
(match fst cert with
| [] -> Lwt.fail_with "certificate is empty"
| hd::_ -> Lwt.return hd) >>= fun leaf ->
let certificates = `Single cert in
let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
if Vmm_asn.contains_vm leaf || Vmm_asn.contains_crl leaf then
read_tls_write_cons db t
else
(Logs.debug (fun m -> m "read/write games!") ;
Lwt.join [ read_tls_write_cons db t ; read_cons_write_tls db t ]))
(fun exn ->
Logs.err (fun m -> m "failed to establish TLS connection: %s"
(Printexc.to_string exn)) ;
Lwt.return_unit)
let run_client _ cas cert key (host, port) db =
Printexc.register_printer (function
| Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x)
| Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
| _ -> None) ;
Sys.(set_signal sigpipe Signal_ignore) ;
let db =
let open Rresult.R.Infix in
match db with
| None -> []
| Some db ->
match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with
| Ok db -> db
| Error (`Msg m) -> Logs.warn (fun f -> f "couldn't parse database %s" m) ; []
in
Lwt_main.run (client cas host port cert key db)
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let host_port : (string * int) Arg.converter =
let parse s =
try
let open String in
let colon = index s ':' in
let hostname = sub s 0 colon
and port =
let csucc = succ colon in
sub s csucc (length s - csucc)
in
`Ok (hostname, int_of_string port)
with
Not_found -> `Error "broken"
in
parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p
let cas =
let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in
Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
let client_cert =
let doc = "Use a client certificate chain" in
Arg.(required & pos 1 (some file) None & info [] ~doc)
let client_key =
let doc = "Use a client key" in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let destination =
Arg.(required & pos 3 (some host_port) None & info [] ~docv:"destination"
~doc:"the destination hostname:port to connect to")
let db =
let doc = "Certificate database" in
Arg.(value & opt (some file) None & info [ "db" ] ~doc)
let cmd =
let doc = "VMM TLS client" in
let man = [
`S "DESCRIPTION" ;
`P "$(tname) connects to a server and initiates a TLS handshake" ]
in
Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination $ db),
Term.info "vmm_client" ~version:"%%VERSION_NUM%%" ~doc ~man
let () =
match Term.eval cmd
with `Error _ -> exit 1 | _ -> exit 0

View file

@ -1,188 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(* the process responsible for buffering console IO *)
(* communication channel is a single unix domain socket shared between vmmd and
vmm_console. The vmmd can issue the following commands:
- Add name --> creates a new console slurper for name
- Attach name since --> attaches console of name since counter, whenever
console output to name is reported, this will be forwarded as Data
- Detach name --> detaches console *)
open Lwt.Infix
open Astring
open Vmm_wire
open Vmm_wire.Console
let my_version = `WV0
let pp_sockaddr ppf = function
| Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
| Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
(Unix.string_of_inet_addr addr) port
let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
let active = ref String.Map.empty
let read_console name ring channel () =
Lwt.catch (fun () ->
let rec loop () =
Lwt_io.read_line channel >>= fun line ->
Logs.debug (fun m -> m "read %s" line) ;
let t = Ptime_clock.now () in
Vmm_ring.write ring (t, line) ;
(match String.Map.find name !active with
| None -> Lwt.return_unit
| Some fd ->
Vmm_lwt.write_raw fd (data my_version name t line) >>= function
| Error _ -> Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit)
| Ok () -> Lwt.return_unit) >>=
loop
in
loop ())
(fun e ->
begin match e with
| Unix.Unix_error (e, f, _) ->
Logs.err (fun m -> m "%s error in %s: %a" name f pp_unix_error e)
| End_of_file ->
Logs.debug (fun m -> m "%s end of file while reading" name)
| exn ->
Logs.err (fun m -> m "%s error while reading %s" name (Printexc.to_string exn))
end ;
Lwt_io.close channel)
let open_fifo name =
let fifo = Fpath.(Vmm_core.tmpdir / name + "fifo") in
Lwt.catch (fun () ->
Logs.debug (fun m -> m "opening %a for reading" Fpath.pp fifo) ;
Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string fifo) >>= fun channel ->
Lwt.return (Some channel))
(function
| Unix.Unix_error (e, f, _) ->
Logs.err (fun m -> m "%a error in %s: %a" Fpath.pp fifo f pp_unix_error e) ;
Lwt.return None
| exn ->
Logs.err (fun m -> m "%a error while reading %s" Fpath.pp fifo (Printexc.to_string exn)) ;
Lwt.return None)
let t = ref String.Map.empty
let add_fifo name =
open_fifo name >|= function
| Some f ->
let ring = Vmm_ring.create () in
Logs.debug (fun m -> m "inserting %s" name) ;
let map = String.Map.add name ring !t in
t := map ;
Lwt.async (read_console name ring f) ;
Ok "reading"
| None ->
Error (`Msg "opening")
let attach s name =
Logs.debug (fun m -> m "attempting to attach %s" name) ;
match String.Map.find name !t with
| None -> Lwt.return (Error (`Msg "not found"))
| Some _ ->
active := String.Map.add name s !active ;
Lwt.return (Ok "attached")
let detach name =
active := String.Map.remove name !active ;
Lwt.return (Ok "removed")
let history s name since =
match String.Map.find name !t with
| None -> Lwt.return (Rresult.R.error_msgf "ring %s not found (%d): %a"
name (String.Map.cardinal !t)
Fmt.(list ~sep:(unit ";") string)
(List.map fst (String.Map.bindings !t)))
| Some r ->
let entries = Vmm_ring.read_history r since in
Logs.debug (fun m -> m "found %d history" (List.length entries)) ;
Lwt_list.iter_s (fun (i, v) ->
Vmm_lwt.write_raw s (data my_version name i v) >|= fun _ -> ())
entries >|= fun () ->
Ok "success"
let handle s addr () =
Logs.info (fun m -> m "handling connection %a" pp_sockaddr addr) ;
let rec loop () =
Vmm_lwt.read_exactly s >>= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while reading %s" msg) ;
loop ()
| Error _ ->
Logs.err (fun m -> m "exception while reading") ;
Lwt.return_unit
| Ok (hdr, data) ->
(if not (version_eq hdr.version my_version) then
Lwt.return (Error (`Msg "ignoring data with bad version"))
else
match decode_str data with
| Error e -> Lwt.return (Error e)
| Ok (name, off) ->
match Console.int_to_op hdr.tag with
| Some Add_console -> add_fifo name
| Some Attach_console -> attach s name
| Some Detach_console -> detach name
| Some History ->
(match decode_ts ~off data with
| Error e -> Lwt.return (Error e)
| Ok since -> history s name since)
| _ ->
Lwt.return (Error (`Msg "unknown command"))) >>= (function
| Ok msg -> Vmm_lwt.write_raw s (success ~msg hdr.id my_version)
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while processing command: %s" msg) ;
Vmm_lwt.write_raw s (fail ~msg hdr.id my_version)) >>= function
| Ok () -> loop ()
| Error _ ->
Logs.err (fun m -> m "exception while writing to socket") ;
Lwt.return_unit
in
loop () >>= fun () ->
Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
Logs.warn (fun m -> m "disconnected")
let jump _ file =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run
((Lwt_unix.file_exists file >>= function
| true -> Lwt_unix.unlink file
| false -> Lwt.return_unit) >>= fun () ->
let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.(bind s (ADDR_UNIX file)) >>= fun () ->
Lwt_unix.listen s 1 ;
let rec loop () =
Lwt_unix.accept s >>= fun (cs, addr) ->
Lwt.async (handle cs addr) ;
loop ()
in
loop ())
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let socket =
let doc = "Socket to listen on" in
let sock = Fpath.(to_string (Vmm_core.tmpdir / "cons" + "sock")) in
Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ socket)),
Term.info "vmm_console" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,162 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(* the process responsible for event log *)
(* communication channel is a single unix domain socket shared between vmmd and
vmm_log. There are two commands from vmmd to vmm_log, history and data. *)
(* TODO: this should (optionally?) persist to a remote target *)
(* internally, a ring buffer for the last N events is preserved in memory
each new event is directly written to disk! *)
open Lwt.Infix
open Astring
open Vmm_wire
open Vmm_wire.Log
let my_version = `WV0
let write_complete s str =
let l = String.length str in
let b = Bytes.unsafe_of_string str in
let rec w off =
let len = l - off in
Lwt_unix.write s b off len >>= fun n ->
if n = len then Lwt.return_unit else w (off + n)
in
w 0
let pp_sockaddr ppf = function
| Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
| Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
(Unix.string_of_inet_addr addr) port
let handle fd ring s addr () =
Logs.info (fun m -> m "handling connection from %a" pp_sockaddr addr) ;
let str = Fmt.strf "%a: CONNECT\n" (Ptime.pp_human ~tz_offset_s:0 ()) (Ptime_clock.now ()) in
write_complete fd str >>= fun () ->
let rec loop () =
Vmm_lwt.read_exactly s >>= function
| Error (`Msg e) ->
Logs.err (fun m -> m "error while reading %s" e) ;
loop ()
| Error _ ->
Logs.err (fun m -> m "exception while reading") ;
Lwt.return_unit
| Ok (hdr, data) ->
let out =
(if not (version_eq hdr.version my_version) then
Error (`Msg "unknown version")
else match int_to_op hdr.tag with
| Some Data ->
(match decode_ts data with
| Ok ts -> Vmm_ring.write ring (ts, data)
| Error _ ->
Logs.warn (fun m -> m "ignoring error while decoding timestamp %s" data)) ;
Ok (`Data data)
| Some History ->
begin match decode_str data with
| Error e -> Error e
| Ok (str, off) -> match decode_ts ~off data with
| Error e -> Error e
| Ok ts ->
let elements = Vmm_ring.read_history ring ts in
let res = List.fold_left (fun acc (_, x) ->
match Vmm_wire.Log.decode_log_hdr (Cstruct.of_string x) with
| Ok (hdr, _) ->
Logs.debug (fun m -> m "found an entry: %a" (Vmm_core.Log.pp_hdr []) hdr) ;
if String.equal str (Vmm_core.string_of_id hdr.Vmm_core.Log.context) then
x :: acc
else
acc
| _ -> acc)
[] elements
in
(* just need a wrapper in tag = Log.Data, id = reqid *)
let out =
List.fold_left (fun acc x ->
let length = String.length x in
let hdr = Vmm_wire.create_header { length ; id = hdr.id ; tag = op_to_int Data ; version = my_version } in
(Cstruct.to_string hdr ^ x) :: acc)
[] (List.rev res)
in
Ok (`Out out)
end
| _ -> Error (`Msg "unknown command"))
in
match out with
| Error (`Msg msg) ->
begin
Logs.err (fun m -> m "error while processing: %s" msg) ;
Vmm_lwt.write_raw s (fail ~msg hdr.id my_version) >>= function
| Error _ -> Logs.err (fun m -> m "error0 while writing") ; Lwt.return_unit
| Ok () -> loop ()
end
| Ok (`Data data) ->
begin
write_complete fd data >>= fun () ->
Vmm_lwt.write_raw s (success hdr.id my_version) >>= function
| Error _ -> Logs.err (fun m -> m "error1 while writing") ; Lwt.return_unit
| Ok () -> loop ()
end
| Ok (`Out datas) ->
Lwt_list.fold_left_s (fun r x -> match r with
| Error e -> Lwt.return (Error e)
| Ok () -> Vmm_lwt.write_raw s x)
(Ok ()) datas >>= function
| Error _ -> Logs.err (fun m -> m "error2 while writing") ; Lwt.return_unit
| Ok () ->
Vmm_lwt.write_raw s (success hdr.id my_version) >>= function
| Error _ -> Logs.err (fun m -> m "error3 while writing") ; Lwt.return_unit
| Ok () -> loop ()
in
loop () >>= fun () ->
Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit)
let jump _ file sock =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run
(Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd ->
(Lwt_unix.file_exists sock >>= function
| true -> Lwt_unix.unlink sock
| false -> Lwt.return_unit) >>= fun () ->
let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.(bind s (ADDR_UNIX sock)) >>= fun () ->
Lwt_unix.listen s 1 ;
let ring = Vmm_ring.create () in
let rec loop () =
Lwt_unix.accept s >>= fun (cs, addr) ->
Lwt.async (handle fd ring cs addr) ;
loop ()
in
loop ())
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let socket =
let doc = "Socket to listen on" in
let sock = Fpath.(to_string (Vmm_core.tmpdir / "log" + "sock")) in
Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let file =
let doc = "File to write the log to" in
Arg.(value & opt string "/var/log/albatross" & info [ "logfile" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ file $ socket)),
Term.info "vmm_log" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,356 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
open Astring
open Vmm_core
let my_version = `WV0
let command = ref 1
let t : (Lwt_unix.file_descr * Lwt_unix.sockaddr * string) IM.t ref = ref IM.empty
module S = struct
type t = Lwt_unix.sockaddr
let compare : Lwt_unix.sockaddr -> Lwt_unix.sockaddr -> int = compare
end
module SM = Map.Make(S)
let count : int SM.t ref = ref SM.empty
let dec s =
match SM.find s !count with
| exception Not_found -> `Not_found
| 1 -> count := SM.remove s !count ; `Close
| x -> count := SM.add s (pred x) !count ; `Continue
let known_vms : string list ref = ref []
module P = struct
let p vm ?(typ = `Counter) name help value =
let t_s = function `Counter -> "counter" | `Gauge -> "gauge" in
let name = vm ^ "_" ^ name in
let p a v = String.concat ~sep:" " [ "#" ; a ; name ; v ] in
String.concat ~sep:"\n"
[ p "HELP" help ; p "TYPE" (t_s typ) ; name ^ " " ^ value ]
let tv (sec, usec) = Printf.sprintf "%Lu.%06d" sec usec
let i64 i = Printf.sprintf "%Lu" i
let encode_ru vm ru =
let p = p vm in
String.concat ~sep:"\n"
[ p "utime" "user time used" (tv ru.utime) ;
p "stime" "system time used" (tv ru.stime) ;
p "maxrss" "maximum resident set" (i64 ru.maxrss) ;
p ~typ:`Gauge "ixrss" "shared memory" (i64 ru.ixrss) ;
p ~typ:`Gauge "idrss" "unshared data" (i64 ru.idrss) ;
p ~typ:`Gauge "isrss" "unshared stack" (i64 ru.isrss) ;
p "minflt" "page reclaims" (i64 ru.minflt) ;
p "maxflt" "page faults" (i64 ru.majflt) ;
p "nswap" "swaps" (i64 ru.nswap) ;
p "inblock" "block input ops" (i64 ru.inblock) ;
p "outblock" "block output ops" (i64 ru.outblock) ;
p "msgsnd" "messages send" (i64 ru.msgsnd) ;
p "msgrcv" "messages received" (i64 ru.msgrcv) ;
p "nsignals" "signals received" (i64 ru.nsignals) ;
p "nvcsw" "voluntary context switches" (i64 ru.nvcsw) ;
p "nivcsw" "involuntary context switches" (i64 ru.nivcsw)
]
let encode_vmm vm xs =
let p = p vm in
let massage s =
let cutted = match String.cut ~sep:"umber of " s with
| Some (_, r) -> r
| None -> s
in
let cutted = match String.cut ~sep:"[" cutted with
| None -> cutted
| Some (l, r) -> match String.cut ~sep:"]" r with
| None -> cutted
| Some (l', r) when r = "" -> l ^ "_" ^ l'
| Some (l', r') -> l ^ "_" ^ l' ^ "_" ^ r'
in
let cutted =
List.fold_left (fun str sep ->
match String.cut ~sep str with
| None -> str
| Some (l, r) -> l ^ r)
cutted [ "%" ; "/" ; "-" ]
in
String.concat ~sep:"_" (String.cuts ~sep:" " cutted)
in
String.concat ~sep:"\n"
(List.map (fun (k, v) -> p (massage k) k (i64 v)) xs)
let i32 i = Printf.sprintf "%lu" i
let encode_if vm ifd =
let p = p (vm ^ "_" ^ ifd.name) in
String.concat ~sep:"\n"
(* TODO: flags *)
[ p ~typ:`Gauge "send_length" "length of send queue" (i32 ifd.send_length) ;
p "max_send_length" "maximum length of send queue" (i32 ifd.max_send_length) ;
p "send_drops" "drops in send queue" (i32 ifd.send_drops) ;
p ~typ:`Gauge "mtu" "maximum transmission unit" (i32 ifd.mtu) ;
p ~typ:`Gauge "baudrate" "linespeed" (i64 ifd.baudrate) ;
p "vm_to_host_packets" "packets from vm" (i64 ifd.input_packets) ;
p "vm_to_host_errors" "packet errors from vm" (i64 ifd.input_errors) ;
p "vm_to_host_bytes" "bytes from vm" (i64 ifd.input_bytes) ;
p "vm_to_host_mcast" "packets from vm via multicast" (i64 ifd.input_mcast) ;
p "vm_to_host_dropped" "packets dropped from vm" (i64 ifd.input_dropped) ;
p "collisions" "collisions on csma interface" (i64 ifd.collisions) ;
p "host_to_vm_packets" "packets to vm" (i64 ifd.output_packets) ;
p "host_to_vm_errors" "packet errors to vm" (i64 ifd.output_errors) ;
p "host_to_vm_bytes" "bytes to vm" (i64 ifd.output_bytes) ;
p "host_to_vm_mcast" "packets to vm via multicast" (i64 ifd.output_mcast) ;
p "host_to_vm_dropped" "packets dropped to vm" (i64 ifd.output_dropped)
]
end
(* just a reminder whether we already sent the initial "info" or not *)
let f_done = ref false
let process db tls hdr data =
let open Vmm_wire in
let open Rresult.R.Infix in
if not (version_eq hdr.version my_version) then begin
Logs.err (fun m -> m "unknown wire protocol version") ; Lwt.return_unit
end else
match hdr.tag with
| x when x = Client.log_msg_tag && not !f_done ->
f_done := true ;
(* issue initial "info" to get all the vm names *)
let out = Vmm_wire.Client.cmd Info !command my_version in
command := succ !command ;
Logs.debug (fun m -> m "writing %a over TLS" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
(Vmm_tls.write_tls tls out >|= function
| Ok () -> ()
| Error _ -> Logs.err (fun m -> m "error while writing") ; ())
| _ ->
let r =
match hdr.tag with
| x when x = Client.log_msg_tag ->
Client.decode_log data >>= fun (hdr, event) ->
let nam = translate_serial db hdr.Vmm_core.Log.name in
begin match event with
| `VM_start _ -> known_vms := nam :: !known_vms
| `VM_stop _ -> known_vms := List.filter (fun m -> m <> nam) !known_vms
| _ -> ()
end ;
Ok `None
| x when x = Client.info_msg_tag ->
Client.decode_info data >>= fun vms ->
let vms = List.map (fun (name, _, _, _) -> translate_serial db name) vms in
known_vms := vms ;
Ok `None
| x when x = Client.stat_msg_tag ->
Client.decode_stat data >>= fun (ru, vmm, ifd) ->
begin match IM.find hdr.id !t with
| exception Not_found -> Logs.err (fun m -> m "unexpected reply") ; Ok `None
| (fd, s, vm) ->
t := IM.remove hdr.id !t ;
let out = String.concat ~sep:"\n" (P.encode_ru vm ru :: P.encode_vmm vm vmm :: List.map (P.encode_if vm) ifd @ [""]) in
Ok (`Stat (fd, s, out))
end
| x when x = fail_tag ->
let res =
match IM.find hdr.id !t with
| exception Not_found -> `None
| (fd, s, _) -> `Sockaddr (fd, s)
in
t := IM.remove hdr.id !t ;
decode_str data >>= fun (msg, _) ->
Logs.err (fun m -> m "failed %s" msg) ;
Ok res
| x -> Rresult.R.error_msgf "ignoring header tag %02X" x
in
let d (fd, s) = match dec s with
| `Continue -> Lwt.return_unit
| `Close -> Lwt_unix.close fd
| `Not_found -> Logs.err (fun m -> m "sockaddr not found") ; Lwt.return_unit
in
let open Lwt.Infix in
match r with
| Ok `None -> Lwt.return_unit
| Ok (`Sockaddr s) -> d s
| Ok (`Stat (fd, s, out)) ->
(Vmm_lwt.write_raw fd out >>= function
| Ok () -> d (fd, s)
| Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return_unit)
| Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg) ; Lwt.return_unit
let rec tls_listener db tls =
(Vmm_tls.read_tls tls >>= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while reading %s" msg) ;
Lwt.return (Ok ())
| Error _ ->
Logs.err (fun m -> m "received exception in read_tls") ;
Lwt.return (Error ())
| Ok (hdr, data) ->
process db tls hdr data >>= fun () ->
Lwt.return (Ok ())) >>= function
| Ok () -> tls_listener db tls
| Error () -> Lwt.return_unit
let hdr =
String.concat ~sep:"\r\n"
[ "HTTP/1.1 200 OK" ;
"Content-Type: text/plain; version=0.0.4" ;
"\r\n" ]
(* wait for TCP connection, once received request stats from vmmd, and loop *)
let rec tcp_listener db tcp tls =
Lwt_unix.accept tcp >>= fun (cs, sockaddr) ->
Vmm_lwt.write_raw cs hdr >>= function
| Error _ -> Logs.err (fun m -> m "exception while accepting") ; Lwt.return_unit
| Ok () ->
let l = List.length !known_vms in
let ip, port = match sockaddr with Lwt_unix.ADDR_INET (ip, port) -> ip, port | _ -> invalid_arg "unexpected" in
Logs.info (fun m -> m "connection from %s:%d with %d known" (Unix.string_of_inet_addr ip) port l) ;
(if l = 0 then
Lwt_unix.close cs >|= fun () -> Error ()
else begin
count := SM.add sockaddr (List.length !known_vms) !count ;
Lwt_list.fold_left_s
(fun r vm ->
match r with
| Error () -> Lwt.return (Error ())
| Ok () ->
let vm_id = translate_name db vm in
let out = Vmm_wire.Client.cmd Statistics ~arg:vm_id !command my_version in
t := IM.add !command (cs, sockaddr, vm) !t ;
command := succ !command ;
Vmm_tls.write_tls tls out >|= function
| Ok () -> Ok ()
| Error _ -> Logs.err (fun m -> m "exception while writing") ; Error ())
(Ok ()) !known_vms
end) >>= function
| Ok () -> tcp_listener db tcp tls
| Error () -> Lwt.return_unit
let client cas host port cert priv_key db listen_ip listen_port =
Nocrypto_entropy_lwt.initialize () >>= fun () ->
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 () ->
(* start TCP listening socket *)
let tcp = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in
Lwt_unix.(setsockopt tcp SO_REUSEADDR true) ;
let addr = Lwt_unix.ADDR_INET (Ipaddr_unix.V4.to_inet_addr listen_ip, listen_port) in
Lwt_unix.bind tcp addr >>= fun () ->
Lwt_unix.listen tcp 1 ;
(* setup remote connection to VMMD *)
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
Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
let certificates = `Single cert in
let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun tls ->
(* loop on both tcp and tls connections *)
Lwt.join [ tcp_listener db tcp tls ; tls_listener db tls ])
(fun exn ->
Logs.err (fun m -> m "failed to establish TLS connection: %s"
(Printexc.to_string exn)) ;
Lwt.return_unit)
let run_client _ cas cert key (host, port) db listen_ip listen_port =
Printexc.register_printer (function
| Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x)
| Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
| _ -> None) ;
Sys.(set_signal sigpipe Signal_ignore) ;
let db =
let open Rresult.R.Infix in
match db with
| None -> []
| Some db ->
match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with
| Ok db -> db
| Error (`Msg m) -> Logs.warn (fun f -> f "couldn't parse database %s" m) ; []
in
Lwt_main.run (client cas host port cert key db listen_ip listen_port)
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let host_port : (string * int) Arg.converter =
let parse s =
match String.cut ~sep:":" s with
| None -> `Error "broken: no port specified"
| Some (hostname, port) ->
try
`Ok (hostname, int_of_string port)
with
Not_found -> `Error "failed to parse port"
in
parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p
let cas =
let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in
Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
let client_cert =
let doc = "Use a client certificate chain" in
Arg.(required & pos 1 (some file) None & info [] ~doc)
let client_key =
let doc = "Use a client key" in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let destination =
Arg.(required & pos 3 (some host_port) None & info [] ~docv:"destination"
~doc:"the destination hostname:port to connect to")
let ip : Ipaddr.V4.t Arg.converter =
let parse s =
try
`Ok (Ipaddr.V4.of_string_exn s)
with
Not_found -> `Error "broken"
in
parse, Ipaddr.V4.pp_hum
let address =
let doc = "Address to listen on" in
Arg.(value & opt ip (Ipaddr.V4.of_string_exn "127.0.0.1") & info [ "address" ] ~doc)
let port =
let doc = "TCP port to listen on" in
Arg.(value & opt int 9080 & info [ "port" ] ~doc)
let db =
let doc = "Certificate database" in
Arg.(value & opt (some file) None & info [ "db" ] ~doc)
let cmd =
let doc = "VMM Prometheus connector" in
let man = [
`S "DESCRIPTION" ;
`P "$(tname) connects to a VMMD to gather statistics and serves them for Prometheus via HTTP" ]
in
Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination $ db $ address $ port),
Term.info "vmm_prometheus_stats" ~version:"%%VERSION_NUM%%" ~doc ~man
let () =
match Term.eval cmd
with `Error _ -> exit 1 | _ -> exit 0

View file

@ -1,20 +1,6 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
let asn_version = `AV0
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
let l_exts =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Client_auth]) ]
let d_exts ?len () =
[ (true, (`Basic_constraints (true, len)))
; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ]
let asn_version = `AV2
let timestamps validity =
let now = Ptime_clock.now () in
@ -57,19 +43,6 @@ let sign ?dbname ?certname extensions issuer key csr delta =
match nam with
| `CN name -> Ok name
| _ -> Error (`Msg "cannot happen")) >>= fun certname ->
(match dbname with
| None -> Ok None
| Some dbname ->
Bos.OS.File.exists dbname >>= function
| false -> Ok None
| true ->
Bos.OS.File.read_lines dbname >>= fun content ->
Vmm_core.parse_db content >>= fun db ->
match Vmm_core.find_name db certname with
| Ok serial ->
Logs.info (fun m -> m "reusing serial %s" (Z.to_string serial)) ;
Ok (Some serial)
| Error _ -> Ok None) >>= fun serial ->
timestamps delta >>= fun (valid_from, valid_until) ->
let extensions =
match dbname with
@ -80,11 +53,10 @@ let sign ?dbname ?certname extensions issuer key csr delta =
let capub = `RSA (Nocrypto.Rsa.pub_of_priv priv) in
extensions @ key_ids (X509.CA.info csr).X509.CA.public_key capub
in
let cert = X509.CA.sign csr ?serial ~valid_from ~valid_until ~extensions key issuer in
(match serial, dbname with
| Some _, _ -> Ok () (* already in DB! *)
| _, None -> Ok () (* no DB! *)
| None, Some dbname ->
let cert = X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer in
(match dbname with
| None -> Ok () (* no DB! *)
| Some dbname ->
append dbname (Printf.sprintf "%s %s\n" (Z.to_string (X509.serial cert)) certname)) >>= fun () ->
let enc = X509.Encoding.Pem.Certificate.to_pem_cstruct1 cert in
Bos.OS.File.write Fpath.(v certname + "pem") (Cstruct.to_string enc)
@ -107,11 +79,6 @@ let priv_key ?(bits = 2048) fn name =
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let nam =
let doc = "Name to provision" in
Arg.(required & pos 0 (some string) None & info [] ~doc)

196
app/vmm_stats_pure.ml Normal file
View file

@ -0,0 +1,196 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Astring
open Rresult.R.Infix
open Vmm_core
external sysctl_rusage : int -> Stats.rusage = "vmmanage_sysctl_rusage"
external sysctl_ifcount : unit -> int = "vmmanage_sysctl_ifcount"
external sysctl_ifdata : int -> Stats.ifdata = "vmmanage_sysctl_ifdata"
type vmctx
external vmmapi_open : string -> vmctx = "vmmanage_vmmapi_open"
external vmmapi_close : vmctx -> unit = "vmmanage_vmmapi_close"
external vmmapi_statnames : vmctx -> string list = "vmmanage_vmmapi_statnames"
external vmmapi_stats : vmctx -> int64 list = "vmmanage_vmmapi_stats"
let my_version = `AV2
let descr = ref []
type 'a t = {
pid_nic : ((vmctx, int) result * (int * string) list) IM.t ;
vmid_pid : int Vmm_trie.t ;
name_sockets : 'a Vmm_trie.t ;
}
let pp_strings pp taps = Fmt.(list ~sep:(unit ",@ ") string) pp taps
let empty () =
{ pid_nic = IM.empty ; vmid_pid = Vmm_trie.empty ; name_sockets = Vmm_trie.empty }
let remove_entry t name =
let name_sockets = Vmm_trie.remove name t.name_sockets in
{ t with name_sockets }
let rec wrap f arg =
try Some (f arg) with
| Unix.Unix_error (Unix.EINTR, _, _) -> wrap f arg
| e ->
Logs.err (fun m -> m "exception %s" (Printexc.to_string e)) ;
None
let fill_descr ctx =
match !descr with
| [] ->
begin match wrap vmmapi_statnames ctx with
| None ->
Logs.err (fun m -> m "vmmapi_statnames failed, shouldn't happen") ;
()
| Some d ->
Logs.debug (fun m -> m "descr are %a" pp_strings d) ;
descr := d
end
| ds -> Logs.debug (fun m -> m "%d descr are already present" (List.length ds))
let open_vmmapi ?(retries = 4) pid =
let name = "solo5-" ^ string_of_int pid in
if retries = 0 then begin
Logs.debug (fun m -> m "(ignored 0) vmmapi_open failed for %d" pid) ;
Error 0
end else
match wrap vmmapi_open name with
| None ->
let left = max 0 (pred retries) in
Logs.warn (fun m -> m "(ignored, %d attempts left) vmmapi_open failed for %d" left pid) ;
Error left
| Some vmctx ->
Logs.info (fun m -> m "vmmapi_open succeeded for %d" pid) ;
fill_descr vmctx ;
Ok vmctx
let try_open_vmmapi pid_nic =
IM.fold (fun pid (vmctx, nics) fresh ->
let vmctx =
match vmctx with
| Ok vmctx -> Ok vmctx
| Error retries -> open_vmmapi ~retries pid
in
IM.add pid (vmctx, nics) fresh)
pid_nic IM.empty
let gather pid vmctx nics =
wrap sysctl_rusage pid,
(match vmctx with
| Error _ -> None
| Ok vmctx -> wrap vmmapi_stats vmctx),
List.fold_left (fun ifd (nic, nname) ->
match wrap sysctl_ifdata nic with
| None ->
Logs.warn (fun m -> m "failed to get ifdata for %s" nname) ;
ifd
| Some data -> data::ifd)
[] nics
let tick t =
let pid_nic = try_open_vmmapi t.pid_nic in
let t' = { t with pid_nic } in
let outs =
List.fold_left (fun out (vmid, pid) ->
let listeners = Vmm_trie.collect vmid t'.name_sockets in
match listeners with
| [] -> Logs.warn (fun m -> m "nobody is listening") ; out
| xs -> match IM.find_opt pid t.pid_nic with
| None -> Logs.warn (fun m -> m "couldn't find nics of %d" pid) ; out
| Some (vmctx, nics) ->
let ru, vmm, ifd = gather pid vmctx nics in
match ru with
| None -> Logs.err (fun m -> m "failed to get rusage for %d" pid) ; out
| Some ru' ->
let stats =
let vmm' = match vmm with None -> None | Some xs -> Some (List.combine !descr xs) in
ru', vmm', ifd
in
List.fold_left (fun out (id, socket) ->
match Vmm_core.drop_super ~super:id ~sub:vmid with
| None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.pp_id id Vmm_core.pp_id vmid) ; out
| Some real_id ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id = real_id } in
((socket, vmid, (header, `Data (`Stats_data stats))) :: out))
out xs)
[] (Vmm_trie.all t'.vmid_pid)
in
(t', outs)
let add_pid t vmid pid nics =
match wrap sysctl_ifcount () with
| None ->
Logs.err (fun m -> m "sysctl ifcount failed for %d %a" pid pp_strings nics) ;
Error (`Msg "sysctl ifcount failed")
| Some max_nic ->
let rec go cnt acc id =
if id > 0 && cnt > 0 then
match wrap sysctl_ifdata id with
| Some ifd when List.mem ifd.Vmm_core.Stats.name nics ->
go (pred cnt) ((id, ifd.Vmm_core.Stats.name) :: acc) (pred id)
| _ -> go cnt acc (pred id)
else
List.rev acc
in
Ok (go (List.length nics) [] max_nic) >>= fun nic_ids ->
let vmctx = open_vmmapi pid in
Logs.info (fun m -> m "adding %d %a with vmctx %b" pid pp_strings nics
(match vmctx with Error _ -> false | Ok _ -> true)) ;
let pid_nic = IM.add pid (vmctx, nic_ids) t.pid_nic
and vmid_pid, ret = Vmm_trie.insert vmid pid t.vmid_pid
in
assert (ret = None) ;
Ok { t with pid_nic ; vmid_pid }
let remove_vmid t vmid =
Logs.info (fun m -> m "removing vmid %a" Vmm_core.pp_id vmid) ;
match Vmm_trie.find vmid t.vmid_pid with
| None -> Logs.warn (fun m -> m "no pid found for %a" Vmm_core.pp_id vmid) ; t
| Some pid ->
Logs.info (fun m -> m "removing pid %d" pid) ;
(try
match IM.find pid t.pid_nic with
| Ok vmctx, _ -> ignore (wrap vmmapi_close vmctx)
| Error _, _ -> ()
with
_ -> ()) ;
let pid_nic = IM.remove pid t.pid_nic
and vmid_pid = Vmm_trie.remove vmid t.vmid_pid
in
{ t with pid_nic ; vmid_pid }
let remove_vmids t vmids =
List.fold_left remove_vmid t vmids
let handle t socket (header, wire) =
if not (Vmm_commands.version_eq my_version header.Vmm_commands.version) then begin
Logs.err (fun m -> m "invalid version %a (mine is %a)"
Vmm_commands.pp_version header.Vmm_commands.version
Vmm_commands.pp_version my_version) ;
Error (`Msg "cannot handle version")
end else
match wire with
| `Command (`Stats_cmd cmd) ->
begin
let id = header.Vmm_commands.id in
match cmd with
| `Stats_add (pid, taps) ->
add_pid t id pid taps >>= fun t ->
Ok (t, `Add id, "added")
| `Stats_remove ->
let t = remove_vmid t id in
Ok (t, `Remove id, "removed")
| `Stats_subscribe ->
let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in
Ok ({ t with name_sockets }, `Close close, "subscribed")
end
| _ ->
Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire (header, wire)) ;
Error (`Msg "unexpected command")

256
app/vmmc_bistro.ml Normal file
View file

@ -0,0 +1,256 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let version = `AV2
let process fd =
Vmm_tls_lwt.read_tls fd >|= function
| Error _ ->
Error (`Msg "read or parse error")
| Ok (header, reply) ->
if Vmm_commands.version_eq header.Vmm_commands.version version then begin
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) ;
Ok ()
end else begin
Logs.err (fun m -> m "version not equal") ;
Error (`Msg "version not equal")
end
let connect socket_path =
let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.set_close_on_exec c ;
Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
c
let read fd =
(* now we busy read and process output *)
let rec loop () =
process fd >>= function
| Error e -> Lwt.return (Error e)
| Ok () -> loop ()
in
loop ()
let key_ids pub issuer =
let auth = (Some (X509.key_id issuer), [], None) in
[ (false, `Subject_key_id (X509.key_id pub)) ; (false, `Authority_key_id auth) ]
let timestamps validity =
let now = Ptime_clock.now () in
match Ptime.add_span now (Ptime.Span.of_int_s validity) with
| None -> invalid_arg "span too big - reached end of ptime"
| Some exp -> (now, exp)
let handle (host, port) cert key ca id (cmd : Vmm_commands.t) =
Vmm_lwt.read_from_file cert >>= fun cert_cs ->
let cert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 cert_cs in
Vmm_lwt.read_from_file key >>= fun key_cs ->
let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in
let tmpkey = Nocrypto.Rsa.generate 4096 in
let name = Vmm_core.string_of_id id in
let extensions =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Client_auth]) ;
(false, `Unsupported (Vmm_asn.oid, Vmm_asn.cert_extension_to_cstruct (version, cmd))) ] in
let csr =
let name = [ `CN name ] in
X509.CA.request name ~extensions:[`Extensions extensions] (`RSA tmpkey)
in
let mycert =
let valid_from, valid_until = timestamps 300 in
let extensions =
let capub = match key with `RSA key -> Nocrypto.Rsa.pub_of_priv key in
extensions @ key_ids (X509.CA.info csr).X509.CA.public_key (`RSA capub)
in
let issuer = X509.subject cert in
X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer
in
let certificates = `Single ([ mycert ; cert ], tmpkey) in
X509_lwt.authenticator (`Ca_file ca) >>= fun authenticator ->
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
Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
read t
let jump endp cert key ca name cmd =
match
Lwt_main.run (handle endp cert key ca name cmd)
with
| Ok () -> `Ok ()
| 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_policy _ endp cert key ca name =
jump endp cert key ca name (`Policy_cmd `Policy_info)
let remove_policy _ endp cert key ca name =
jump endp cert key ca name (`Policy_cmd `Policy_remove)
let add_policy _ endp cert key ca name vms memory cpus block bridges =
let p = Vmm_cli.policy vms memory cpus block bridges in
jump endp cert key ca name (`Policy_cmd (`Policy_add p))
let destroy _ endp cert key ca name =
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 compression =
match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
| Ok cmd -> jump endp cert key ca name (`Vm_cmd cmd)
| Error (`Msg msg) -> `Error (false, msg)
let console _ endp cert key ca name since =
jump endp cert key ca name (`Console_cmd (`Console_subscribe since))
let stats _ endp cert key ca name =
jump endp cert key ca name (`Stats_cmd `Stats_subscribe)
let event_log _ endp cert key ca name since =
jump endp cert key ca 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 Vmm_cli
let server_ca =
let doc = "The certificate authority used to verify the remote server." in
Arg.(value & opt string "cacert.pem" & info [ "server-ca" ] ~doc)
let ca_cert =
let doc = "The certificate authority used to issue the certificate" in
Arg.(value & opt string "ca.pem" & info [ "ca" ] ~doc)
let ca_key =
let doc = "The private key of the signing certificate authority" in
Arg.(value & opt string "ca.key" & info [ "ca-key" ] ~doc)
let destination =
Arg.(required & pos 0 (some host_port) None & info [] ~docv:"destination"
~doc:"the destination hostname:port to connect to")
let image =
let doc = "File of virtual machine image." in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let vm_name =
let doc = "Name virtual machine." in
Arg.(required & pos 1 (some vm_c) None & info [] ~doc)
let destroy_cmd =
let doc = "destroys a virtual machine" in
let man =
[`S "DESCRIPTION";
`P "Destroy a virtual machine."]
in
Term.(ret (const destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name)),
Term.info "destroy" ~doc ~man
let remove_policy_cmd =
let doc = "removes a policy" in
let man =
[`S "DESCRIPTION";
`P "Removes a policy."]
in
Term.(ret (const remove_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
Term.info "remove_policy" ~doc ~man
let info_cmd =
let doc = "information about VMs" in
let man =
[`S "DESCRIPTION";
`P "Shows information about VMs."]
in
Term.(ret (const info_ $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
Term.info "info" ~doc ~man
let policy_cmd =
let doc = "active policies" in
let man =
[`S "DESCRIPTION";
`P "Shows information about policies."]
in
Term.(ret (const info_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)),
Term.info "policy" ~doc ~man
let add_policy_cmd =
let doc = "Add a policy" in
let man =
[`S "DESCRIPTION";
`P "Adds a policy."]
in
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
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 $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ vm_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 $ destination $ ca_cert $ ca_key $ server_ca $ 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 $ destination $ ca_cert $ ca_key $ server_ca $ 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 $ destination $ ca_cert $ ca_key $ server_ca $ 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 conex commands and subcommands"]
in
Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ topic)),
Term.info "help" ~doc ~man
let default_cmd =
let doc = "VMM client and go to bistro" in
let man = [
`S "DESCRIPTION" ;
`P "$(tname) executes the provided subcommand on a remote albatross" ]
in
Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "vmmc_bistro" ~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

215
app/vmmc_local.ml Normal file
View file

@ -0,0 +1,215 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let version = `AV2
let process fd =
Vmm_lwt.read_wire fd >|= function
| Error _ ->
Error (`Msg "read or parse error")
| Ok (header, reply) ->
if Vmm_commands.version_eq header.Vmm_commands.version version then begin
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) ;
Ok ()
end else begin
Logs.err (fun m -> m "version not equal") ;
Error (`Msg "version not equal")
end
let socket t = function
| Some x -> x
| None -> Vmm_core.socket_path t
let connect socket_path =
let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.set_close_on_exec c ;
Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
c
let read fd =
(* now we busy read and process output *)
let rec loop () =
process fd >>= function
| Error e -> Lwt.return (Error e)
| Ok () -> loop ()
in
loop ()
let handle opt_socket id (cmd : Vmm_commands.t) =
let sock, next = Vmm_commands.endpoint cmd in
connect (socket sock opt_socket) >>= fun fd ->
let header = Vmm_commands.{ version ; sequence = 0L ; id } in
Vmm_lwt.write_wire fd (header, `Command cmd) >>= function
| Error `Exception -> Lwt.return (Error (`Msg "couldn't write"))
| Ok () ->
(match next with
| `Read -> read fd
| `End -> process fd) >>= fun res ->
Vmm_lwt.safe_close fd >|= fun () ->
res
let jump opt_socket name cmd =
match
Lwt_main.run (handle opt_socket name cmd)
with
| Ok () -> `Ok ()
| Error (`Msg m) -> `Error (false, m)
let info_ _ opt_socket name = jump opt_socket name (`Vm_cmd `Vm_info)
let info_policy _ opt_socket name =
jump opt_socket name (`Policy_cmd `Policy_info)
let remove_policy _ opt_socket name =
jump opt_socket name (`Policy_cmd `Policy_remove)
let add_policy _ opt_socket name vms memory cpus block bridges =
let p = Vmm_cli.policy vms memory cpus block bridges in
jump opt_socket name (`Policy_cmd (`Policy_add p))
let destroy _ opt_socket name =
jump opt_socket name (`Vm_cmd `Vm_destroy)
let create _ opt_socket force name image cpuid requested_memory boot_params block_device network compression =
match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
| Ok cmd -> jump opt_socket name (`Vm_cmd cmd)
| Error (`Msg msg) -> `Error (false, msg)
let console _ opt_socket name since =
jump opt_socket name (`Console_cmd (`Console_subscribe since))
let stats _ opt_socket name =
jump opt_socket name (`Stats_cmd `Stats_subscribe)
let event_log _ opt_socket name since =
jump opt_socket 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 Vmm_cli
let socket =
let doc = "Socket to connect to" in
Arg.(value & opt (some string) None & info [ "socket" ] ~doc)
let image =
let doc = "File of virtual machine image." in
Arg.(required & pos 1 (some file) None & info [] ~doc)
let vm_name =
let doc = "Name virtual machine." in
Arg.(required & pos 0 (some vm_c) None & info [] ~doc)
let destroy_cmd =
let doc = "destroys a virtual machine" in
let man =
[`S "DESCRIPTION";
`P "Destroy a virtual machine."]
in
Term.(ret (const destroy $ setup_log $ socket $ vm_name)),
Term.info "destroy" ~doc ~man
let remove_policy_cmd =
let doc = "removes a policy" in
let man =
[`S "DESCRIPTION";
`P "Removes a policy."]
in
Term.(ret (const remove_policy $ setup_log $ socket $ opt_vm_name)),
Term.info "remove_policy" ~doc ~man
let info_cmd =
let doc = "information about VMs" in
let man =
[`S "DESCRIPTION";
`P "Shows information about VMs."]
in
Term.(ret (const info_ $ setup_log $ socket $ opt_vm_name)),
Term.info "info" ~doc ~man
let policy_cmd =
let doc = "active policies" in
let man =
[`S "DESCRIPTION";
`P "Shows information about policies."]
in
Term.(ret (const info_policy $ setup_log $ socket $ opt_vm_name)),
Term.info "policy" ~doc ~man
let add_policy_cmd =
let doc = "Add a policy" in
let man =
[`S "DESCRIPTION";
`P "Adds a policy."]
in
Term.(ret (const add_policy $ setup_log $ socket $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)),
Term.info "add_policy" ~doc ~man
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 $ socket $ force $ vm_name $ image $ cpu $ vm_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 $ socket $ 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 $ socket $ 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 $ socket $ 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 $ socket $ 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 $ socket $ 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

75
app/vmmc_remote.ml Normal file
View file

@ -0,0 +1,75 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let rec read_tls_write_cons t =
Vmm_tls_lwt.read_tls t >>= function
| Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit
| Ok wire ->
Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire) ;
read_tls_write_cons t
let client cas host port cert priv_key =
Nocrypto_entropy_lwt.initialize () >>= fun () ->
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
Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
let certificates = `Single cert in
let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
read_tls_write_cons t)
(fun exn ->
Logs.err (fun m -> m "failed to establish TLS connection: %s"
(Printexc.to_string exn)) ;
Lwt.return_unit)
let run_client _ cas cert key (host, port) =
Printexc.register_printer (function
| Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x)
| Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
| _ -> None) ;
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run (client cas host port cert key)
open Cmdliner
open Vmm_cli
let cas =
let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in
Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
let client_cert =
let doc = "Use a client certificate chain" in
Arg.(required & pos 1 (some file) None & info [] ~doc)
let client_key =
let doc = "Use a client key" in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let destination =
Arg.(required & pos 3 (some host_port) None & info [] ~docv:"destination"
~doc:"the destination hostname:port to connect to")
let cmd =
let doc = "VMM remote TLS client" in
let man = [
`S "DESCRIPTION" ;
`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 "vmmc_remote" ~version:"%%VERSION_NUM%%" ~doc ~man
let () =
match Term.eval cmd
with `Error _ -> exit 1 | _ -> exit 0

View file

@ -1,5 +1,7 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_cli
type stats = {
start : Ptime.t ;
vm_created : int ;
@ -16,296 +18,188 @@ let pp_stats ppf s =
open Lwt.Infix
let write_raw s data =
Vmm_lwt.write_raw s data >|= fun _ -> ()
let version = `AV2
let write_tls state t data =
Vmm_tls.write_tls (fst t) data >>= function
| Ok () -> Lwt.return_unit
| Error `Exception ->
let state', out = Vmm_engine.handle_disconnect !state t in
state := state' ;
Lwt_list.iter_s (fun (s, data) -> write_raw s data) out >>= fun () ->
Tls_lwt.Unix.close (fst t)
let state = ref (Vmm_vmmd.init version)
let to_ipaddr (_, sa) = match sa with
| Lwt_unix.ADDR_UNIX _ -> invalid_arg "cannot convert unix address"
| Lwt_unix.ADDR_INET (addr, port) -> Ipaddr_unix.V4.of_inet_addr_exn addr, port
let pp_sockaddr ppf (_, sa) = match sa with
| Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
| Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
(Unix.string_of_inet_addr addr) port
let process state xs =
Lwt_list.iter_s (function
| `Raw (s, str) -> write_raw s str
| `Tls (s, str) -> write_tls state s str)
xs
let handle ca state t =
Logs.debug (fun m -> m "connection from %a" pp_sockaddr t) ;
let authenticator =
let time = Ptime_clock.now () in
X509.Authenticator.chain_of_trust ~time ~crls:!state.Vmm_engine.crls [ca]
in
Lwt.catch
(fun () -> Tls_lwt.Unix.reneg ~authenticator (fst t))
(fun e ->
(match e with
| Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a))
| Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f))
| exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ;
Tls_lwt.Unix.close (fst t) >>= fun () ->
Lwt.fail e) >>= fun () ->
(match Tls_lwt.Unix.epoch (fst t) with
| `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
| `Error ->
Tls_lwt.Unix.close (fst t) >>= fun () ->
Lwt.fail_with "error while getting epoch") >>= fun chain ->
match Vmm_engine.handle_initial !state t (to_ipaddr t) chain ca with
| Ok (state', outs, next) ->
state := state' ;
process state outs >>= fun () ->
begin match next with
| `Create (task, next) ->
(match task with
| None -> Lwt.return_unit
| Some (kill, wait) -> kill () ; wait) >>= fun () ->
let await, wakeme = Lwt.wait () in
begin match next !state await with
| Ok (state', outs, cont) ->
state := state' ;
process state outs >>= fun () ->
begin match cont !state t with
| Ok (state', outs, vm) ->
state := state' ;
s := { !s with vm_created = succ !s.vm_created } ;
Lwt.async (fun () ->
Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r ->
let state', outs = Vmm_engine.handle_shutdown !state vm r in
s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
state := state' ;
process state outs >|= fun () ->
Lwt.wakeup wakeme ()) ;
process state outs >>= fun () ->
begin match Vmm_engine.setup_stats !state vm with
| Ok (state', outs) ->
state := state' ;
process state outs
| Error (`Msg e) ->
Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ;
Lwt.return_unit
end
| Error (`Msg e) ->
Logs.err (fun m -> m "error while create %s" e) ;
let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
process state [ `Tls (t, err) ]
end
| Error (`Msg e) ->
Logs.err (fun m -> m "error while cont %s" e) ;
let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
process state [ `Tls (t, err) ]
end >>= fun () ->
Tls_lwt.Unix.close (fst t)
| `Loop (prefix, perms) ->
let rec loop () =
Vmm_tls.read_tls (fst t) >>= function
let create process cont =
let await, wakeme = Lwt.wait () in
match cont !state await with
| Error (`Msg msg) ->
Logs.err (fun m -> m "create continuation failed %s" msg) ;
Lwt.return_unit
| Ok (state'', out, name, vm) ->
state := state'' ;
s := { !s with vm_created = succ !s.vm_created } ;
Lwt.async (fun () ->
Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r ->
let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in
s := { !s with vm_destroyed = succ !s.vm_destroyed } ;
state := state' ;
(process out' >|= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "reading client %a error: %s" pp_sockaddr t msg) ;
loop ()
| Error _ ->
Logs.err (fun m -> m "disconnect from %a" pp_sockaddr t) ;
let state', cons = Vmm_engine.handle_disconnect !state t in
state := state' ;
Lwt_list.iter_s (fun (s, data) -> write_raw s data) cons >>= fun () ->
Tls_lwt.Unix.close (fst t)
| Ok (hdr, buf) ->
let state', out = Vmm_engine.handle_command !state t prefix perms hdr buf in
state := state' ;
process state out >>= fun () ->
loop ()
in
loop ()
| `Close socks ->
Logs.debug (fun m -> m "closing session with %d active ones" (List.length socks)) ;
Lwt_list.iter_s (fun (t, _) -> Tls_lwt.Unix.close t) socks >>= fun () ->
Tls_lwt.Unix.close (fst t)
end
| Error (`Msg e) ->
Logs.err (fun m -> m "VMM %a %s" pp_sockaddr t e) ;
let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in
process state [`Tls (t, err)] >>= fun () ->
Tls_lwt.Unix.close (fst t)
Logs.err (fun m -> m "error %s on handling shutdown" msg)
| Ok () -> ()) >|= fun () ->
Lwt.wakeup wakeme ()) ;
(process out >|= function
| Error (`Msg msg) -> Logs.err (fun m -> m "error %s while setting up stats and logging" msg)
| Ok () -> ()) >>= fun () ->
let state', out = Vmm_vmmd.setup_stats !state name vm in
state := state' ;
process [ out ] >|= function
| Error (`Msg msg) -> Logs.err (fun m -> m "error %s sending information to stats" msg)
| Ok () -> ()
let server_socket port =
let open Lwt_unix in
let s = socket PF_INET SOCK_STREAM 0 in
set_close_on_exec s ;
setsockopt s SO_REUSEADDR true ;
bind s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () ->
listen s 10 ;
Lwt.return s
let handle out fd addr =
Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ;
(* now we need to read a packet and handle it
(1)
(a) easy for info (look up name/prefix in resources)
(b) destroy looks up vm in resources, executes kill (wait for pid will do the cleanup)
logs "destroy issued"
(c) create initiates the vm startup procedure:
write image file, create fifo, create tap(s), send fifo to console
-- Lwt effects happen (console) --
executes solo5-hvt + waiter, send stats pid and taps, inserts await into state, logs "created vm"
-- Lwt effects happen (stats, logs, wait_and_clear) --
(2) goto (1)
*)
let process wires =
Lwt_list.fold_left_s (fun r data ->
match r, data with
| Ok (), (#Vmm_vmmd.service_out as o) -> out o
| Ok (), `Data wire ->
(* rather: terminate connection *)
Vmm_lwt.write_wire fd wire >|= fun _ ->
Ok ()
| Error e, _ -> Lwt.return (Error e))
(Ok ()) wires
in
Logs.debug (fun m -> m "now reading") ;
(Vmm_lwt.read_wire fd >>= function
| Error _ ->
Logs.err (fun m -> m "error while reading") ;
Lwt.return_unit
| Ok wire ->
Logs.debug (fun m -> m "read sth") ;
let state', data, next = Vmm_vmmd.handle_command !state wire in
state := state' ;
process data >>= function
| Error (`Msg msg) -> Logs.err (fun m -> m "received error %s" msg) ; Lwt.return_unit
| Ok () -> match next with
| `End -> Lwt.return_unit
| `Wait (task, out) ->
task >>= fun () ->
process [ out ] >|= fun _ ->
()
| `Wait_and_create (task, next) ->
task >>= fun () ->
let state', data, n = next !state in
state := state' ;
process data >>= fun _ ->
(match n with
| `End -> Lwt.return_unit
| `Create cont -> create process cont)
| `Create cont ->
create process cont
(* data contained a write to console, we need to wait for its reply first *)
) >>= fun () ->
Vmm_lwt.safe_close fd
let init_sock dir name =
let init_sock sock =
let name = Vmm_core.socket_path sock in
let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.set_close_on_exec c ;
let addr = Fpath.(dir / name + "sock") in
Lwt.catch (fun () ->
Lwt_unix.(connect c (ADDR_UNIX (Fpath.to_string addr))) >|= fun () -> Some c)
Lwt_unix.(connect c (ADDR_UNIX name)) >|= fun () -> Some c)
(fun e ->
Logs.warn (fun m -> m "error %s connecting to socket %a"
(Printexc.to_string e) Fpath.pp addr) ;
Logs.warn (fun m -> m "error %s connecting to socket %s"
(Printexc.to_string e) name) ;
(Lwt.catch (fun () -> Lwt_unix.close c) (fun _ -> Lwt.return_unit)) >|= fun () ->
None)
let rec read_log state s =
Vmm_lwt.read_exactly s >>= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "reading log error %s" msg) ;
read_log state s
| Error _ ->
Logs.err (fun m -> m "exception while reading log") ;
invalid_arg "log socket communication issue"
| Ok (hdr, data) ->
let state', outs = Vmm_engine.handle_log !state hdr data in
state := state' ;
process state outs >>= fun () ->
read_log state s
let create_mbox sock =
init_sock sock >|= function
| None -> None
| Some fd ->
let mvar = Lwt_mvar.create_empty () in
(* could be more elaborate:
if <log> fails, we can reconnect and spit our more log messages to the new socket
if <console> fails, all running VMs terminate, so we can terminate as well ;)
if <stat> fails, we'd need to retransmit all VM info to stat (or stat has to ask at connect) *)
let rec loop () =
Lwt_mvar.take mvar >>= fun data ->
Vmm_lwt.write_wire fd data >>= function
| Ok () -> loop ()
| Error `Exception -> invalid_arg ("exception while writing to " ^ Fmt.to_to_string Vmm_core.pp_socket sock) ;
in
Lwt.async loop ;
Some (mvar, fd)
let rec read_cons state s =
Vmm_lwt.read_exactly s >>= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "reading console error %s" msg) ;
read_cons state s
| Error _ ->
Logs.err (fun m -> m "exception while reading console socket") ;
invalid_arg "console socket communication issue"
| Ok (hdr, data) ->
let state', outs = Vmm_engine.handle_cons !state hdr data in
state := state' ;
process state outs >>= fun () ->
read_cons state s
let rec read_stats state s =
Vmm_lwt.read_exactly s >>= function
| Error (`Msg msg) ->
Logs.err (fun m -> m "reading stats error %s" msg) ;
read_stats state s
| Error _ ->
Logs.err (fun m -> m "exception while reading stats") ;
Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
invalid_arg "stat socket communication issue"
| Ok (hdr, data) ->
let state', outs = Vmm_engine.handle_stat !state hdr data in
state := state' ;
process state outs >>= fun () ->
read_stats state s
let cmp_s (_, a) (_, b) =
let open Lwt_unix in
match a, b with
| ADDR_UNIX str, ADDR_UNIX str' -> String.compare str str' = 0
| ADDR_INET (addr, port), ADDR_INET (addr', port') ->
port = port' &&
String.compare (Unix.string_of_inet_addr addr) (Unix.string_of_inet_addr addr') = 0
| _ -> false
let server_socket sock =
let name = Vmm_core.socket_path sock in
(Lwt_unix.file_exists name >>= function
| true -> Lwt_unix.unlink name
| false -> Lwt.return_unit) >>= fun () ->
let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.set_close_on_exec s ;
Lwt_unix.(bind s (ADDR_UNIX name)) >|= fun () ->
Lwt_unix.listen s 1 ;
s
let rec stats_loop () =
Logs.info (fun m -> m "%a" pp_stats !s) ;
Lwt_unix.sleep 600. >>= fun () ->
stats_loop ()
let jump _ cacert cert priv_key port =
let jump _ =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run
(Nocrypto_entropy_lwt.initialize () >>= fun () ->
(init_sock Vmm_core.tmpdir "cons" >|= function
(server_socket `Vmmd >>= fun ss ->
(create_mbox `Console >|= function
| None -> invalid_arg "cannot connect to console socket"
| Some c -> c) >>= fun c ->
init_sock Vmm_core.tmpdir "stat" >>= fun s ->
(init_sock Vmm_core.tmpdir "log" >|= function
| Some c -> c) >>= fun (c, c_fd) ->
create_mbox `Stats >>= fun s ->
(create_mbox `Log >|= function
| None -> invalid_arg "cannot connect to log socket"
| Some l -> l) >>= fun l ->
server_socket port >>= fun socket ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
X509_lwt.certs_of_pem cacert >>= (function
| [ ca ] -> Lwt.return ca
| _ -> Lwt.fail_with "expect single ca as cacert") >>= fun ca ->
let config =
Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2)
~reneg:true ~certificates:(`Single cert) ())
| Some l -> l) >>= fun (l, l_fd) ->
let write_reply (header, cmd) mvar fd =
Lwt_mvar.put mvar (header, cmd) >>= fun () ->
Vmm_lwt.read_wire fd >|= function
| Ok (header', reply) ->
if not Vmm_commands.(version_eq header.version header'.version) then
Error (`Msg "wrong version in reply")
else if not Vmm_commands.(Int64.equal header.sequence header'.sequence) then
Error (`Msg "wrong id in reply")
else begin match reply with
| `Success _ -> Ok ()
| `Failure msg -> Error (`Msg msg)
| _ -> Error (`Msg "unexpected data")
end
| Error _ -> Error (`Msg "error in read")
in
let out = function
| `Stat wire ->
begin match s with
| None -> Lwt.return (Ok ())
| Some (s, s_fd) -> write_reply wire s s_fd
end
| `Log wire -> write_reply wire l l_fd
| `Cons wire -> write_reply wire c c_fd
in
(match Vmm_engine.init cmp_s c s l with
| Ok s -> Lwt.return s
| Error (`Msg m) -> Lwt.fail_with m) >>= fun t ->
let state = ref t in
Lwt.async (fun () -> read_cons state c) ;
(match s with
| None -> ()
| Some s -> Lwt.async (fun () -> read_stats state s)) ;
Lwt.async (fun () -> read_log state l) ;
Lwt.async stats_loop ;
let rec loop () =
Lwt.catch (fun () ->
Lwt_unix.accept socket >>= fun (fd, addr) ->
Lwt_unix.set_close_on_exec fd ;
Lwt.catch
(fun () -> Tls_lwt.Unix.server_of_fd config fd >|= fun t -> (t, addr))
(fun exn ->
Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () ->
Lwt.fail exn) >>= fun t ->
Lwt.async (fun () ->
Lwt.catch
(fun () -> handle ca state t)
(fun e ->
Logs.err (fun m -> m "error while handle() %s"
(Printexc.to_string e)) ;
Lwt.return_unit)) ;
loop ())
(function
| Unix.Unix_error (e, f, _) ->
Logs.err (fun m -> m "Unix error %s in %s" (Unix.error_message e) f) ;
loop ()
| Tls_lwt.Tls_failure a ->
Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
loop ()
| exn ->
Logs.err (fun m -> m "exception %s" (Printexc.to_string exn)) ;
loop ())
Lwt_unix.accept ss >>= fun (fd, addr) ->
Lwt_unix.set_close_on_exec fd ;
Lwt.async (fun () -> handle out fd addr) ;
loop ()
in
loop ())
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let cacert =
let doc = "CA certificate" in
Arg.(required & pos 0 (some file) None & info [] ~doc)
let cert =
let doc = "Certificate" in
Arg.(required & pos 1 (some file) None & info [] ~doc)
let key =
let doc = "Private key" in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let port =
let doc = "TCP listen port" in
Arg.(value & opt int 1025 & info [ "port" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ cacert $ cert $ key $ port)),
Term.(ret (const jump $ setup_log)),
Term.info "vmmd" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

185
app/vmmd_console.ml Normal file
View file

@ -0,0 +1,185 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(* the process responsible for buffering console IO *)
(* communication channel is a single unix domain socket. The following commands
can be issued:
- Add name (by vmmd) --> creates a new console slurper for name,
and starts a read_console task
- Attach name --> attaches console of name: send existing stuff to client,
and record the requesting socket to receive further messages. A potential
earlier subscriber to the same console is closed. *)
open Lwt.Infix
open Astring
let my_version = `AV2
let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
let active = ref String.Map.empty
let read_console name ring channel () =
let id = Vmm_core.id_of_string name in
Lwt.catch (fun () ->
let rec loop () =
Lwt_io.read_line channel >>= fun line ->
Logs.debug (fun m -> m "read %s" line) ;
let t = Ptime_clock.now () in
Vmm_ring.write ring (t, line) ;
(match String.Map.find name !active with
| None -> Lwt.return_unit
| Some fd ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function
| Error _ ->
Vmm_lwt.safe_close fd >|= fun () ->
active := String.Map.remove name !active
| Ok () -> Lwt.return_unit) >>=
loop
in
loop ())
(fun e ->
begin match e with
| Unix.Unix_error (e, f, _) ->
Logs.err (fun m -> m "%s error in %s: %a" name f pp_unix_error e)
| End_of_file ->
Logs.debug (fun m -> m "%s end of file while reading" name)
| exn ->
Logs.err (fun m -> m "%s error while reading %s" name (Printexc.to_string exn))
end ;
Lwt_io.close channel)
let open_fifo name =
let fifo = Fpath.(Vmm_core.tmpdir / "fifo" / name) in
Lwt.catch (fun () ->
Logs.debug (fun m -> m "opening %a for reading" Fpath.pp fifo) ;
Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string fifo) >>= fun channel ->
Lwt.return (Some channel))
(function
| Unix.Unix_error (e, f, _) ->
Logs.err (fun m -> m "%a error in %s: %a" Fpath.pp fifo f pp_unix_error e) ;
Lwt.return None
| exn ->
Logs.err (fun m -> m "%a error while reading %s" Fpath.pp fifo (Printexc.to_string exn)) ;
Lwt.return None)
let t = ref String.Map.empty
let add_fifo id =
let name = Vmm_core.string_of_id id in
open_fifo name >|= function
| Some f ->
let ring = Vmm_ring.create "" () in
Logs.debug (fun m -> m "inserting fifo %s" name) ;
let map = String.Map.add name ring !t in
t := map ;
Lwt.async (read_console name ring f) ;
Ok ()
| None ->
Error (`Msg "opening")
let subscribe s id =
let name = Vmm_core.string_of_id id in
Logs.debug (fun m -> m "attempting to subscribe %a" Vmm_core.pp_id id) ;
match String.Map.find name !t with
| None ->
active := String.Map.add name s !active ;
Lwt.return (None, "waiting for VM")
| Some r ->
(match String.Map.find name !active with
| None -> Lwt.return_unit
| Some s -> Vmm_lwt.safe_close s) >|= fun () ->
active := String.Map.add name s !active ;
(Some r, "subscribed")
let send_history s r id since =
let entries =
match since with
| None -> Vmm_ring.read r
| Some ts -> Vmm_ring.read_history r ts
in
Logs.debug (fun m -> m "%a found %d history" Vmm_core.pp_id id (List.length entries)) ;
Lwt_list.iter_s (fun (i, v) ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >>= function
| Ok () -> Lwt.return_unit
| Error _ -> Vmm_lwt.safe_close s)
entries
let handle s addr () =
Logs.info (fun m -> m "handling connection %a" Vmm_lwt.pp_sockaddr addr) ;
let rec loop () =
Vmm_lwt.read_wire s >>= function
| Error _ ->
Logs.err (fun m -> m "exception while reading") ;
Lwt.return_unit
| Ok (header, `Command (`Console_cmd cmd)) ->
if not (Vmm_commands.version_eq header.Vmm_commands.version my_version) then begin
Logs.err (fun m -> m "ignoring data with bad version") ;
Lwt.return_unit
end else begin
let name = header.Vmm_commands.id in
match cmd with
| `Console_add ->
begin
add_fifo name >>= fun res ->
let reply = match res with
| Ok () -> `Success `Empty
| Error (`Msg msg) -> `Failure msg
in
Vmm_lwt.write_wire s (header, reply) >>= function
| Ok () -> loop ()
| Error _ ->
Logs.err (fun m -> m "error while writing") ;
Lwt.return_unit
end
| `Console_subscribe ts ->
subscribe s name >>= fun (ring, res) ->
Vmm_lwt.write_wire s (header, `Success (`String res)) >>= function
| Error _ -> Vmm_lwt.safe_close s
| Ok () ->
(match ring with
| None -> Lwt.return_unit
| Some r -> send_history s r name ts) >>= fun () ->
(* now we wait for the next read and terminate*)
Vmm_lwt.read_wire s >|= fun _ -> ()
end
| Ok wire ->
Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire wire) ;
Lwt.return ()
in
loop () >>= fun () ->
Vmm_lwt.safe_close s >|= fun () ->
Logs.warn (fun m -> m "disconnected")
let jump _ file =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run
((Lwt_unix.file_exists file >>= function
| true -> Lwt_unix.unlink file
| false -> Lwt.return_unit) >>= fun () ->
let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.(bind s (ADDR_UNIX file)) >>= fun () ->
Lwt_unix.listen s 1 ;
let rec loop () =
Lwt_unix.accept s >>= fun (cs, addr) ->
Lwt.async (handle cs addr) ;
loop ()
in
loop ())
open Cmdliner
open Vmm_cli
let socket =
let doc = "socket to use" in
Arg.(value & opt string (Vmm_core.socket_path `Console) & info [ "socket" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ socket)),
Term.info "vmmd_console" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -5,6 +5,7 @@ open Lwt.Infix
open Astring
open Vmm_core
open Vmm_core.Stats
(*
@ -140,11 +141,9 @@ module P = struct
vm ifd.name (String.concat ~sep:"," fields)
end
let my_version = `WV1
let my_version = `AV2
let command = ref 1
let (req : string IM.t ref) = ref IM.empty
let command = ref 1L
let str_of_e = function
| `Eof -> "end of file"
@ -160,112 +159,71 @@ let safe_close s =
Logs.err (fun m -> m "exception %s while closing" (Printexc.to_string e)) ;
Lwt.return_unit)
let rec read_sock_write_tcp closing db c ?fd addr addrtype =
let rec read_sock_write_tcp c ?fd addr addrtype =
match fd with
| None ->
if !closing then
Lwt.return_unit
else begin
Logs.debug (fun m -> m "new connection to TCP") ;
let fd = Lwt_unix.socket addrtype Lwt_unix.SOCK_STREAM 0 in
Lwt_unix.setsockopt fd Lwt_unix.SO_KEEPALIVE true ;
Lwt.catch
(fun () ->
Lwt_unix.connect fd addr >|= fun () ->
Logs.debug (fun m -> m "connected to TCP") ;
Some fd)
(fun e ->
let addr', port = match addr with
| Lwt_unix.ADDR_INET (ip, port) -> Unix.string_of_inet_addr ip, port
| Lwt_unix.ADDR_UNIX addr -> addr, 0
in
Logs.warn (fun m -> m "error %s connecting to influxd %s:%d, retrying in 5s"
(Printexc.to_string e) addr' port) ;
safe_close fd >>= fun () ->
Lwt_unix.sleep 5.0 >|= fun () ->
None) >>= fun fd ->
read_sock_write_tcp closing db c ?fd addr addrtype
end
Logs.debug (fun m -> m "new connection to TCP") ;
let fd = Lwt_unix.socket addrtype Lwt_unix.SOCK_STREAM 0 in
Lwt_unix.setsockopt fd Lwt_unix.SO_KEEPALIVE true ;
Lwt.catch
(fun () ->
Lwt_unix.connect fd addr >|= fun () ->
Logs.debug (fun m -> m "connected to TCP") ;
Some fd)
(fun e ->
let addr', port = match addr with
| Lwt_unix.ADDR_INET (ip, port) -> Unix.string_of_inet_addr ip, port
| Lwt_unix.ADDR_UNIX addr -> addr, 0
in
Logs.warn (fun m -> m "error %s connecting to influxd %s:%d, retrying in 5s"
(Printexc.to_string e) addr' port) ;
safe_close fd >>= fun () ->
Lwt_unix.sleep 5.0 >|= fun () ->
None) >>= fun fd ->
read_sock_write_tcp c ?fd addr addrtype
| Some fd ->
if !closing then
safe_close fd
else begin
let open Vmm_wire in
Logs.debug (fun m -> m "reading from unix socket") ;
Vmm_lwt.read_exactly c >>= function
| Error e ->
Logs.err (fun m -> m "error %s while reading vmm socket (return)"
(str_of_e e)) ;
closing := true ;
safe_close fd
| Ok (hdr, data) ->
if not (version_eq hdr.version my_version) then begin
Logs.err (fun m -> m "unknown wire protocol version") ;
closing := true ;
safe_close fd
end else
let name =
try IM.find hdr.id !req
with Not_found -> "not found"
in
req := IM.remove hdr.id !req ;
begin match Stats.int_to_op hdr.tag with
| Some Stats.Stat_reply ->
begin match Vmm_wire.Stats.decode_stats (Cstruct.of_string data) with
| Error (`Msg msg) ->
Logs.warn (fun m -> m "error %s while decoding stats %s, ignoring"
msg name) ;
Lwt.return (Some fd)
| Ok (ru, vmm, ifs) ->
let ru = P.encode_ru name ru in
let vmm = P.encode_vmm name vmm in
let taps = List.map (P.encode_if name) ifs in
let out = (String.concat ~sep:"\n" (ru :: vmm :: taps)) ^ "\n" in
Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ;
Vmm_lwt.write_raw fd out >>= function
| Ok () ->
Logs.debug (fun m -> m "wrote successfully") ;
Lwt.return (Some fd)
| Error e ->
Logs.err (fun m -> m "error %s while writing to tcp (%s)"
(str_of_e e) name) ;
safe_close fd >|= fun () ->
None
end
| _ when hdr.tag = fail_tag ->
Logs.err (fun m -> m "failed to retrieve statistics for %s" name) ;
Lwt.return (Some fd)
| _ ->
Logs.err (fun m -> m "unhandled tag %d for %s" hdr.tag name) ;
Lwt.return (Some fd)
end >>= fun fd ->
read_sock_write_tcp closing db c ?fd addr addrtype
end
let rec query_sock closing prefix db c interval =
(* query c for everyone in db *)
if !closing then
Lwt.return_unit
else
Lwt_list.fold_left_s (fun r (id, name) ->
match r with
| Error e -> Lwt.return (Error e)
| Ok () ->
let id = identifier id in
let id = match prefix with None -> id | Some p -> p ^ "." ^ id in
let request = Vmm_wire.Stats.stat !command my_version id in
req := IM.add !command name !req ;
incr command ;
Logs.debug (fun m -> m "%d requesting %s via socket" !command id) ;
Vmm_lwt.write_raw c request)
(Ok ()) db >>= function
Logs.debug (fun m -> m "reading from unix socket") ;
Vmm_lwt.read_wire c >>= function
| Error e ->
Logs.err (fun m -> m "error %s while writing to vmm socket" (str_of_e e)) ;
closing := true ;
Lwt.return_unit
| Ok () ->
Lwt_unix.sleep (float_of_int interval) >>= fun () ->
query_sock closing prefix db c interval
Logs.err (fun m -> m "error %s while reading vmm socket (return)"
(str_of_e e)) ;
safe_close fd >>= fun () ->
safe_close c >|= fun () ->
true
| Ok (hdr, `Data (`Stats_data (ru, vmm, ifs))) ->
begin
if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.err (fun m -> m "unknown wire protocol version") ;
safe_close fd >>= fun () ->
safe_close c >|= fun () ->
false
end else
let name = string_of_id hdr.Vmm_commands.id in
let ru = P.encode_ru name ru in
let vmm = match vmm with None -> [] | Some xs -> [ P.encode_vmm name xs ] in
let taps = List.map (P.encode_if name) ifs in
let out = (String.concat ~sep:"\n" (ru :: vmm @ taps)) ^ "\n" in
Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ;
Vmm_lwt.write_raw fd (Bytes.unsafe_of_string out) >>= function
| Ok () ->
Logs.debug (fun m -> m "wrote successfully") ;
read_sock_write_tcp c ~fd addr addrtype
| Error e ->
Logs.err (fun m -> m "error %s while writing to tcp (%s)"
(str_of_e e) name) ;
safe_close fd >|= fun () ->
false
end
| Ok wire ->
Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ;
Lwt.return (Some fd) >>= fun fd ->
read_sock_write_tcp c ?fd addr addrtype
let query_sock vm c =
let header = Vmm_commands.{ version = my_version ; sequence = !command ; id = vm } in
command := Int64.succ !command ;
Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id vm) ;
Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe))
let rec maybe_connect stat_socket =
let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
@ -282,10 +240,7 @@ let rec maybe_connect stat_socket =
Lwt_unix.sleep (float_of_int 5) >>= fun () ->
maybe_connect stat_socket)
let client stat_socket influxhost influxport db prefix interval =
(* start a socket connection to vmm_stats *)
maybe_connect stat_socket >>= fun c ->
let client stat_socket influxhost influxport vm =
(* figure out address of influx *)
Lwt_unix.gethostbyname influxhost >>= fun host_entry ->
let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in
@ -294,7 +249,7 @@ let client stat_socket influxhost influxport db prefix interval =
in
(* loop *)
(* the query task queries the stat_socket at each interval
(* the query task queries the stat_socket at each
- if this fails, closing is set to true (and unit is returned)
the read_sock reads the stat_socket, and forwards to a TCP socket
@ -306,82 +261,43 @@ let client stat_socket influxhost influxport db prefix interval =
- query_sock/read_sock_write_tcp write an read from it
- on failure in read or write, the TCP connection is closed, and loop
takes control: safe_close, maybe_connect, rinse, repeat *)
let rec loop c =
let closing = ref false in
Lwt.join [
query_sock closing prefix db c interval ;
read_sock_write_tcp closing db c addr addrtype
] >>= fun () ->
safe_close c >>= fun () ->
let rec loop () =
(* start a socket connection to vmm_stats *)
maybe_connect stat_socket >>= fun c ->
loop c
query_sock vm c >>= function
| Error e ->
Logs.err (fun m -> m "error %s while writing to stat socket" (str_of_e e)) ;
Lwt.return_unit
| Ok () ->
read_sock_write_tcp c addr addrtype >>= fun restart ->
if restart then loop () else Lwt.return_unit
in
loop c
loop ()
let run_client _ socket (influxhost, influxport) db prefix interval =
let run_client _ socket (influxhost, influxport) vm =
Sys.(set_signal sigpipe Signal_ignore) ;
let db =
let open Rresult.R.Infix in
match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with
| Ok [] -> invalid_arg "empty database"
| Ok db -> db
| Error (`Msg m) -> invalid_arg ("couldn't parse database " ^ m)
in
Lwt_main.run (client socket influxhost influxport db prefix interval)
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
Lwt_main.run (client socket influxhost influxport vm)
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
let host_port : (string * int) Arg.converter =
let parse s =
match String.cut ~sep:":" s with
| None -> `Error "broken: no port specified"
| Some (hostname, port) ->
try
`Ok (hostname, int_of_string port)
with
Not_found -> `Error "failed to parse port"
in
parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p
open Vmm_cli
let socket =
let doc = "Stat socket to connect onto" in
let sock = Fpath.(to_string (Vmm_core.tmpdir / "stat" + "sock")) in
Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let doc = "socket to use" in
Arg.(value & opt string (Vmm_core.socket_path `Stats) & info [ "socket" ] ~doc)
let influx =
Arg.(required & pos 0 (some host_port) None & info [] ~docv:"influx"
~doc:"the influx hostname:port to connect to")
let db =
let doc = "VMID database" in
Arg.(required & pos 1 (some file) None & info [] ~doc)
let prefix =
let doc = "prefix" in
Arg.(value & opt (some string) None & info [ "prefix" ] ~doc)
let interval =
let doc = "Poll interval in seconds" in
Arg.(value & opt int 10 & info [ "interval" ] ~doc)
let cmd =
let doc = "VMM InfluxDB connector" in
let man = [
`S "DESCRIPTION" ;
`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 $ db $ prefix $ interval),
Term.info "vmm_influxdb_stats" ~version:"%%VERSION_NUM%%" ~doc ~man
Term.(pure run_client $ setup_log $ socket $ influx $ opt_vm_name),
Term.info "vmmd_influx" ~version:"%%VERSION_NUM%%" ~doc ~man
let () =
match Term.eval cmd

193
app/vmmd_log.ml Normal file
View file

@ -0,0 +1,193 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(* the process responsible for event log *)
(* communication channel is a single unix domain socket shared between vmmd and
vmm_log. There are two commands from vmmd to vmm_log, history and data. *)
(* internally, a ring buffer for the last N events is preserved in memory
each new event is directly written to disk! *)
open Lwt.Infix
let my_version = `AV2
let broadcast prefix wire t =
Lwt_list.fold_left_s (fun t (id, s) ->
Vmm_lwt.write_wire s wire >|= function
| Ok () -> t
| Error `Exception -> Vmm_trie.remove id t)
t (Vmm_trie.collect prefix t)
let write_complete s cs =
let l = Cstruct.len cs in
let b = Cstruct.to_bytes cs in
let rec w off =
let len = l - off in
Lwt_unix.write s b off len >>= fun n ->
if n = len then Lwt.return_unit else w (off + n)
in
w 0
let read_from_file file =
Vmm_lwt.read_from_file file >|= fun data ->
let logs = Vmm_asn.logs_of_disk my_version data in
List.rev logs
let write_to_file file =
let mvar = Lwt_mvar.create_empty () in
let rec write_loop ?(retry = true) ?log_entry ?fd () =
match fd with
| None when retry ->
Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd ->
write_loop ~retry:false ?log_entry ~fd ()
| None ->
Logs.err (fun m -> m "retry is false, exiting") ;
Lwt.return_unit
| Some fd ->
(match log_entry with
| None -> Lwt_mvar.take mvar
| Some l -> Lwt.return l) >>= fun log_entry ->
let data = Vmm_asn.log_to_disk my_version log_entry in
Lwt.catch
(fun () -> write_complete fd data >|= fun () -> (true, None, Some fd))
(fun e ->
Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ;
Vmm_lwt.safe_close fd >|= fun () ->
(retry, Some log_entry, None)) >>= fun (retry, log_entry, fd) ->
write_loop ~retry ?log_entry ?fd ()
in
mvar, write_loop
let send_history s ring id ts =
let elements =
match ts with
| None -> Vmm_ring.read ring
| Some since -> Vmm_ring.read_history ring since
in
let res =
List.fold_left (fun acc (ts, event) ->
let sub = Vmm_core.Log.name event in
if Vmm_core.is_sub_id ~super:id ~sub
then (ts, event) :: acc
else acc)
[] elements
in
(* just need a wrapper in tag = Log.Data, id = reqid *)
Lwt_list.fold_left_s (fun r (ts, event) ->
match r with
| Ok () ->
let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in
Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event)))
| Error e -> Lwt.return (Error e))
(Ok ()) (List.rev res)
let tree = ref Vmm_trie.empty
let handle_data s mvar ring hdr entry =
if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.warn (fun m -> m "unsupported version") ;
Lwt.return_unit
end else begin
Vmm_lwt.write_wire s (hdr, `Success `Empty) >>= fun _ ->
Vmm_ring.write ring entry ;
Lwt_mvar.put mvar entry >>= fun () ->
let data' = (hdr, `Data (`Log_data entry)) in
broadcast hdr.Vmm_commands.id data' !tree >|= fun tree' ->
tree := tree'
end
let read_data mvar ring s =
let rec loop () =
Vmm_lwt.read_wire s >>= function
| Error _ ->
Logs.err (fun m -> m "error while reading") ;
Lwt.return_unit
| Ok (hdr, `Data (`Log_data entry)) ->
handle_data s mvar ring hdr entry >>= fun () ->
loop ()
| Ok wire ->
Logs.warn (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire wire) ;
Lwt.return_unit
in
loop ()
let handle mvar ring s addr () =
Logs.info (fun m -> m "handling connection from %a" Vmm_lwt.pp_sockaddr addr) ;
Vmm_lwt.read_wire s >>= begin function
| Error _ ->
Logs.err (fun m -> m "error while reading") ;
Lwt.return_unit
| Ok (hdr, `Data (`Log_data entry)) ->
handle_data s mvar ring hdr entry >>= fun () ->
read_data mvar ring s
| Ok (hdr, `Command (`Log_cmd lc)) ->
if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin
Logs.warn (fun m -> m "unsupported version") ;
Lwt.return_unit
end else begin
match lc with
| `Log_subscribe ts ->
let tree', ret = Vmm_trie.insert hdr.Vmm_commands.id s !tree in
tree := tree' ;
(match ret with
| None -> Lwt.return_unit
| Some s' -> Vmm_lwt.safe_close s') >>= fun () ->
let out = `Success `Empty in
Vmm_lwt.write_wire s (hdr, out) >>= function
| Error _ -> Logs.err (fun m -> m "error while sending reply for subscribe") ;
Lwt.return_unit
| Ok () ->
send_history s ring hdr.Vmm_commands.id ts >>= function
| Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit
| Ok () ->
(* command processing is finished, but we leave the socket open
until read returns (either with a message we ignore or a failure from the closed connection) *)
Vmm_lwt.read_wire s >|= fun _ -> ()
end
| Ok wire ->
Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ;
Lwt.return_unit
end >>= fun () ->
Vmm_lwt.safe_close s
let jump _ file sock =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run
((Lwt_unix.file_exists sock >>= function
| true -> Lwt_unix.unlink sock
| false -> Lwt.return_unit) >>= fun () ->
let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.(bind s (ADDR_UNIX sock)) >>= fun () ->
Lwt_unix.listen s 1 ;
let ring = Vmm_ring.create `Startup () in
read_from_file file >>= fun entries ->
List.iter (Vmm_ring.write ring) entries ;
let mvar, writer = write_to_file file in
let start = Ptime_clock.now (), `Startup in
Lwt_mvar.put mvar start >>= fun () ->
Vmm_ring.write ring start ;
let rec loop () =
Lwt_unix.accept s >>= fun (cs, addr) ->
Lwt.async (handle mvar ring cs addr) ;
loop ()
in
Lwt.pick [ loop () ; writer () ]) ;
`Ok ()
open Cmdliner
open Vmm_cli
let socket =
let doc = "socket to use" in
Arg.(value & opt string (Vmm_core.socket_path `Log) & info [ "socket" ] ~doc)
let file =
let doc = "File to write the log to" in
Arg.(value & opt string "/var/log/albatross" & info [ "logfile" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ file $ socket)),
Term.info "vmm_log" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

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
@ -23,32 +25,52 @@ let pp_sockaddr ppf = function
let handle s addr () =
Logs.info (fun m -> m "handling stats connection %a" pp_sockaddr addr) ;
let rec loop acc =
Vmm_lwt.read_exactly s >>= function
| Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop acc
| Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return acc
| Ok (hdr, data) ->
Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp (Cstruct.of_string data)) ;
let t', action, out = Vmm_stats.handle !t hdr data in
let acc = match action with
| `Add pid -> pid :: acc
| `Remove pid -> List.filter (fun m -> m <> pid) acc
| `None -> acc
in
t := t' ;
Logs.debug (fun m -> m "sent %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ;
Vmm_lwt.write_raw s out >>= function
| Ok () -> loop acc
| Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc
let rec loop pids =
Vmm_lwt.read_wire s >>= function
| Error _ ->
Logs.err (fun m -> m "exception while reading") ;
Lwt.return pids
| Ok wire ->
match handle !t s wire with
| Error (`Msg msg) ->
Vmm_lwt.write_wire s (fst wire, `Failure msg) >>= fun _ ->
Lwt.return pids
| Ok (t', action, out) ->
t := t' ;
let pids = match action with
| `Add pid -> pid :: pids
| `Remove pid -> List.filter (fun m -> m <> pid) pids
| `Close _ -> pids
in
t := t' ;
Vmm_lwt.write_wire s (fst wire, `Success (`String out)) >>= function
| Ok () ->
(match action with
| `Close (Some s') ->
Vmm_lwt.safe_close s' >>= fun () ->
(* read the next *)
Vmm_lwt.read_wire s >|= fun _ -> pids
| _ -> loop pids)
| Error _ ->
Logs.err (fun m -> m "error while writing") ;
Lwt.return pids
in
loop [] >>= fun vmids ->
Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () ->
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 () =
t := Vmm_stats.tick !t ;
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 := remove_entry !t name ;
Vmm_lwt.safe_close s)
outs >>= fun () ->
Lwt_unix.sleep interval >>= fun () ->
timer interval ()
@ -70,29 +92,19 @@ let jump _ file interval =
in
loop ())
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
open Cmdliner
let setup_log =
Term.(const setup_log
$ Fmt_cli.style_renderer ()
$ Logs_cli.level ())
open Vmm_cli
let socket =
let doc = "Socket to listen on" in
let sock = Fpath.(to_string (Vmm_core.tmpdir / "stat" + "sock")) in
Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc)
let doc = "socket to use" in
Arg.(value & opt string (Vmm_core.socket_path `Stats) & info [ "socket" ] ~doc)
let interval =
let doc = "Interval between statistics gatherings (in seconds)" in
Arg.(value & opt int 10 & info [ "internval" ] ~doc)
Arg.(value & opt int 10 & info [ "interval" ] ~doc)
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

201
app/vmmd_tls.ml Normal file
View file

@ -0,0 +1,201 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let my_version = `AV2
let command = ref 0L
let pp_sockaddr ppf = function
| Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
| Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
(Unix.string_of_inet_addr addr) port
let connect socket_path =
let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in
Lwt_unix.set_close_on_exec c ;
Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () ->
c
let client_auth ca tls addr =
Logs.debug (fun m -> m "connection from %a" pp_sockaddr addr) ;
let authenticator =
let time = Ptime_clock.now () in
X509.Authenticator.chain_of_trust ~time (* ~crls:!state.Vmm_engine.crls *) [ca]
in
Lwt.catch
(fun () -> Tls_lwt.Unix.reneg ~authenticator tls)
(fun e ->
(match e with
| Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a))
| Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f))
| exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ;
Vmm_tls_lwt.close tls >>= fun () ->
Lwt.fail e) >>= fun () ->
(match Tls_lwt.Unix.epoch tls with
| `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain
| `Error ->
Vmm_tls_lwt.close tls >>= fun () ->
Lwt.fail_with "error while getting epoch")
let read fd tls =
(* now we busy read and process output *)
let rec loop () =
Vmm_lwt.read_wire fd >>= function
| Error _ -> Lwt.return (Error (`Msg "exception while reading"))
| Ok wire ->
Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire wire) ;
Vmm_tls_lwt.write_tls tls wire >>= function
| Ok () -> loop ()
| Error `Exception -> Lwt.return (Error (`Msg "exception"))
in
loop ()
let process fd tls =
Vmm_lwt.read_wire fd >>= function
| Error _ -> Lwt.return (Error (`Msg "read error"))
| Ok wire ->
(* TODO check version *)
Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ;
Vmm_tls_lwt.write_tls tls wire >|= function
| Ok () -> Ok ()
| Error `Exception -> Error (`Msg "exception on write")
let handle ca (tls, addr) =
client_auth ca tls addr >>= fun chain ->
match Vmm_tls.handle addr my_version chain with
| Error (`Msg m) ->
Vmm_tls_lwt.close tls >>= fun () ->
Lwt.fail_with m
| Ok (name, policies, cmd) ->
let sock, next = Vmm_commands.endpoint cmd in
connect (Vmm_core.socket_path sock) >>= fun fd ->
(match sock with
| `Vmmd ->
Lwt_list.fold_left_s (fun r (id, policy) ->
match r with
| Error (`Msg msg) -> Lwt.return (Error (`Msg msg))
| Ok () ->
Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.pp_id id Vmm_core.pp_policy policy) ;
let header = Vmm_commands.{version = my_version ; sequence = !command ; id } in
command := Int64.succ !command ;
Vmm_lwt.write_wire fd (header, `Command (`Policy_cmd (`Policy_add policy))) >>= function
| Error `Exception -> Lwt.return (Error (`Msg "failed to write policy"))
| Ok () ->
Vmm_lwt.read_wire fd >|= function
| Error _ -> Error (`Msg "read error")
| Ok (_, `Success _) -> Ok ()
| Ok _ ->
(* TODO check version *)
Error (`Msg ("expected success, received something else when adding policy")))
(Ok ()) policies
| _ -> Lwt.return (Ok ())) >>= function
| Error (`Msg msg) ->
begin
Logs.debug (fun m -> m "error while applying policies %s" msg) ;
let wire =
let header = Vmm_commands.{version = my_version ; sequence = 0L ; id = name } in
header, `Failure msg
in
Vmm_tls_lwt.write_tls tls wire >>= fun _ ->
Vmm_tls_lwt.close tls >>= fun () ->
Vmm_lwt.safe_close fd >>= fun () ->
Lwt.fail_with msg
end
| Ok () ->
let wire =
let header = Vmm_commands.{version = my_version ; sequence = !command ; id = name } in
command := Int64.succ !command ;
(header, `Command cmd)
in
Vmm_lwt.write_wire fd wire >>= function
| Error `Exception ->
Vmm_tls_lwt.close tls >>= fun () ->
Vmm_lwt.safe_close fd >>= fun () ->
Lwt.return (Error (`Msg "couldn't write"))
| Ok () ->
(match next with
| `Read -> read fd tls
| `End -> process fd tls) >>= fun res ->
Vmm_tls_lwt.close tls >>= fun () ->
Vmm_lwt.safe_close fd >|= fun () ->
res
let server_socket port =
let open Lwt_unix in
let s = socket PF_INET SOCK_STREAM 0 in
set_close_on_exec s ;
setsockopt s SO_REUSEADDR true ;
bind s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () ->
listen s 10 ;
Lwt.return s
let jump _ cacert cert priv_key port =
Sys.(set_signal sigpipe Signal_ignore) ;
Lwt_main.run
(Nocrypto_entropy_lwt.initialize () >>= fun () ->
server_socket port >>= fun socket ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
X509_lwt.certs_of_pem cacert >>= (function
| [ ca ] -> Lwt.return ca
| _ -> Lwt.fail_with "expect single ca as cacert") >>= fun ca ->
let config =
Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2)
~reneg:true ~certificates:(`Single cert) ())
in
let rec loop () =
Lwt.catch (fun () ->
Lwt_unix.accept socket >>= fun (fd, addr) ->
Lwt_unix.set_close_on_exec fd ;
Lwt.catch
(fun () -> Tls_lwt.Unix.server_of_fd config fd >|= fun t -> (t, addr))
(fun exn ->
Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () ->
Lwt.fail exn) >>= fun t ->
Lwt.async (fun () ->
Lwt.catch
(fun () -> handle ca t >|= function
| Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg)
| Ok () -> ())
(fun e ->
Logs.err (fun m -> m "error while handle() %s"
(Printexc.to_string e)) ;
Lwt.return_unit)) ;
loop ())
(function
| Unix.Unix_error (e, f, _) ->
Logs.err (fun m -> m "Unix error %s in %s" (Unix.error_message e) f) ;
loop ()
| Tls_lwt.Tls_failure a ->
Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
loop ()
| exn ->
Logs.err (fun m -> m "exception %s" (Printexc.to_string exn)) ;
loop ())
in
loop ())
open Cmdliner
open Vmm_cli
let cacert =
let doc = "CA certificate" in
Arg.(required & pos 0 (some file) None & info [] ~doc)
let cert =
let doc = "Certificate" in
Arg.(required & pos 1 (some file) None & info [] ~doc)
let key =
let doc = "Private key" in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let port =
let doc = "TCP listen port" in
Arg.(value & opt int 1025 & info [ "port" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ cacert $ cert $ key $ port)),
Term.info "vmmd_tls" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

166
app/vmmp_ca.ml Normal file
View file

@ -0,0 +1,166 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Rresult.R.Infix
let l_exts =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Client_auth]) ]
let d_exts ?len () =
[ (true, (`Basic_constraints (true, len)))
; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ]
let s_exts =
[ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ])
; (true, `Basic_constraints (false, None))
; (true, `Ext_key_usage [`Server_auth]) ]
let albatross_extension csr =
let req_exts =
match
List.find (function `Extensions _ -> true | _ -> false) X509.CA.((info csr).extensions)
with
| exception Not_found -> []
| `Extensions x -> x
| _ -> []
in
match
List.filter (function
| (_, `Unsupported (oid, _)) when Asn.OID.equal oid Vmm_asn.oid -> true
| _ -> false)
req_exts
with
| [ (_, `Unsupported (_, v)) as ext ] -> Ok (ext, v)
| _ -> Error (`Msg "couldn't find albatross extension in CSR")
let sign dbname cacert key csr days =
let ri = X509.CA.info csr in
Logs.app (fun m -> m "signing certificate with subject %s"
(X509.distinguished_name_to_string ri.X509.CA.subject)) ;
let issuer = X509.subject cacert in
(* TODO: check delegation! verify whitelisted commands!? *)
match albatross_extension csr with
| Ok (ext, v) ->
Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) ->
(if Vmm_commands.version_eq version version then
Ok ()
else
Error (`Msg "unknown version in request")) >>= fun () ->
let exts = match cmd with
| `Policy_cmd (`Policy_add _) -> d_exts ()
| _ -> l_exts
in
Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ;
Ok (ext :: exts) >>= fun extensions ->
Vmm_provision.sign ~dbname extensions issuer key csr (Duration.of_day days)
| Error e -> Error e
let sign _ db cacert cakey csrname days =
let days = match days with None -> 1 | Some x -> x in
Nocrypto_entropy_unix.initialize () ;
match
Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
Bos.OS.File.read (Fpath.v csrname) >>= fun enc ->
let csr = X509.Encoding.Pem.Certificate_signing_request.of_pem_cstruct1 (Cstruct.of_string enc) in
sign (Fpath.v db) cacert cakey csr days
with
| Ok () -> `Ok ()
| Error (`Msg e) -> `Error (false, e)
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 ()
let generate _ name db days sname sdays =
let days = match days with None -> 3650 | Some x -> x in
Nocrypto_entropy_unix.initialize () ;
match
Vmm_provision.priv_key ~bits:4096 None name >>= fun key ->
let name = [ `CN name ] in
let csr = X509.CA.request name key in
Vmm_provision.sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () ->
Vmm_provision.priv_key None sname >>= fun skey ->
let sname = [ `CN sname ] in
let csr = X509.CA.request sname skey in
Vmm_provision.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
open Vmm_cli
let csr =
let doc = "signing request" in
Arg.(required & pos 3 (some file) None & info [] ~doc)
let key =
let doc = "Private key" in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let days =
let doc = "Number of days" in
Arg.(value & opt (some int) None & 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 generate_cmd =
let doc = "generates a certificate authority" in
let man =
[`S "DESCRIPTION";
`P "Generates a certificate authority."]
in
Term.(ret (const generate $ setup_log $ Vmm_provision.nam $ db $ days $ sname $ sday)),
Term.info "generate" ~doc ~man
let sign_cmd =
let doc = "sign a request" in
let man =
[`S "DESCRIPTION";
`P "Signs the certificate signing request."]
in
Term.(ret (const sign $ setup_log $ db $ Vmm_provision.cacert $ key $ csr $ days)),
Term.info "sign" ~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 vmmp_sign" in
let man =
[`S "DESCRIPTION";
`P "Prints help about 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 " in
let man = [
`S "DESCRIPTION" ;
`P "$(tname) executes the provided subcommand on a remote albatross" ]
in
Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)),
Term.info "vmmp_ca" ~version:"%%VERSION_NUM%%" ~doc ~man
let cmds = [ help_cmd ; sign_cmd ; generate_cmd ; (* TODO revoke_cmd *)]
let () =
match Term.eval_choice default_cmd cmds
with `Ok () -> exit 0 | _ -> exit 1

180
app/vmmp_request.ml Normal file
View file

@ -0,0 +1,180 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Vmm_asn
open Rresult.R.Infix
let version = `AV2
let csr priv name cmd =
let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (version, cmd))) ]
and name = [ `CN name ]
in
X509.CA.request name ~extensions:[`Extensions exts] priv
let jump id cmd =
Nocrypto_entropy_unix.initialize () ;
let name = Vmm_core.string_of_id id in
match
priv_key None name >>= fun priv ->
let csr = csr priv name cmd 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)
let info_ _ name = jump name (`Vm_cmd `Vm_info)
let info_policy _ name =
jump name (`Policy_cmd `Policy_info)
let remove_policy _ name =
jump name (`Policy_cmd `Policy_remove)
let add_policy _ name vms memory cpus block bridges =
let p = Vmm_cli.policy vms memory cpus block bridges in
jump name (`Policy_cmd (`Policy_add p))
let destroy _ name =
jump name (`Vm_cmd `Vm_destroy)
let create _ force name image cpuid requested_memory boot_params block_device network compression =
match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with
| Ok cmd -> jump name (`Vm_cmd cmd)
| Error (`Msg msg) -> `Error (false, msg)
let console _ name since =
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 Vmm_cli
let image =
let doc = "File of virtual machine image." in
Arg.(required & pos 1 (some file) None & info [] ~doc)
let vm_name =
let doc = "Name virtual machine." in
Arg.(required & pos 0 (some vm_c) None & info [] ~doc)
let destroy_cmd =
let doc = "destroys a virtual machine" in
let man =
[`S "DESCRIPTION";
`P "Destroy a virtual machine."]
in
Term.(ret (const destroy $ setup_log $ vm_name)),
Term.info "destroy" ~doc ~man
let remove_policy_cmd =
let doc = "removes a policy" in
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 info_cmd =
let doc = "information about VMs" in
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 policy_cmd =
let doc = "active policies" in
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 add_policy_cmd =
let doc = "Add a policy" in
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 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 $ vm_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

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

14
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.04.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}
@ -14,7 +14,6 @@ depends: [
"ipaddr" {>= "2.2.0"}
"hex"
"cstruct"
"ppx_cstruct" {build & >= "3.0.0"}
"logs"
"rresult"
"bos"
@ -27,9 +26,10 @@ depends: [
"nocrypto"
"asn1-combinators" {>= "0.2.0"}
"duration"
"decompress" {>= "0.7"}
"decompress" {= "0.7"}
]
build: [
[ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ]
]
synopsis: "Albatross - orchestrate and manage MirageOS unikernels"

83
packaging/MANIFEST Normal file
View file

@ -0,0 +1,83 @@
name: albatross
version: 1.0.%%GITVER%%_1
origin: local/albatross
comment: Albatross: Managing virtual machines
www: https://github.com/hannesm/albatross
maintainer: Hannes Mehnert <hannes@mehnert.org>
prefix: /usr/local
licenselogic: single
licenses: [NONE]
flatsize: %%FLATSIZE%%
categories: [local]
deps {
gmp {
origin = "math/gmp";
version = "6.1.2";
}
}
scripts : {
pre-install = <<EOD
if [ -n "${PKG_ROOTDIR}" ] && [ "${PKG_ROOTDIR}" != "/" ]; then
PW="/usr/sbin/pw -R ${PKG_ROOTDIR}"
else
PW=/usr/sbin/pw
fi
echo "===> Creating groups."
if ! ${PW} groupshow albatross >/dev/null 2>&1; then
echo "Creating group 'albatross' with gid '496'."
${PW} groupadd albatross -g 496
else
echo "Using existing group 'albatross'."
fi
echo "===> Creating users"
if ! ${PW} usershow albatross >/dev/null 2>&1; then
echo "Creating user 'albatross' with uid '496'."
${PW} useradd albatross -u 496 -g 496 -c "albatross daemon" -d /nonexistent -s /usr/sbin/nologin
else
echo "Using existing user 'albatross'."
fi
EOD;
post-install = <<EOD
mkdir -p /var/run/albatross/util /var/run/albatross/fifo
chown albatross:albatross /var/run/albatross/util /var/run/albatross/fifo
chmod 2760 /var/run/albatross/fifo
chgrp albatross /usr/local/libexec/albatross/vmmd
chmod 2700 /usr/local/libexec/albatross/vmmd
EOD;
post-deinstall = <<EOD
if [ -n "${PKG_ROOTDIR}" ] && [ "${PKG_ROOTDIR}" != "/" ]; then
PW="/usr/sbin/pw -R ${PKG_ROOTDIR}"
else
PW=/usr/sbin/pw
fi
if ${PW} usershow albatross >/dev/null 2>&1; then
echo "==> You should manually remove the \"albatross\" user. "
fi
if ${PW} groupshow albatross >/dev/null 2>&1; then
echo "==> You should manually remove the \"albatross\" group "
fi
EOD;
}
desc = <<EOD
A set of binaries to manage, provision, and deploy virtual machine images.
EOD;
messages [
{
message = <<EOD
===================================================================
you need to:
* modify /etc/devfs.rules to include:
add path 'vmm/solo5*' mode 0660 group albatross
* install solo5-hvt.net solo5-hvt.none in /var/db/albatross
===================================================================
EOD;
}
]

52
packaging/create_package.sh Executable file
View file

@ -0,0 +1,52 @@
#!/bin/sh -e
basedir=$(realpath "$(dirname "$0")"/..)
#tmptmpl=$(basename "$0")
#tmpd=$(mktemp -t "$tmptmpl")
tmpd=$basedir/_build/stage
manifest=$tmpd/+MANIFEST
rootdir=$tmpd/rootdir
trap 'rm -rf $tmpd' 0 INT EXIT
mkdir -p "$rootdir"/usr/local/sbin \
"$rootdir"/usr/local/libexec/albatross \
"$rootdir"/usr/local/etc/rc.d
# stage service scripts
for f in albatross_log \
albatross_stat \
albatross_console \
albatross_daemon \
albatross_x
do install -U $basedir/packaging/rc.d/$f $rootdir/usr/local/etc/rc.d/$f; done
# stage albatross app binaries
for f in vmmd vmmd_log vmmd_console vmmd_stats vmmd_influx vmmd_tls; do
install -U $basedir/_build/app/$f.native \
$rootdir/usr/local/libexec/albatross/$f; done
for f in vmmc_local vmmc_remote vmmc_bistro vmmp_ca vmmp_request; do
install -U $basedir/_build/app/$f.native \
$rootdir/usr/local/sbin/$f; done
# create +MANIFEST
flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + |
awk 'BEGIN {s=0} {s+=$1} END {print s}')
gitver=$(git rev-parse --short HEAD)
sed -e "s:%%GITVER%%:${gitver}:" -e "s:%%FLATSIZE%%:${flatsize}:" \
"$basedir/packaging/MANIFEST" > "$manifest"
{
printf '\nfiles {\n'
find "$rootdir" -type f -exec sha256 -r {} + |
awk '{print " " $2 ": \"" $1 "\"," }'
find "$rootdir" -type l |
awk "{print \" \"\$1 \": -,\"}"
printf '}\n'
} | sed -e "s:${rootdir}::" >> "$manifest"
pkg create -r "$rootdir" -M "$manifest" -o $basedir/_build/

View file

@ -0,0 +1,39 @@
#!/bin/sh
# $FreeBSD$
#
# PROVIDE: albatross_console
# REQUIRE: LOGIN
# KEYWORD: shutdown nojail
#
# Define these albatross_console_* variables in one of these files
# /etc/rc.conf
# /etc/rc.conf.local
# /etc/rc.conf.d/albatross_console
# /usr/local/etc/rc.conf.d/albatross_console
#
# albatross_console_flags:
# Default: ""
#
. /etc/rc.subr
name=albatross_console
rcvar=${name}_enable
desc="Albatross console service"
load_rc_config $name
start_cmd="albatross_console_start"
: ${albatross_console_enable:="NO"}
: ${albatross_console_flags:=""}
: ${albatross_console_user:="albatross"}
pidfile="/var/run/albatross_console.pid"
procname="/usr/local/libexec/albatross/vmmd_console"
albatross_console_start () {
/usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_console_user}" \
"${procname}" "${albatross_console_flags}"
}
run_rc_command "$1"

74
packaging/rc.d/albatross_daemon Executable file
View file

@ -0,0 +1,74 @@
#!/bin/sh
# $FreeBSD$
#
# PROVIDE: albatross_daemon
# REQUIRE: LOGIN albatross_console albatross_log albatross_stat
# KEYWORD: shutdown nojail
#
# Define these albatross_daemon_* variables in one of these files
# /etc/rc.conf
# /etc/rc.conf.local
# /etc/rc.conf.d/albatross_daemon
# /usr/local/etc/rc.conf.d/albatross_daemon
#
# albatross_daemon_enable: Set YES to enable the albatross daemon service
# Default: NO
# albatross_daemon_flags:
# Default: ""
#
#
. /etc/rc.subr
name=albatross_daemon
rcvar=${name}_enable
desc="Albatross service"
load_rc_config $name
start_cmd="albatross_daemon_start"
start_precmd="albatross_daemon_precmd"
: ${albatross_daemon_enable:="NO"}
: ${albatross_daemon_flags:=""}
pidfile="/var/run/albatross_daemon.pid"
procname="/usr/local/libexec/albatross/vmmd"
#
# force_depend script [rcvar]
# Force a service to start. Intended for use by services
# to resolve dependency issues.
# $1 - filename of script, in /usr/local/etc/rc.d, to run
# $2 - name of the script's rcvar (minus the _enable)
#
my_force_depend()
{
local _depend _dep_rcvar
_depend="$1"
_dep_rcvar="${2:-$1}_enable"
[ -n "$rc_fast" ] && ! checkyesno always_force_depends &&
checkyesno $_dep_rcvar && return 0
/usr/local/etc/rc.d/${_depend} forcestatus >/dev/null 2>&1 && return 0
info "${name} depends on ${_depend}, which will be forced to start."
if ! /usr/local/etc/rc.d/${_depend} forcestart; then
warn "Unable to force ${_depend}. It may already be running."
return 1
fi
}
albatross_daemon_precmd() {
my_force_depend albatross_console || err 1 "Cannot run albatross_console"
my_force_depend albatross_log || err 1 "Cannot run albatross_log"
my_force_depend albatross_stat || err 1 "Cannot run albatross_stat"
}
albatross_daemon_start () {
/usr/sbin/daemon -S -p "${pidfile}" "${procname}" \
"${albatross_daemon_flags}"
}
run_rc_command "$1"

47
packaging/rc.d/albatross_log Executable file
View file

@ -0,0 +1,47 @@
#!/bin/sh
# $FreeBSD$
#
# PROVIDE: albatross_log
# REQUIRE: LOGIN
# KEYWORD: shutdown nojail
#
# Define these albatross_log_* variables in one of these files
# /etc/rc.conf
# /etc/rc.conf.local
# /etc/rc.conf.d/albatross_log
# /usr/local/etc/rc.conf.d/albatross_log
#
# albatross_log_flags:
# Default: ""
#
. /etc/rc.subr
name=albatross_log
rcvar=${name}_enable
desc="Albatross log service"
load_rc_config $name
start_cmd="albatross_log_start"
start_precmd="albatross_log_precmd"
: ${albatross_log_enable:="NO"}
: ${albatross_log_flags:=""}
: ${albatross_log_user:="albatross"}
pidfile="/var/run/albatross_log.pid"
procname="/usr/local/libexec/albatross/vmmd_log"
logfile="/var/log/albatross"
albatross_log_precmd () {
[ -e "${logfile}" ] ||
install -g ${albatross_log_user} -o ${albatross_log_user} \
-- /dev/null "${logfile}";
}
albatross_log_start () {
/usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_log_user}" \
"${procname}" "${albatross_log_flags}"
}
run_rc_command "$1"

39
packaging/rc.d/albatross_stat Executable file
View file

@ -0,0 +1,39 @@
#!/bin/sh
# $FreeBSD$
#
# PROVIDE: albatross_stat
# REQUIRE: LOGIN
# KEYWORD: shutdown nojail
#
# Define these albatross_stat_* variables in one of these files
# /etc/rc.conf
# /etc/rc.conf.local
# /etc/rc.conf.d/albatross_stat
# /usr/local/etc/rc.conf.d/albatross_stat
#
# albatross_stat_flags:
# Default: ""
#
. /etc/rc.subr
name=albatross_stat
rcvar=${name}_enable
desc="Albatross stat service"
load_rc_config $name
start_cmd="albatross_stat_start"
: ${albatross_stat_enable:="NO"}
: ${albatross_stat_flags:=""}
: ${albatross_stat_user:="albatross"}
pidfile="/var/run/albatross_stat.pid"
procname="/usr/local/libexec/albatross/vmmd_stats"
albatross_stat_start () {
/usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_stat_user}" \
"${procname}" "${albatross_stat_flags}"
}
run_rc_command "$1"

73
packaging/rc.d/albatross_x Executable file
View file

@ -0,0 +1,73 @@
#!/bin/sh
# $FreeBSD$
#
# PROVIDE: albatross_x
# REQUIRE: LOGIN albatross_daemon
# KEYWORDS: shutdown nojail
#
# Define these albatross_x_* variables in one of these files
# /etc/rc.conf
# /etc/rc.conf.local
# /etc/rc.conf.d/albatross_x
# /usr/local/etc/rc.conf.d/albatross_x
#
# albatross_x_enable: Set YES to enable the albatross vm start service
# Default: NO
# albatross_x_vms: list of vms to manage
# Default: ""
# albatross_x_args_$VM: vm create arguments
#
#
. /etc/rc.subr
name=albatross_x
rcvar=${name}_enable
desc="Manage Albatross VMs"
load_rc_config $name
start_cmd="albatross_x_start"
stop_cmd="albatross_x_stop"
status_cmd="albatross_x_status"
extra_commands="status"
: ${albatross_x_enable:="NO"}
: ${albatross_x_vms:=""}
albatross_x_start () {
case $1 in
_ALL)
for _vm in $albatross_x_vms; do
eval _create_args=\"\$albatross_x_args_${_vm}\"
/usr/local/sbin/vmmc_local create $_vm $_create_args
done
return
;;
esac
for _vm in $@; do
eval _create_args=\"\$albatross_x_args_${_vm}\"
/usr/local/sbin/vmmc_local create $_vm $_create_args
done
}
albatross_x_stop () {
case $1 in
ALL)
for _vm in $albatross_x_vms
do /usr/local/sbin/vmmc_local destroy $_vm; done
return
esac
for _vm in $@
do /usr/local/sbin/vmmc_local destroy $_vm; done
}
albatross_x_status () {
for _vm in $@
do /usr/local/sbin/vmmc_local info $_vm; done
}
case $# in
1) run_rc_command $@ ${albatross_x_list:-_ALL} ;;
*) run_rc_command $@ ;;
esac

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

@ -7,17 +7,14 @@ let () =
Pkg.describe "albatross" @@ fun _ ->
Ok [
Pkg.bin "app/vmmd" ;
Pkg.bin "app/vmm_console" ;
Pkg.bin "app/vmm_log" ;
Pkg.bin "app/vmm_client" ;
Pkg.bin "provision/vmm_req_permissions" ;
Pkg.bin "provision/vmm_req_delegation" ;
Pkg.bin "provision/vmm_req_vm" ;
Pkg.bin "provision/vmm_sign" ;
Pkg.bin "provision/vmm_revoke" ;
Pkg.bin "provision/vmm_gen_ca" ;
Pkg.clib "stats/libvmm_stats_stubs.clib" ;
Pkg.bin "stats/vmm_stats_lwt" ;
Pkg.bin "app/vmm_prometheus_stats" ;
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_ca" ;
]

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,85 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Vmm_asn
open Rresult.R.Infix
open Astring
let subca_csr key name cpus mem vms block bridges =
let block = match block with
| None -> []
| Some x -> [ (false, `Unsupported (Oid.block, int_to_cstruct x)) ]
and bridge = match bridges with
| [] -> []
| xs -> [ (false, `Unsupported (Oid.bridges, bridges_to_cstruct xs)) ]
in
let exts =
[ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ;
(false, `Unsupported (Oid.cpuids, ints_to_cstruct cpus)) ;
(false, `Unsupported (Oid.memory, int_to_cstruct mem)) ;
(false, `Unsupported (Oid.vms, int_to_cstruct vms)) ;
] @ block @ bridge
and name = [ `CN name ]
in
X509.CA.request name ~extensions:[`Extensions exts] key
let jump _ name key vms mem cpus block bridges =
Nocrypto_entropy_unix.initialize () ;
match
priv_key key name >>= fun key ->
let csr = subca_csr key name cpus mem vms block bridges 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 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 b =
let parse s =
match String.cuts ~sep:"/" s with
| [ name ; fst ; lst ; gw ; nm ] ->
begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with
| Some fst, Some lst, Some gw ->
(try
let nm = int_of_string nm in
if nm > 0 && nm <= 32 then
let net = Ipaddr.V4.Prefix.make nm gw in
if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then
`Ok (`External (name, fst, lst, gw, nm))
else
`Error "first or last IP are not in subnet"
else
`Error "netmask must be > 0 and <= 32"
with Failure _ -> `Error "couldn't parse netmask")
| _ -> `Error "couldn't parse IP address"
end
| [ name ] -> `Ok (`Internal name)
| _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')"
in
(parse, Vmm_core.pp_bridge)
let bridge =
let doc = "Bridge to provision" in
Arg.(value & opt_all b [] & info [ "bridge" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)),
Term.info "vmm_req_delegation" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,46 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Rresult.R.Infix
open Vmm_asn
let cmd_csr name key permissions =
let exts =
[ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ;
(false, `Unsupported (Oid.permissions, permissions_to_cstruct permissions)) ]
and name = [ `CN name ]
in
X509.CA.request name ~extensions:[`Extensions exts] key
let jump _ name key permissions =
Nocrypto_entropy_unix.initialize () ;
match
priv_key key name >>= fun key ->
let csr = cmd_csr name key permissions 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 cmd =
let parse s =
match Vmm_core.permission_of_string s with
| Some x -> `Ok x
| None -> `Error "invalid permission"
in
(parse, Vmm_core.pp_permission)
let permissions =
let doc = "permissions" in
Arg.(value & opt_all cmd [] & info [ "p" ; "permission" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ nam $ key $ permissions)),
Term.info "vmm_req_permissions" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,85 +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 cpu mem args block net force compression =
let block = match block with
| None -> []
| Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ]
and arg = match args with
| [] -> []
| xs -> [ (false, `Unsupported (Oid.argv, strings_to_cstruct xs)) ]
and net = match net with
| [] -> []
| xs -> [ (false, `Unsupported (Oid.network, strings_to_cstruct xs)) ]
and cmd = if force then `Force_create else `Create
in
let image = match compression with
| 0 -> image_to_cstruct (`Ukvm_amd64, image)
| level ->
let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
image_to_cstruct (`Ukvm_amd64_compressed, Cstruct.of_string img)
in
let exts =
[ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ;
(false, `Unsupported (Oid.cpuid, int_to_cstruct cpu)) ;
(false, `Unsupported (Oid.memory, int_to_cstruct mem)) ;
(false, `Unsupported (Oid.vmimage, image)) ;
(false, `Unsupported (Oid.permissions, permissions_to_cstruct [ cmd ])) ;
] @ block @ arg @ net
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,78 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Astring
open Rresult.R.Infix
let jump _ db cacert cakey crl cn serial =
Nocrypto_entropy_unix.initialize () ;
match
(match cn, serial with
| x, y when x = "" && String.length y > 0 ->
(try Ok (Z.of_string y) with Invalid_argument x -> Error (`Msg x))
| x, y when y = "" ->
Bos.OS.File.read_lines (Fpath.v db) >>= fun entries ->
Vmm_core.parse_db entries >>= fun db ->
Vmm_core.find_name db x
| _ -> Error (`Msg "please provide either common name or serial!")) >>= fun serial ->
Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
let this_update = Ptime_clock.now () in
let revoked = { X509.CRL.serial ; date = this_update ; extensions = [] } in
let crl = Fpath.v crl in
let issuer = X509.subject cacert in
(Bos.OS.File.exists crl >>= function
| true ->
Bos.OS.File.read crl >>= fun crl ->
(match X509.Encoding.crl_of_cstruct (Cstruct.of_string crl) with
| None -> Error (`Msg "couldn't parse CRL")
| Some c -> Ok (X509.CRL.revoke_certificate revoked ~this_update c cakey))
| false ->
Ok (X509.CRL.revoke
~issuer
~this_update
~extensions:[ (false, `CRL_number 0) ]
[ revoked ] cakey)) >>= fun new_crl ->
let crl_cs = X509.Encoding.crl_to_cstruct new_crl in
Bos.OS.File.write crl (Cstruct.to_string crl_cs) >>= fun () ->
(* create temporary certificate for uploading CRL *)
let name = "revoke" in
priv_key None name >>= fun key ->
let csr = X509.CA.request [ `CN name ] key in
let extensions = [ (false, `Unsupported (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct asn_version)) ;
(false, `Unsupported (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct [ `Crl ])) ;
(false, `Unsupported (Vmm_asn.Oid.crl, crl_cs)) ] @ l_exts
in
sign ~dbname:(Fpath.v db) extensions issuer cakey csr (Duration.of_hour 1)
with
| Ok () -> `Ok ()
| Error (`Msg e) -> `Error (false, e)
open Cmdliner
let key =
let doc = "Private key" in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let crl =
let doc = "Revocation list" in
Arg.(required & pos 3 (some file) None & info [] ~doc)
let cn =
let doc = "Common Name" in
Arg.(value & opt string "" & info [ "cn" ] ~doc)
let serial =
let doc = "Serial" in
Arg.(value & opt string "" & info [ "serial" ] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ db $ cacert $ key $ crl $ cn $ serial)),
Term.info "vmm_revoke" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,298 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Vmm_provision
open Rresult.R.Infix
open Astring
let has oid exts =
List.exists (function (_, `Unsupported (x, _)) when x = oid -> true | _ -> false) exts
let req oid exts f =
try
let ext = List.find (function (_, `Unsupported (x, _)) when x = oid -> true | _ -> false) exts in
match ext with
| (_, `Unsupported (_, y)) -> f y
| _ -> Error (`Msg "not found")
with Not_found -> Error (`Msg "not found")
let opt oid exts f =
try
let ext = List.find (function (_, `Unsupported (x, _)) when x = oid -> true | _ -> false) exts in
match ext with
| (_, `Unsupported (_, y)) -> f y >>= fun x -> Ok (Some x)
| _ -> Ok None
with Not_found -> Ok None
let sign dbname cacert key csr days =
let ri = X509.CA.info csr in
Logs.app (fun m -> m "signing certificate with subject %s"
(X509.distinguished_name_to_string ri.X509.CA.subject)) ;
let issuer = X509.subject cacert in
(* TODO: handle version mismatch of the delegation cert specially here *)
let delegation = match Vmm_asn.delegation_of_cert asn_version cacert with
| Ok d -> Some d
| Error _ -> None
in
Logs.app (fun m -> m "using delegation %s: %a" (X509.distinguished_name_to_string issuer)
Fmt.(option ~none:(unit "no") Vmm_core.pp_delegation) delegation) ;
let req_exts =
match
List.find (function `Extensions _ -> true | _ -> false) ri.X509.CA.extensions
with
| exception Not_found -> []
| `Extensions x -> x
| _ -> []
in
req Vmm_asn.Oid.version req_exts Vmm_asn.version_of_cstruct >>= fun v ->
(if Vmm_asn.version_eq v asn_version then
Ok ()
else
Error (`Msg "unknown version in request")) >>= fun () ->
let s_exts = [ (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct v) ] in
let get_int () =
let id = read_line () in
(try Ok (int_of_string id) with
| Failure _ -> Error (`Msg "couldn't parse integer"))
in
(match has Vmm_asn.Oid.vmimage req_exts, has Vmm_asn.Oid.vms req_exts with
| true, false -> Ok `Vm
| false, true -> Ok `Delegation
| false, false -> Ok `Permission
| _ -> Error (`Msg "cannot categorise signing request")) >>= (function
| `Vm ->
Logs.app (fun m -> m "categorised as a virtual machine request") ;
req Vmm_asn.Oid.vmimage req_exts Vmm_asn.image_of_cstruct >>= fun (typ, img) ->
Logs.app (fun m -> m "image of type %a, size %d" Vmm_core.pp_vmtype typ (Cstruct.len img)) ;
let s_exts = (Vmm_asn.Oid.vmimage, Vmm_asn.image_to_cstruct (typ, img)) :: s_exts in
let cpuids = match delegation with
| None -> None
| Some x -> Some (Vmm_core.IS.elements x.Vmm_core.cpuids)
in
(opt Vmm_asn.Oid.cpuid req_exts Vmm_asn.int_of_cstruct >>= function
| None ->
Logs.warn (fun m -> m "no CPU specified, please specify one of %a: "
Fmt.(option ~none:(unit "??") (list ~sep:(unit ",") int)) cpuids) ;
get_int () >>= fun cpu ->
(match cpuids with
| None -> Ok cpu
| Some x when List.mem cpu x -> Ok cpu
| Some _ -> Error (`Msg "refusing to use a not-delegated CPU"))
| Some cpu ->
match cpuids with
| None -> Ok cpu
| Some x when List.mem cpu x -> Ok cpu
| Some x ->
Logs.err (fun m -> m "CPU id %d was requested, which is not delegated, please specify one of %a:"
cpu Fmt.(list ~sep:(unit ",") int) x) ;
get_int () >>= fun cpu ->
if List.mem cpu x then Ok cpu
else Error (`Msg "refusing to use a not-delegated CPU")) >>= fun cpuid ->
Logs.app (fun m -> m "using CPU %d" cpuid) ;
let s_exts = (Vmm_asn.Oid.cpuid, Vmm_asn.int_to_cstruct cpuid) :: s_exts in
let memory = match delegation with
| None -> None
| Some x -> Some x.Vmm_core.memory
in
(opt Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>= function
| None ->
Logs.warn (fun m -> m "no memory specified, please specify amount (max %a):"
Fmt.(option ~none:(unit "??") int) memory) ;
get_int () >>= fun m ->
(match memory with
| None -> Ok m
| Some x when m <= x -> Ok m
| Some _ -> Error (`Msg "refusing to overcommit memory"))
| Some me ->
match memory with
| None -> Ok me
| Some x when me < x -> Ok me
| Some x ->
Logs.err (fun m -> m "you have %d memory delegated, but %d is requested, please specify a smaller amount:" x me) ;
get_int () >>= fun m ->
if m <= x then Ok m
else Error (`Msg "refusing to use that much memory")) >>= fun mem ->
Logs.app (fun m -> m "using %d memory" mem) ;
let s_exts = (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct mem) :: s_exts in
(opt Vmm_asn.Oid.network req_exts Vmm_asn.strings_of_cstruct >>= function
| None -> Ok None
| Some [] -> Ok None
| Some x ->
match delegation with
| None -> Ok (Some x)
| Some del ->
let bridges = del.Vmm_core.bridges in
List.fold_left (fun r x ->
r >>= fun () -> match String.Map.find x bridges with
| None ->
Rresult.R.error_msgf
"won't get you a network interface on bridge %s, which is not delegated." x
| Some _ -> Ok ())
(Ok ()) x >>= fun () ->
Ok (Some x)) >>= fun net ->
Logs.app (fun m -> m "using network interfaces %a"
Fmt.(option ~none:(unit "none") (list ~sep:(unit ",") string)) net) ;
let s_exts =
match net with
| None -> s_exts
| Some n -> (Vmm_asn.Oid.network, Vmm_asn.strings_to_cstruct n) :: s_exts
in
(opt Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>= function
| None -> Ok None
| Some x ->
match delegation with
| None -> Ok (Some x)
| Some d -> match d.Vmm_core.block with
| None -> Error (`Msg "trying to use a block device, when no block storage is delegated")
| Some _ -> Ok (Some x)) >>= fun block_device ->
Logs.app (fun m -> m "using block device %a"
Fmt.(option ~none:(unit "none") string) block_device) ;
let s_exts = match block_device with
| None -> s_exts
| Some x -> (Vmm_asn.Oid.block_device, Vmm_asn.string_to_cstruct x) :: s_exts
in
opt Vmm_asn.Oid.argv req_exts Vmm_asn.strings_of_cstruct >>= fun argv ->
Logs.app (fun m -> m "using argv %a"
Fmt.(option ~none:(unit "none")
(list ~sep:(unit ", ") string)) argv) ;
let s_exts = match argv with
| None -> s_exts
| Some a -> (Vmm_asn.Oid.argv, Vmm_asn.strings_to_cstruct a) :: s_exts
in
opt Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms ->
Logs.app (fun m -> m "using permission %a"
Fmt.(option ~none:(unit "none")
(list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ;
let perm = match perms with
| Some [ `Force_create ] -> [ `Force_create ]
| Some [ `Create ] -> [ `Create ]
| _ ->
Logs.warn (fun m -> m "weird permissions (%a), replaced with create"
Fmt.(option ~none:(unit "none")
(list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ;
[ `Create ]
in
let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perm) :: s_exts in
let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
Ok (exts @ l_exts)
| `Delegation ->
(req Vmm_asn.Oid.cpuids req_exts Vmm_asn.ints_of_cstruct >>= fun x ->
match delegation with
| None -> Ok x
| Some d when Vmm_core.IS.subset d.Vmm_core.cpuids (Vmm_core.IS.of_list x) -> Ok x
| Some d -> Rresult.R.error_msgf
"CPUs %a are not a subset of the delegated ones %a"
Fmt.(list ~sep:(unit ",") int) x
Fmt.(list ~sep:(unit ",") int) (Vmm_core.IS.elements d.Vmm_core.cpuids)) >>= fun cpuids ->
Logs.app (fun m -> m "delegating CPUs %a" Fmt.(list ~sep:(unit ",") int) cpuids) ;
let s_exts = (Vmm_asn.Oid.cpuids, Vmm_asn.ints_to_cstruct cpuids) :: s_exts in
(req Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>= fun x ->
match delegation with
| None -> Ok x
| Some d when d.Vmm_core.memory >= x -> Ok x
| Some d -> Rresult.R.error_msgf
"cannot delegate %d memory, only have %d delegated" x d.Vmm_core.memory) >>= fun mem ->
Logs.app (fun m -> m "delegating %d memory" mem) ;
let s_exts = (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct mem) :: s_exts in
(opt Vmm_asn.Oid.block req_exts Vmm_asn.int_of_cstruct >>= function
| None -> Ok None
| Some x when x = 0 -> Ok None
| Some x -> match delegation with
| None -> Ok (Some x)
| Some d -> match d.Vmm_core.block with
| None -> Error (`Msg "cannot delegate block storage, don't have any delegated")
| Some d when d >= x -> Ok (Some x)
| Some d -> Rresult.R.error_msgf
"cannot delegate %d block storage, only have %d delegated" x d) >>= fun bl ->
Logs.app (fun m -> m "delegating %a block storage" Fmt.(option ~none:(unit "none") int) bl) ;
let s_exts = match bl with
| None -> s_exts
| Some x -> (Vmm_asn.Oid.block, Vmm_asn.int_to_cstruct x) :: s_exts
in
(req Vmm_asn.Oid.vms req_exts Vmm_asn.int_of_cstruct >>= fun x ->
match delegation with
| None -> Ok x
| Some d when d.Vmm_core.vms >= x -> Ok x
| Some d -> Rresult.R.error_msgf
"cannot delegate %d vms, only have %d delegated" x d.Vmm_core.vms) >>= fun vm ->
Logs.app (fun m -> m "delegating %d vms" vm) ;
let s_exts = (Vmm_asn.Oid.vms, Vmm_asn.int_to_cstruct vm) :: s_exts in
(opt Vmm_asn.Oid.bridges req_exts Vmm_asn.bridges_of_cstruct >>= function
| None -> Ok None
| Some xs when xs = [] -> Ok None
| Some xs -> match delegation with
| None -> Ok (Some xs)
| Some x ->
let sub =
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
in
if Vmm_core.sub_bridges x.Vmm_core.bridges sub then Ok (Some xs)
else Error (`Msg "cannot delegate bridges which are not delegated in this ca cert")) >>= fun bridges ->
Logs.app (fun m -> m "delegating bridges: %a"
Fmt.(option ~none:(unit "none") (list ~sep:(unit ",") Vmm_core.pp_bridge))
bridges) ;
let s_exts = match bridges with
| None -> s_exts
| Some b -> (Vmm_asn.Oid.bridges, Vmm_asn.bridges_to_cstruct b) :: s_exts
in
let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
let pl = match X509.Extension.basic_constraints cacert with
| None -> None
| Some (true, n) -> Some n
| Some (false, _) -> None
in
Logs.app (fun m -> m "how much deeper should delegate be able to share? (max %a)"
Fmt.(option ~none:(unit "??") (option ~none:(unit "unlimited") int)) pl) ;
get_int () >>= fun len ->
(match pl with
| None | Some None -> Ok ()
| Some (Some x) when x >= succ len -> Ok ()
| Some _ -> Error (`Msg "cannot delegate that deep")) >>= fun () ->
Ok (exts @ d_exts ~len ())
| `Permission ->
req Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms ->
Logs.app (fun m -> m "an interactive certificate with permissions %a"
Fmt.(list ~sep:(unit ", ") Vmm_core.pp_permission) perms) ;
let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perms) :: s_exts in
let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in
Ok (exts @ l_exts)) >>= fun extensions ->
sign ~dbname extensions issuer key csr (Duration.of_day days)
let jump _ db cacert cakey csrname days =
Nocrypto_entropy_unix.initialize () ;
match
Bos.OS.File.read (Fpath.v cacert) >>= fun cacert ->
let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in
Bos.OS.File.read (Fpath.v cakey) >>= fun pk ->
let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in
Bos.OS.File.read (Fpath.v csrname) >>= fun enc ->
let csr = X509.Encoding.Pem.Certificate_signing_request.of_pem_cstruct1 (Cstruct.of_string enc) in
sign (Fpath.v db) cacert cakey csr days
with
| Ok () -> `Ok ()
| Error (`Msg e) -> `Error (false, e)
open Cmdliner
let csr =
let doc = "signing request" in
Arg.(required & pos 3 (some file) None & info [] ~doc)
let days =
let doc = "Number of days" in
Arg.(value & opt int 1 & info [ "days" ] ~doc)
let key =
let doc = "Private key" in
Arg.(required & pos 2 (some file) None & info [] ~doc)
let cmd =
Term.(ret (const jump $ setup_log $ db $ cacert $ key $ csr $ days)),
Term.info "vmm_sign" ~version:"%%VERSION_NUM%%"
let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

View file

@ -1,53 +1,12 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Vmm_core
open Vmm_commands
open Rresult
open Astring
module Oid = struct
open Asn.OID
let m = base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 42
let version = m <| 0
(* used only in CA certs *)
let vms = m <| 1
let bridges = m <| 2
let block = m <| 3
let cpuids = m <| 4
(* TODO: embed host URL (well, or use common name / SubjectAlternativeName with IP, and static port?) *)
(* used in both CA and VM certs *)
let memory = m <| 5
(* used only in VM certs *)
let cpuid = m <| 6
let network = m <| 7
let block_device = m <| 8
let vmimage = m <| 9
let argv = m <| 10
(* used in VM certs and other leaf certs *)
let permissions = m <| 42
(* used in CRL certs *)
let crl = m <| 43
end
let perms : permission list Asn.t =
Asn.S.bit_string_flags [
0, `All ;
1, `Info ;
2, `Create ;
3, `Block ;
4, `Statistics ;
5, `Console ;
6, `Log ;
7, `Crl ;
9, `Force_create ;
]
let oid = Asn.OID.(base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 42)
open Rresult.R.Infix
@ -64,9 +23,6 @@ let projections_of asn =
let c = Asn.codec Asn.der asn in
(decode_strict c, Asn.encode c)
let int_of_cstruct, int_to_cstruct = projections_of Asn.S.int
let ints_of_cstruct, ints_to_cstruct = projections_of Asn.S.(sequence_of int)
let ipv4 =
let f cs = Ipaddr.V4.of_bytes_exn (Cstruct.to_string cs)
and g ip = Cstruct.of_string (Ipaddr.V4.to_bytes ip)
@ -91,23 +47,39 @@ let bridge =
(required ~label:"router" ipv4)
(required ~label:"netmask" int))))
let bridges_of_cstruct, bridges_to_cstruct =
projections_of (Asn.S.sequence_of bridge)
let strings_of_cstruct, strings_to_cstruct =
projections_of Asn.S.(sequence_of utf8_string)
let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string
let policy =
let f (cpuids, vms, memory, 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 cpuids
in
{ vms ; cpuids ; memory ; block ; bridges }
and g policy =
(IS.elements policy.cpuids, policy.vms, policy.memory, policy.block,
snd @@ List.split @@ String.Map.bindings policy.bridges)
in
Asn.S.map f g @@
Asn.S.(sequence5
(required ~label:"cpuids" Asn.S.(sequence_of int))
(required ~label:"vms" int)
(required ~label:"memory" int)
(optional ~label:"block" int)
(required ~label:"bridges" Asn.S.(sequence_of bridge)))
let image =
let f = function
| `C1 x -> `Ukvm_amd64, x
| `C2 x -> `Ukvm_arm64, x
| `C3 x -> `Ukvm_amd64_compressed, x
| `C1 x -> `Hvt_amd64, x
| `C2 x -> `Hvt_arm64, x
| `C3 x -> `Hvt_amd64_compressed, x
and g = function
| `Ukvm_amd64, x -> `C1 x
| `Ukvm_arm64, x -> `C2 x
| `Ukvm_amd64_compressed, x -> `C3 x
| `Hvt_amd64, x -> `C1 x
| `Hvt_arm64, x -> `C2 x
| `Hvt_amd64_compressed, x -> `C3 x
in
Asn.S.map f g @@
Asn.S.(choice3
@ -115,99 +87,384 @@ let image =
(explicit 1 octet_string)
(explicit 2 octet_string))
let image_of_cstruct, image_to_cstruct = projections_of image
let console_cmd =
let f = function
| `C1 () -> `Console_add
| `C2 ts -> `Console_subscribe ts
and g = function
| `Console_add -> `C1 ()
| `Console_subscribe ts -> `C2 ts
in
Asn.S.map f g @@
Asn.S.(choice2
(explicit 0 null)
(explicit 1 (sequence (single (optional ~label:"since" utc_time)))))
let permissions_of_cstruct, permissions_to_cstruct = projections_of perms
(* TODO is this good? *)
let int64 =
let f cs = Cstruct.BE.get_uint64 cs 0
and g data =
let buf = Cstruct.create 8 in
Cstruct.BE.set_uint64 buf 0 data ;
buf
in
Asn.S.map f g Asn.S.octet_string
let req label cert oid f =
match X509.Extension.unsupported cert oid with
| None -> R.error_msgf "OID %s not present (%a)" label Asn.OID.pp oid
| Some (_, data) -> f data
let timeval =
Asn.S.(sequence2
(required ~label:"seconds" int64)
(required ~label:"microseconds" int))
let opt cert oid f =
match X509.Extension.unsupported cert oid with
| None -> Ok None
| Some (_, data) -> f data >>| fun s -> Some s
let ru =
let open Stats in
let f (utime, (stime, (maxrss, (ixrss, (idrss, (isrss, (minflt, (majflt, (nswap, (inblock, (outblock, (msgsnd, (msgrcv, (nsignals, (nvcsw, nivcsw))))))))))))))) =
{ utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ; nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw }
and g ru =
(ru.utime, (ru.stime, (ru.maxrss, (ru.ixrss, (ru.idrss, (ru.isrss, (ru.minflt, (ru.majflt, (ru.nswap, (ru.inblock, (ru.outblock, (ru.msgsnd, (ru.msgrcv, (ru.nsignals, (ru.nvcsw, ru.nivcsw)))))))))))))))
in
Asn.S.map f g @@
Asn.S.(sequence @@
(required ~label:"utime" timeval)
@ (required ~label:"stime" timeval)
@ (required ~label:"maxrss" int64)
@ (required ~label:"ixrss" int64)
@ (required ~label:"idrss" int64)
@ (required ~label:"isrss" int64)
@ (required ~label:"minflt" int64)
@ (required ~label:"majflt" int64)
@ (required ~label:"nswap" int64)
@ (required ~label:"inblock" int64)
@ (required ~label:"outblock" int64)
@ (required ~label:"msgsnd" int64)
@ (required ~label:"msgrcv" int64)
@ (required ~label:"nsignals" int64)
@ (required ~label:"nvcsw" int64)
-@ (required ~label:"nivcsw" int64))
type version = [ `AV0 ]
(* TODO is this good? *)
let int32 =
let f i = Int32.of_int i
and g i = Int32.to_int i
in
Asn.S.map f g Asn.S.int
let version_of_int = function
| 0 -> Ok `AV0
| _ -> Error (`Msg "couldn't parse version")
let ifdata =
let open Stats in
let f (name, (flags, (send_length, (max_send_length, (send_drops, (mtu, (baudrate, (input_packets, (input_errors, (output_packets, (output_errors, (collisions, (input_bytes, (output_bytes, (input_mcast, (output_mcast, (input_dropped, output_dropped))))))))))))))))) =
{ name; flags; send_length; max_send_length; send_drops; mtu; baudrate; input_packets; input_errors; output_packets; output_errors; collisions; input_bytes; output_bytes; input_mcast; output_mcast; input_dropped; output_dropped }
and g i =
(i.name, (i.flags, (i.send_length, (i.max_send_length, (i.send_drops, (i.mtu, (i.baudrate, (i.input_packets, (i.input_errors, (i.output_packets, (i.output_errors, (i.collisions, (i.input_bytes, (i.output_bytes, (i.input_mcast, (i.output_mcast, (i.input_dropped, i.output_dropped)))))))))))))))))
in
Asn.S.map f g @@
Asn.S.(sequence @@
(required ~label:"name" utf8_string)
@ (required ~label:"flags" int32)
@ (required ~label:"send_length" int32)
@ (required ~label:"max_send_length" int32)
@ (required ~label:"send_drops" int32)
@ (required ~label:"mtu" int32)
@ (required ~label:"baudrate" int64)
@ (required ~label:"input_packets" int64)
@ (required ~label:"input_errors" int64)
@ (required ~label:"output_packets" int64)
@ (required ~label:"output_errors" int64)
@ (required ~label:"collisions" int64)
@ (required ~label:"input_bytes" int64)
@ (required ~label:"output_bytes" int64)
@ (required ~label:"input_mcast" int64)
@ (required ~label:"output_mcast" int64)
@ (required ~label:"input_dropped" int64)
-@ (required ~label:"output_dropped" int64))
let version_to_int = function
| `AV0 -> 0
let stats_cmd =
let f = function
| `C1 (pid, taps) -> `Stats_add (pid, taps)
| `C2 () -> `Stats_remove
| `C3 () -> `Stats_subscribe
and g = function
| `Stats_add (pid, taps) -> `C1 (pid, taps)
| `Stats_remove -> `C2 ()
| `Stats_subscribe -> `C3 ()
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 (sequence2
(required ~label:"pid" int)
(required ~label:"taps" (sequence_of utf8_string))))
(explicit 1 null)
(explicit 2 null))
let pp_version ppf v =
Fmt.int ppf
(match v with
| `AV0 -> 0)
let version_eq a b =
match a, b with
| `AV0, `AV0 -> true
let version_to_cstruct v = int_to_cstruct (version_to_int v)
let version_of_cstruct cs =
int_of_cstruct cs >>= fun v ->
version_of_int v
let version_of_cert version cert =
req "version" cert Oid.version version_of_cstruct >>= fun version' ->
if version_eq version version' then
Ok ()
else
R.error_msgf "unsupported asn version %a (expected %a)"
pp_version version' pp_version version
let delegation_of_cert version cert =
version_of_cert version cert >>= fun () ->
req "cpuids" cert Oid.cpuids ints_of_cstruct >>= fun cpuids ->
req "memory" cert Oid.memory int_of_cstruct >>= fun memory ->
opt cert Oid.block int_of_cstruct >>= fun block ->
req "vms" cert Oid.vms int_of_cstruct >>= fun vms ->
opt cert Oid.bridges bridges_of_cstruct >>= fun bridges ->
let bridges = match bridges with
| None -> String.Map.empty
| Some xs ->
let add m v =
let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in
String.Map.add n v m
let log_event =
let f = function
| `C1 () -> `Startup
| `C2 (name, ip, port) -> `Login (name, ip, port)
| `C3 (name, ip, port) -> `Logout (name, ip, port)
| `C4 (name, pid, taps, block) -> `Vm_start (name, pid, taps, block)
| `C5 (name, pid, status) ->
let status' = match status with
| `C1 n -> `Exit n
| `C2 n -> `Signal n
| `C3 n -> `Stop n
in
List.fold_left add String.Map.empty xs
and cpuids = IS.of_list cpuids
`Vm_stop (name, pid, status')
and g = function
| `Startup -> `C1 ()
| `Login (name, ip, port) -> `C2 (name, ip, port)
| `Logout (name, ip, port) -> `C3 (name, ip, port)
| `Vm_start (name, pid, taps, block) -> `C4 (name, pid, taps, block)
| `Vm_stop (name, pid, status) ->
let status' = match status with
| `Exit n -> `C1 n
| `Signal n -> `C2 n
| `Stop n -> `C3 n
in
`C5 (name, pid, status')
in
Ok { vms ; cpuids ; memory ; block ; bridges }
let contains_vm cert =
match X509.Extension.unsupported cert Oid.vmimage with
| None -> false
| Some _ -> true
let contains_crl cert =
match X509.Extension.unsupported cert Oid.crl with
| None -> false
| Some _ -> true
let crl_of_cert cert =
let crl cs = match X509.Encoding.crl_of_cstruct cs with
| None -> Error (`Msg "couldn't parse revocation list")
| Some x -> Ok x
let endp =
Asn.S.(sequence3
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"ip" ipv4)
(required ~label:"port" int))
in
req "crl" cert Oid.crl crl
Asn.S.map f g @@
Asn.S.(choice5
(explicit 0 null)
(explicit 1 endp)
(explicit 2 endp)
(explicit 3 (sequence4
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"pid" int)
(required ~label:"taps" (sequence_of utf8_string))
(optional ~label:"block" utf8_string)))
(explicit 4 (sequence3
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"pid" int)
(required ~label:"status" (choice3
(explicit 0 int)
(explicit 1 int)
(explicit 2 int))))))
let vm_of_cert prefix cert =
req "cpuid" cert Oid.cpuid int_of_cstruct >>= fun cpuid ->
req "memory" cert Oid.memory int_of_cstruct >>= fun requested_memory ->
opt cert Oid.block_device string_of_cstruct >>= fun block_device ->
opt cert Oid.network strings_of_cstruct >>= fun network ->
req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage ->
opt cert Oid.argv strings_of_cstruct >>= fun argv ->
let vname = id cert in
let network = match network with None -> [] | Some x -> x in
Ok { prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
let log_cmd =
let f = function
| ts -> `Log_subscribe ts
and g = function
| `Log_subscribe ts -> ts
in
Asn.S.map f g @@
Asn.S.(sequence (single (optional ~label:"since" utc_time)))
let permissions_of_cert version cert =
version_of_cert version cert >>= fun () ->
req "permissions" cert Oid.permissions permissions_of_cstruct
let vm_config =
let f (cpuid, requested_memory, block_device, network, vmimage, argv) =
let network = match network with None -> [] | Some xs -> xs in
{ cpuid ; requested_memory ; block_device ; network ; vmimage ; argv }
and g vm =
let network = match vm.network with [] -> None | xs -> Some xs in
(vm.cpuid, vm.requested_memory, vm.block_device, network, vm.vmimage, vm.argv)
in
Asn.S.map f g @@
Asn.S.(sequence6
(required ~label:"cpu" int)
(required ~label:"memory" int)
(optional ~label:"block" utf8_string)
(optional ~label:"bridges" (sequence_of utf8_string))
(required ~label:"vmimage" image)
(optional ~label:"arguments" (sequence_of utf8_string)))
let vm_cmd =
let f = function
| `C1 () -> `Vm_info
| `C2 vm -> `Vm_create vm
| `C3 vm -> `Vm_force_create vm
| `C4 () -> `Vm_destroy
and g = function
| `Vm_info -> `C1 ()
| `Vm_create vm -> `C2 vm
| `Vm_force_create vm -> `C3 vm
| `Vm_destroy -> `C4 ()
in
Asn.S.map f g @@
Asn.S.(choice4
(explicit 0 null)
(explicit 1 vm_config)
(explicit 2 vm_config)
(explicit 3 null))
let policy_cmd =
let f = function
| `C1 () -> `Policy_info
| `C2 policy -> `Policy_add policy
| `C3 () -> `Policy_remove
and g = function
| `Policy_info -> `C1 ()
| `Policy_add policy -> `C2 policy
| `Policy_remove -> `C3 ()
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 null)
(explicit 1 policy)
(explicit 2 null))
let version =
let f data = match data with
| 2 -> `AV2
| _ -> Asn.S.error (`Parse "unknown version number")
and g = function
| `AV2 -> 2
in
Asn.S.map f g Asn.S.int
let wire_command =
let f = function
| `C1 console -> `Console_cmd console
| `C2 stats -> `Stats_cmd stats
| `C3 log -> `Log_cmd log
| `C4 vm -> `Vm_cmd vm
| `C5 policy -> `Policy_cmd policy
and g = function
| `Console_cmd c -> `C1 c
| `Stats_cmd c -> `C2 c
| `Log_cmd c -> `C3 c
| `Vm_cmd c -> `C4 c
| `Policy_cmd c -> `C5 c
in
Asn.S.map f g @@
Asn.S.(choice5
(explicit 0 console_cmd)
(explicit 1 stats_cmd)
(explicit 2 log_cmd)
(explicit 3 vm_cmd)
(explicit 4 policy_cmd))
let data =
let f = function
| `C1 (timestamp, data) -> `Console_data (timestamp, data)
| `C2 (ru, ifs, vmm) -> `Stats_data (ru, vmm, ifs)
| `C3 (timestamp, event) -> `Log_data (timestamp, event)
and g = function
| `Console_data (timestamp, data) -> `C1 (timestamp, data)
| `Stats_data (ru, ifs, vmm) -> `C2 (ru, vmm, ifs)
| `Log_data (timestamp, event) -> `C3 (timestamp, event)
in
Asn.S.map f g @@
Asn.S.(choice3
(explicit 0 (sequence2
(required ~label:"timestamp" utc_time)
(required ~label:"data" utf8_string)))
(explicit 1 (sequence3
(required ~label:"resource_usage" ru)
(required ~label:"ifdata" (sequence_of ifdata))
(optional ~label:"vmm_stats"
(sequence_of (sequence2
(required ~label:"key" utf8_string)
(required ~label:"value" int64))))))
(explicit 2 (sequence2
(required ~label:"timestamp" utc_time)
(required ~label:"event" log_event))))
let header =
let f (version, sequence, id) = { version ; sequence ; id }
and g h = h.version, h.sequence, h.id
in
Asn.S.map f g @@
Asn.S.(sequence3
(required ~label:"version" version)
(required ~label:"sequence" int64)
(required ~label:"id" (sequence_of utf8_string)))
let success =
let f = function
| `C1 () -> `Empty
| `C2 str -> `String str
| `C3 policies -> `Policies policies
| `C4 vms -> `Vms vms
and g = function
| `Empty -> `C1 ()
| `String s -> `C2 s
| `Policies ps -> `C3 ps
| `Vms vms -> `C4 vms
in
Asn.S.map f g @@
Asn.S.(choice4
(explicit 0 null)
(explicit 1 utf8_string)
(explicit 2 (sequence_of
(sequence2
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"policy" policy))))
(explicit 3 (sequence_of
(sequence2
(required ~label:"name" (sequence_of utf8_string))
(required ~label:"vm_config" vm_config)))))
let payload =
let f = function
| `C1 cmd -> `Command cmd
| `C2 s -> `Success s
| `C3 str -> `Failure str
| `C4 data -> `Data data
and g = function
| `Command cmd -> `C1 cmd
| `Success s -> `C2 s
| `Failure str -> `C3 str
| `Data d -> `C4 d
in
Asn.S.map f g @@
Asn.S.(choice4
(explicit 0 wire_command)
(explicit 1 success)
(explicit 2 utf8_string)
(explicit 3 data))
let wire =
Asn.S.(sequence2
(required ~label:"header" header)
(required ~label:"payload" payload))
let wire_of_cstruct, wire_to_cstruct = projections_of wire
let log_entry =
Asn.S.(sequence2
(required ~label:"timestamp" utc_time)
(required ~label:"event" log_event))
let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry
let log_disk =
Asn.S.(sequence2
(required ~label:"version" version)
(required ~label:"entry" log_entry))
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 log_disk_of_cstruct buf with
| Ok ((version', entry), cs) ->
let acc' =
if Vmm_commands.version_eq version version' then
entry :: acc
else
acc
in
next acc' cs
| Error (`Parse msg) ->
Logs.warn (fun m -> m "parse error %s while parsing log" msg) ;
acc (* ignore *)
in
next [] buf
type cert_extension = version * t
let cert_extension =
Asn.S.(sequence2
(required ~label:"version" version)
(required ~label:"command" wire_command))
let cert_extension_of_cstruct, cert_extension_to_cstruct =
projections_of cert_extension

View file

@ -1,161 +1,27 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Vmm_core
(** ASN.1 encoding of resources and configuration *)
(** Object Identifiers *)
(** {1 Object Identifier} *)
module Oid : sig
(** OID in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.43) *)
val oid : Asn.OID.t
(** {1 Object identifiers} *)
val wire_to_cstruct : Vmm_commands.wire -> Cstruct.t
(** OIDs in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.42) *)
val wire_of_cstruct : Cstruct.t -> (Vmm_commands.wire, [> `Msg of string ]) result
(** [version] specifies an [INTEGER] describing the version. *)
val version : Asn.OID.t
val log_entry_to_cstruct : Log.t -> Cstruct.t
(** {2 OIDs used in delegation certificates} *)
val log_entry_of_cstruct : Cstruct.t -> (Log.t, [> `Msg of string ]) result
(** [vms] is an [INTEGER] denoting the number of virtual machines. *)
val vms : Asn.OID.t
val log_to_disk : Vmm_commands.version -> Log.t -> Cstruct.t
(** [bridges] is a [CHOICE] between [ [0] UTF8STRING], describing an internal
bridge, and a [ [1] SEQUENCE] of [UTF8STRING], [IPV4ADDRESS] denoting the first
IP to use, [IPV4ADDRESS] denoting the last IP to use, [IPV4ADDRESS]
denoting the default gateway, [INTEGER] denoting the netmask. *)
val bridges : Asn.OID.t
val logs_of_disk : Vmm_commands.version -> Cstruct.t -> Log.t list
(** [block] is an [INTEGER] denoting the size of block storage available for
this delegation in MB. *)
val block : Asn.OID.t
type cert_extension = Vmm_commands.version * Vmm_commands.t
(** [cpuids] is a [SEQUENCE OF INTEGER] denoting the CPU identifiers available
for this delegate. *)
val cpuids : Asn.OID.t
(** [memory] is an [INTEGER] denoting the amount of available memory, in
MB. Also used in virtual machine certificates. *)
val memory : Asn.OID.t
(** {2 OIDs used in virtual machine certificates} *)
(** [cpuid] is an [INTEGER] denoting the CPU identifier on which this virtual
machine should be executed. Must be a member of all [cpuids] in the
chained delegation certificates. *)
val cpuid : Asn.OID.t
(** [network] is a [SEQUENCE OF UTF8STRING] denoting the bridge devices to
hook this virtual machine up to. Each name must be in the chained
delegation certificates. *)
val network : Asn.OID.t
(** [block_device] is a [UTF8STRING] with the name of the block device. It
must exist. *)
val block_device : Asn.OID.t
(** [vmimage] is a [CHOICE] between [ [0] OCTET_STRING] for an UKVM amd64
image and [ [1] OCTET_STRING] for an UKVM arm64 image. *)
val vmimage : Asn.OID.t
(** [argv] is a [SEQUENCE OF UTF8STRING] denoting the boot parameters passed
to the virtual machine image. *)
val argv : Asn.OID.t
(** {2 OID used in administrative certificates} *)
(** [permissions] is a [BIT_STRING] denoting the permissions this certificate
has: 0 for All, 1 for Info, 2 for Image, 3 for Block, 4 for Statistics, 5
for Console, 6 for Log. *)
val permissions : Asn.OID.t
(** [crl] is a [OCTET_STRING] denoting the revocation list of the intermediate
CA. *)
val crl : Asn.OID.t
end
(** {1 Encoding and decoding functions} *)
(** The type of versions of the ASN.1 grammar defined above. *)
type version = [ `AV0 ]
(** [version_eq a b] is true if [a] and [b] are equal. *)
val version_eq : version -> version -> bool
(** [pp_version ppf version] pretty prints [version] onto [ppf]. *)
val pp_version : version Fmt.t
(** [version_to_cstruct ver] is the DER encoded version. *)
val version_to_cstruct : version -> Cstruct.t
(** [version_of_cstruct buffer] is either a decoded version of the DER
encoding [buffer] or an error. *)
val version_of_cstruct : Cstruct.t -> (version, [> `Msg of string ]) result
(** [permissions_to_cstruct perms] is the DER encoded permission list. *)
val permissions_to_cstruct : Vmm_core.permission list -> Cstruct.t
(** [permissions_of_cstruct buffer] is either a decoded permissions list of
the DER encoded [buffer] or an error. *)
val permissions_of_cstruct : Cstruct.t -> (Vmm_core.permission list, [> `Msg of string ]) result
(** [bridges_to_cstruct bridges] is the DER encoded bridges. *)
val bridges_to_cstruct : Vmm_core.bridge list -> Cstruct.t
(** [bridges_of_cstruct buffer] is either a decoded bridge list of the DER
encoded [buffer] or an error. *)
val bridges_of_cstruct : Cstruct.t -> (Vmm_core.bridge list, [> `Msg of string ]) result
(** [image_to_cstruct (typ, img)] is the DER encoded image. *)
val image_to_cstruct : Vmm_core.vmtype * Cstruct.t -> Cstruct.t
(** [image_of_cstruct buffer] is either a decoded image of the DER encoded
[buffer] or an error. *)
val image_of_cstruct : Cstruct.t -> (Vmm_core.vmtype * Cstruct.t, [> `Msg of string ]) result
(** [int_to_cstruct i] is the DER encoded int. *)
val int_to_cstruct : int -> Cstruct.t
(** [int_of_cstruct buffer] is either a decoded int of the DER encoded [buffer]
or an error. *)
val int_of_cstruct : Cstruct.t -> (int, [> `Msg of string ]) result
(** [ints_to_cstruct xs] is the DER encoded int sequence. *)
val ints_to_cstruct : int list -> Cstruct.t
(** [ints_of_cstruct buffer] is either a decoded int list of the DER encoded
[buffer] or an error. *)
val ints_of_cstruct : Cstruct.t -> (int list, [> `Msg of string ]) result
(** [string_to_cstruct s] is the DER encoded string. *)
val string_to_cstruct : string -> Cstruct.t
(** [string_of_cstruct buffer] is either a decoded string of the DER encoded
[buffer] or an error. *)
val string_of_cstruct : Cstruct.t -> (string, [> `Msg of string ]) result
(** [strings_to_cstruct xs] is the DER encoded string sequence. *)
val strings_to_cstruct : string list -> Cstruct.t
(** [strings_of_cstruct buffer] is either a decoded string list of the DER
encoded [buffer] or an error. *)
val strings_of_cstruct : Cstruct.t -> (string list, [> `Msg of string ]) result
(** {1 Decoding functions} *)
(** [contains_vm cert] is [true] if the certificate contains a virtual machine image. *)
val contains_vm : X509.t -> bool
(** [contains_crl cert] is [true] if the certificate contains a revocation list. *)
val contains_crl : X509.t -> bool
(** [vm_of_cert id cert] is either the decoded virtual machine configuration, or an error. *)
val vm_of_cert : Vmm_core.id -> X509.t -> (Vmm_core.vm_config, [> `Msg of string ]) result
(** [crl_of_cert id cert] is either the decoded revocation list, or an error. *)
val crl_of_cert : X509.t -> (X509.CRL.c, [> `Msg of string ]) result
(** [delegation_of_cert version cert] is either the decoded delegation, or an error. *)
val delegation_of_cert : version -> X509.t -> (Vmm_core.delegation, [> `Msg of string ]) result
(** [permissions_of_cert version cert] is either the decoded permission list, or an error. *)
val permissions_of_cert : version -> X509.t -> (Vmm_core.permission list, [> `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

View file

@ -1,192 +1,134 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Rresult
(* bits copied over from Bos *)
(*---------------------------------------------------------------------------
Copyright (c) 2014 Daniel C. Bünzli
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)
let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
let err_empty_line = "no command, empty command line"
let err_file f e = R.error_msgf "%a: %a" Fpath.pp f pp_unix_error e
let rec openfile fn mode perm = try Unix.openfile fn mode perm with
| Unix.Unix_error (Unix.EINTR, _, _) -> openfile fn mode perm
let fd_for_file flag f =
try Ok (openfile (Fpath.to_string f) (Unix.O_CLOEXEC :: flag) 0o644)
with Unix.Unix_error (e, _, _) -> err_file f e
let read_fd_for_file = fd_for_file Unix.[ O_RDONLY ]
let write_fd_for_file = fd_for_file Unix.[ O_WRONLY ; O_APPEND ]
let null = match read_fd_for_file (Fpath.v "/dev/null") with
| Ok fd -> fd
| Error _ -> invalid_arg "cannot read /dev/null"
let rec create_process prog args stdout stderr =
try Unix.create_process prog args null stdout stderr with
| Unix.Unix_error (Unix.EINTR, _, _) ->
create_process prog args stdout stderr
let rec close fd =
try Unix.close fd with
| Unix.Unix_error (Unix.EINTR, _, _) -> close fd
let close_no_err fd = try close fd with _ -> ()
(* own code starts here
(c) 2017, 2018 Hannes Mehnert, all rights reserved *)
(* (c) 2018 Hannes Mehnert, all rights reserved *)
(* the wire protocol *)
open Vmm_core
let rec mkfifo name =
try Unix.mkfifo (Fpath.to_string name) 0o640 with
| Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
type version = [ `AV2 ]
let image_file, fifo_file =
((fun vm -> Fpath.(tmpdir / (vm_id vm) + "img")),
(fun vm -> Fpath.(tmpdir / (vm_id vm) + "fifo")))
let pp_version ppf v =
Fmt.int ppf
(match v with
| `AV2 -> 2)
let rec fifo_exists file =
try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
| Unix.Unix_error (Unix.ENOENT, _, _) -> Error (`Msg "noent")
| Unix.Unix_error (Unix.EINTR, _, _) -> fifo_exists file
| Unix.Unix_error (e, _, _) ->
R.error_msgf "file %a exists: %s" Fpath.pp file (Unix.error_message e)
let version_eq a b =
match a, b with
| `AV2, `AV2 -> true
| _ -> false
let uname () =
let cmd = Bos.Cmd.(v "uname" % "-s") in
lazy Bos.OS.Cmd.(run_out cmd |> out_string)
type console_cmd = [
| `Console_add
| `Console_subscribe of Ptime.t option
]
let create_tap bridge =
Lazy.force (uname ()) >>= fun (sys, _) ->
match sys with
| x when x = "FreeBSD" ->
let cmd = Bos.Cmd.(v "ifconfig" % "tap" % "create") in
Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string >>= fun (name, _) ->
Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % bridge % "addm" % name) >>= fun () ->
Ok name
| x when x = "Linux" ->
let prefix = "vmmtap" in
let rec find_n x =
let nam = prefix ^ string_of_int x in
match Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % nam) with
| Error _ -> nam
| Ok _ -> find_n (succ x)
in
let tap = find_n 0 in
Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "add" % "mode" % "tap" % tap) >>= fun () ->
Bos.OS.Cmd.run Bos.Cmd.(v "brctl" % "addif" % bridge % tap) >>= fun () ->
Ok tap
| x -> Error (`Msg ("unsupported operating system " ^ x))
let pp_console_cmd ppf = function
| `Console_add -> Fmt.string ppf "console add"
| `Console_subscribe ts ->
Fmt.pf ppf "console subscribe since %a"
Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts
let destroy_tap tapname =
Lazy.force (uname ()) >>= fun (sys, _) ->
match sys with
| x when x = "FreeBSD" ->
Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % tapname % "destroy")
| x when x = "Linux" ->
Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "del" % "dev" % tapname % "mode" % "tap")
| x -> Error (`Msg ("unsupported operating system " ^ x))
type stats_cmd = [
| `Stats_add of int * string list
| `Stats_remove
| `Stats_subscribe
]
let create_bridge bname =
Lazy.force (uname ()) >>= fun (sys, _) ->
match sys with
| x when x = "FreeBSD" ->
let cmd = Bos.Cmd.(v "ifconfig" % "bridge" % "create") in
Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string >>= fun (name, _) ->
Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % name % "name" % bname)
| x when x = "Linux" ->
Bos.OS.Cmd.run Bos.Cmd.(v "brctl" % "addbr" % bname)
| x -> Error (`Msg ("unsupported operating system " ^ x))
let pp_stats_cmd ppf = function
| `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps
| `Stats_remove -> Fmt.string ppf "stat remove"
| `Stats_subscribe -> Fmt.string ppf "stat subscribe"
let prepare vm =
(match vm.vmimage with
| `Ukvm_amd64, blob -> Ok blob
| `Ukvm_amd64_compressed, blob ->
begin match Vmm_compress.uncompress (Cstruct.to_string blob) with
| Ok blob -> Ok (Cstruct.of_string blob)
| Error () -> Error (`Msg "failed to uncompress")
end
| `Ukvm_arm64, _ -> Error (`Msg "no amd64 ukvm image found")) >>= fun image ->
let fifo = fifo_file vm in
(match fifo_exists fifo with
| Ok true -> Ok ()
| Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo"))
| Error _ ->
try Ok (mkfifo fifo) with
| Unix.Unix_error (e, f, _) ->
Logs.err (fun m -> m "%a error in %s: %a" Fpath.pp fifo f pp_unix_error e) ;
Error (`Msg "while creating fifo")) >>= fun () ->
List.fold_left (fun acc b ->
acc >>= fun acc ->
create_tap b >>= fun tap ->
Ok (tap :: acc))
(Ok []) vm.network >>= fun taps ->
Bos.OS.File.write (image_file vm) (Cstruct.to_string image) >>= fun () ->
Ok (List.rev taps)
type log_cmd = [
| `Log_subscribe of Ptime.t option
]
let shutdown vm =
(* same order as prepare! *)
Bos.OS.File.delete (image_file vm.config) >>= fun () ->
Bos.OS.File.delete (fifo_file vm.config) >>= fun () ->
List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps
let pp_log_cmd ppf = function
| `Log_subscribe ts ->
Fmt.pf ppf "log subscribe since %a"
Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts
let cpuset cpu =
Lazy.force (uname ()) >>= fun (sys, _) ->
let cpustring = string_of_int cpu in
match sys with
| x when x = "FreeBSD" ->
Ok ([ "cpuset" ; "-l" ; cpustring ])
| x when x = "Linux" ->
Ok ([ "taskset" ; "-c" ; cpustring ])
| x -> Error (`Msg ("unsupported operating system " ^ x))
type vm_cmd = [
| `Vm_info
| `Vm_create of vm_config
| `Vm_force_create of vm_config
| `Vm_destroy
]
let exec vm taps =
(* TODO: --net-mac=xx *)
let net = List.map (fun t -> "--net=" ^ t) taps in
let argv = match vm.argv with None -> [] | Some xs -> xs in
(match taps with
| [] -> Ok Fpath.(dbdir / "ukvm-bin.none")
| [_] -> Ok Fpath.(dbdir / "ukvm-bin.net")
| _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
cpuset vm.cpuid >>= fun cpuset ->
let mem = "--mem=" ^ string_of_int vm.requested_memory in
let cmd =
Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net %
"--" % p (image_file vm) %% of_list argv)
in
let line = Bos.Cmd.to_list cmd in
let prog = try List.hd line with Failure _ -> failwith err_empty_line in
let line = Array.of_list line in
let fifo = fifo_file vm in
Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
write_fd_for_file fifo >>= fun stdout ->
Logs.debug (fun m -> m "opened file descriptor!");
try
Logs.debug (fun m -> m "creating process");
let pid = create_process prog line stdout stdout in
Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ;
(* this should get rid of the vmimage from vmmd's memory! *)
let config = { vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in
Ok { config ; cmd ; pid ; taps ; stdout }
with
Unix.Unix_error (e, _, _) ->
close_no_err stdout;
R.error_msgf "cmd %a exits: %a" Bos.Cmd.pp cmd pp_unix_error e
let pp_vm_cmd ppf = function
| `Vm_info -> Fmt.string ppf "vm info"
| `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config
| `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config
| `Vm_destroy -> Fmt.string ppf "vm destroy"
type policy_cmd = [
| `Policy_info
| `Policy_add of policy
| `Policy_remove
]
let pp_policy_cmd ppf = function
| `Policy_info -> Fmt.string ppf "policy info"
| `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy
| `Policy_remove -> Fmt.string ppf "policy remove"
type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Policy_cmd of policy_cmd
]
let pp ppf = function
| `Console_cmd c -> pp_console_cmd ppf c
| `Stats_cmd s -> pp_stats_cmd ppf s
| `Log_cmd l -> pp_log_cmd ppf l
| `Vm_cmd v -> pp_vm_cmd ppf v
| `Policy_cmd p -> pp_policy_cmd ppf p
type data = [
| `Console_data of Ptime.t * string
| `Stats_data of Stats.t
| `Log_data of Log.t
]
let pp_data ppf = function
| `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s"
(Ptime.pp_rfc3339 ()) ts line
| `Stats_data stats -> Fmt.pf ppf "stats data: %a" Stats.pp stats
| `Log_data log -> Fmt.pf ppf "log data: %a" Log.pp log
type header = {
version : version ;
sequence : int64 ;
id : id ;
}
type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ]
let pp_success ppf = function
| `Empty -> Fmt.string ppf "success"
| `String data -> Fmt.pf ppf "success: %s" data
| `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps
| `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms
type wire = header * [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data ]
let pp_wire ppf (header, data) =
let id = header.id in
match data with
| `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp c
| `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f
| `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s
| `Data d -> pp_data ppf d
let endpoint = function
| `Vm_cmd _ -> `Vmmd, `End
| `Policy_cmd _ -> `Vmmd, `End
| `Stats_cmd _ -> `Stats, `Read
| `Console_cmd _ -> `Console, `Read
| `Log_cmd _ -> `Log, `Read
let destroy vm = Unix.kill vm.pid 15 (* 15 is SIGTERM *)

View file

@ -1,19 +1,80 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Rresult
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Vmm_core
val prepare : vm_config -> (string list, [> R.msg ]) result
(** The type of versions of the grammar defined below. *)
type version = [ `AV2 ]
val shutdown : vm -> (unit, [> R.msg ]) result
(** [version_eq a b] is true if [a] and [b] are equal. *)
val version_eq : version -> version -> bool
val exec : vm_config -> string list -> (vm, [> R.msg ]) result
(** [pp_version ppf version] pretty prints [version] onto [ppf]. *)
val pp_version : version Fmt.t
val destroy : vm -> unit
type console_cmd = [
| `Console_add
| `Console_subscribe of Ptime.t option
]
val close_no_err : Unix.file_descr -> unit
type stats_cmd = [
| `Stats_add of int * string list
| `Stats_remove
| `Stats_subscribe
]
val create_tap : string -> (string, [> R.msg ]) result
type log_cmd = [
| `Log_subscribe of Ptime.t option
]
val create_bridge : string -> (unit, [> R.msg ]) result
type vm_cmd = [
| `Vm_info
| `Vm_create of vm_config
| `Vm_force_create of vm_config
| `Vm_destroy
]
type policy_cmd = [
| `Policy_info
| `Policy_add of policy
| `Policy_remove
]
type t = [
| `Console_cmd of console_cmd
| `Stats_cmd of stats_cmd
| `Log_cmd of log_cmd
| `Vm_cmd of vm_cmd
| `Policy_cmd of policy_cmd ]
val pp : t Fmt.t
type data = [
| `Console_data of Ptime.t * string
| `Stats_data of Stats.t
| `Log_data of Log.t
]
val pp_data : data Fmt.t
type header = {
version : version ;
sequence : int64 ;
id : id ;
}
type success = [
| `Empty
| `String of string
| `Policies of (id * policy) list
| `Vms of (id * vm_config) list
]
type wire = header * [
| `Command of t
| `Success of success
| `Failure of string
| `Data of data ]
val pp_wire : wire Fmt.t
val endpoint : t -> service * [ `End | `Read ]

4
src/vmm_compress.mli Normal file
View file

@ -0,0 +1,4 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
val compress : ?level:int -> string -> string
val uncompress : string -> (string, unit) result

View file

@ -7,6 +7,23 @@ open Rresult.R.Infix
let tmpdir = Fpath.(v "/var" / "run" / "albatross")
let dbdir = Fpath.(v "/var" / "db" / "albatross")
type service = [ `Console | `Log | `Stats | `Vmmd ]
let socket_path t =
let path name = Fpath.(tmpdir / "util" / name + "sock") in
let path = match t with
| `Console -> path "console"
| `Vmmd -> Fpath.(tmpdir / "vmmd" + "sock")
| `Stats -> path "stat"
| `Log -> path "log"
in
Fpath.to_string path
let pp_socket ppf t =
let name = socket_path t in
Fmt.pf ppf "socket: %s" name
module I = struct
type t = int
let compare : int -> int -> int = compare
@ -15,83 +32,12 @@ end
module IS = Set.Make(I)
module IM = Map.Make(I)
type permission =
[ `All | `Info | `Create | `Block | `Statistics | `Console | `Log | `Crl | `Force_create]
let pp_permission ppf = function
| `All -> Fmt.pf ppf "all"
| `Info -> Fmt.pf ppf "info"
| `Create -> Fmt.pf ppf "create"
| `Block -> Fmt.pf ppf "block"
| `Statistics -> Fmt.pf ppf "statistics"
| `Console -> Fmt.pf ppf "console"
| `Log -> Fmt.pf ppf "log"
| `Crl -> Fmt.pf ppf "crl"
| `Force_create -> Fmt.pf ppf "force-create"
let permission_of_string = function
| x when x = "all" -> Some `All
| x when x = "info" -> Some `Info
| x when x = "create" -> Some `Create
| x when x = "block" -> Some `Block
| x when x = "statistics" -> Some `Statistics
| x when x = "console" -> Some `Console
| x when x = "log" -> Some `Log
| x when x = "crl" -> Some `Crl
| x when x = "force-create" -> Some `Force_create
| _ -> None
type cmd =
| Info
| Destroy_vm
| Create_block
| Destroy_block
| Statistics
| Attach
| Detach
| Log
let pp_cmd ppf = function
| Info -> Fmt.pf ppf "info"
| Destroy_vm -> Fmt.pf ppf "destroy"
| Create_block -> Fmt.pf ppf "create-block"
| Destroy_block -> Fmt.pf ppf "destroy-block"
| Statistics -> Fmt.pf ppf "statistics"
| Attach -> Fmt.pf ppf "attach"
| Detach -> Fmt.pf ppf "detach"
| Log -> Fmt.pf ppf "log"
let cmd_of_string = function
| x when x = "info" -> Some Info
| x when x = "destroy" -> Some Destroy_vm
| x when x = "create-block" -> Some Create_block
| x when x = "destroy-block" -> Some Destroy_block
| x when x = "statistics" -> Some Statistics
| x when x = "attach" -> Some Attach
| x when x = "detach" -> Some Detach
| x when x = "log" -> Some Log
| _ -> None
let cmd_allowed permissions cmd =
List.mem `All permissions ||
let perm = match cmd with
| Info -> `Info
| Destroy_vm -> `Create
| Create_block -> `Block
| Destroy_block -> `Block
| Statistics -> `Statistics
| Attach -> `Console
| Detach -> `Console
| Log -> `Log
in
List.mem perm permissions
type vmtype = [ `Ukvm_amd64 | `Ukvm_arm64 | `Ukvm_amd64_compressed ]
type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ]
let pp_vmtype ppf = function
| `Ukvm_amd64 -> Fmt.pf ppf "ukvm-amd64"
| `Ukvm_amd64_compressed -> Fmt.pf ppf "ukvm-amd64-compressed"
| `Ukvm_arm64 -> Fmt.pf ppf "ukvm-arm64"
| `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64"
| `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed"
| `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64"
type id = string list
@ -110,8 +56,12 @@ let drop_super ~super ~sub =
let is_sub_id ~super ~sub =
match drop_super ~super ~sub with None -> false | Some _ -> true
let domain id = match List.rev id with
| _::prefix -> List.rev prefix
| [] -> []
let pp_id ppf ids =
Fmt.(pf ppf "%a" (list ~sep:(unit ".") string) ids)
Fmt.(pf ppf "(%d)%a" (List.length ids) (list ~sep:(unit ".") string) ids)
let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is)
@ -120,13 +70,27 @@ type bridge = [
| `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
]
let eq_int (a : int) (b : int) = a = b
let eq_bridge b1 b2 = match b1, b2 with
| `Internal a, `Internal a' -> String.equal a a'
| `External (name, ip_start, ip_end, ip_gw, netmask),
`External (name', ip_start', ip_end', ip_gw', netmask') ->
let eq_ip a b = Ipaddr.V4.compare a b = 0 in
String.equal name name' &&
eq_ip ip_start ip_start' &&
eq_ip ip_end ip_end' &&
eq_ip ip_gw ip_gw' &&
eq_int netmask netmask'
| _ -> false
let pp_bridge ppf = function
| `Internal name -> Fmt.pf ppf "%s (internal)" name
| `External (name, l, h, gw, nm) ->
Fmt.pf ppf "%s: %a - %a, GW: %a/%d"
name Ipaddr.V4.pp_hum l Ipaddr.V4.pp_hum h Ipaddr.V4.pp_hum gw nm
type delegation = {
type policy = {
vms : int ;
cpuids : IS.t ;
memory : int ;
@ -134,8 +98,20 @@ type delegation = {
bridges : bridge String.Map.t ;
}
let pp_delegation ppf res =
Fmt.pf ppf "delegated: %d vms %a cpus %d MB memory %a MB block bridges: %a"
let eq_policy p1 p2 =
let eq_opt a b = match a, b with
| None, None -> true
| Some a, Some b -> eq_int a b
| _ -> false
in
eq_int p1.vms p2.vms &&
IS.equal p1.cpuids p2.cpuids &&
eq_int p1.memory p2.memory &&
eq_opt p1.block p2.block &&
String.Map.equal eq_bridge p1.bridges p2.bridges
let pp_policy ppf res =
Fmt.pf ppf "policy: %d vms %a cpus %d MB memory %a MB block bridges: %a"
res.vms pp_is res.cpuids res.memory
Fmt.(option ~none:(unit "no") int) res.block
Fmt.(list ~sep:(unit ", ") pp_bridge)
@ -169,8 +145,6 @@ let is_sub ~super ~sub =
sub_bridges super.bridges sub.bridges && sub_block super.block sub.block
type vm_config = {
prefix : id ;
vname : string ;
cpuid : int ;
requested_memory : int ;
block_device : string option ;
@ -179,22 +153,13 @@ type vm_config = {
argv : string list option ;
}
let fullname vm = vm.prefix @ [ vm.vname ]
let vm_id vm = string_of_id (fullname vm)
(* used for block devices *)
let location vm = match vm.prefix with
| tld::rest -> tld, String.concat ~sep:"." (rest@[vm.vname])
| [] -> invalid_arg "dunno how this happened"
let pp_image ppf (typ, blob) =
let l = Cstruct.len blob in
Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l
let pp_vm_config ppf (vm : vm_config) =
Fmt.pf ppf "%s cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
vm.vname vm.cpuid vm.requested_memory
Fmt.pf ppf "cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a"
vm.cpuid vm.requested_memory
Fmt.(option ~none:(unit "no") string) vm.block_device
Fmt.(list ~sep:(unit ", ") string) vm.network
pp_image vm.vmimage
@ -204,7 +169,7 @@ let good_bridge idxs nets =
(* TODO: uniqueness of n -- it should be an ordered set? *)
List.for_all (fun n -> String.Map.mem n nets) idxs
let vm_matches_res (res : delegation) (vm : vm_config) =
let vm_matches_res (res : policy) (vm : vm_config) =
res.vms >= 1 && IS.mem vm.cpuid res.cpuids &&
vm.requested_memory <= res.memory &&
good_bridge vm.network res.bridges
@ -238,150 +203,104 @@ let translate_tap vm tap =
| [ (_, b) ] -> Some b
| _ -> None
let identifier serial =
match Hex.of_cstruct @@ Nocrypto.Hash.SHA256.digest @@
Nocrypto.Numeric.Z.to_cstruct_be @@ serial
with
| `Hex str -> fst (String.span ~max:6 str)
let id cert = identifier (X509.serial cert)
let parse_db lines =
List.fold_left (fun acc s ->
acc >>= fun datas ->
match String.cut ~sep:" " s with
| None -> Rresult.R.error_msgf "unable to parse entry %s" s
| Some (a, b) ->
(try Ok (Z.of_string a) with Invalid_argument x -> Error (`Msg x)) >>= fun s ->
Ok ((s, b) :: datas))
(Ok []) lines
let find_in_db label db tst =
try Ok (List.find tst db)
with Not_found -> Rresult.R.error_msgf "couldn't find %s in database" label
let find_name db name =
find_in_db name db (fun (_, n) -> String.equal n name) >>= fun (serial, _) ->
Ok serial
let translate_serial db serial =
let tst (s, _) = String.equal serial (identifier s) in
match find_in_db "" db tst with
| Ok (_, n) -> n
| Error _ -> serial
let translate_name db name =
match find_name db name with
| Ok serial -> identifier serial
| Error _ -> name
(* 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)
type rusage = {
utime : (int64 * int) ;
stime : (int64 * int) ;
maxrss : int64 ;
ixrss : int64 ;
idrss : int64 ;
isrss : int64 ;
minflt : int64 ;
majflt : int64 ;
nswap : int64 ;
inblock : int64 ;
outblock : int64 ;
msgsnd : int64 ;
msgrcv : int64 ;
nsignals : int64 ;
nvcsw : int64 ;
nivcsw : int64 ;
}
let pp_rusage ppf r =
Fmt.pf ppf "utime %Lu.%d stime %Lu.%d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu"
(fst r.utime) (snd r.utime) (fst r.stime) (snd r.stime) r.maxrss r.ixrss r.idrss r.isrss r.minflt r.majflt r.nswap r.inblock r.outblock r.msgsnd r.msgrcv r.nsignals r.nvcsw r.nivcsw
type ifdata = {
name : string ;
flags : int32 ;
send_length : int32 ;
max_send_length : int32 ;
send_drops : int32 ;
mtu : int32 ;
baudrate : int64 ;
input_packets : int64 ;
input_errors : int64 ;
output_packets : int64 ;
output_errors : int64 ;
collisions : int64 ;
input_bytes : int64 ;
output_bytes : int64 ;
input_mcast : int64 ;
output_mcast : int64 ;
input_dropped : int64 ;
output_dropped : int64 ;
}
let pp_ifdata ppf i =
Fmt.pf ppf "name %s flags %lX send_length %lu max_send_length %lu send_drops %lu mtu %lu baudrate %Lu input_packets %Lu input_errors %Lu output_packets %Lu output_errors %Lu collisions %Lu input_bytes %Lu output_bytes %Lu input_mcast %Lu output_mcast %Lu input_dropped %Lu output_dropped %Lu"
i.name i.flags i.send_length i.max_send_length i.send_drops i.mtu i.baudrate i.input_packets i.input_errors i.output_packets i.output_errors i.collisions i.input_bytes i.output_bytes i.input_mcast i.output_mcast i.input_dropped i.output_dropped
module Log = struct
type hdr = {
ts : Ptime.t ;
context : id ;
name : string ;
module Stats = struct
type rusage = {
utime : (int64 * int) ;
stime : (int64 * int) ;
maxrss : int64 ;
ixrss : int64 ;
idrss : int64 ;
isrss : int64 ;
minflt : int64 ;
majflt : int64 ;
nswap : int64 ;
inblock : int64 ;
outblock : int64 ;
msgsnd : int64 ;
msgrcv : int64 ;
nsignals : int64 ;
nvcsw : int64 ;
nivcsw : int64 ;
}
let pp_hdr db ppf (hdr : hdr) =
let name = translate_serial db hdr.name in
Fmt.pf ppf "%a: %s" (Ptime.pp_human ~tz_offset_s:0 ()) hdr.ts name
let pp_rusage ppf r =
Fmt.pf ppf "utime %Lu.%d stime %Lu.%d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu"
(fst r.utime) (snd r.utime) (fst r.stime) (snd r.stime) r.maxrss r.ixrss r.idrss r.isrss r.minflt r.majflt r.nswap r.inblock r.outblock r.msgsnd r.msgrcv r.nsignals r.nvcsw r.nivcsw
let hdr context name = { ts = Ptime_clock.now () ; context ; name }
type event =
[ `Startup
| `Login of Ipaddr.V4.t * int
| `Logout of Ipaddr.V4.t * int
| `VM_start of int * string list * string option
| `VM_stop of int * [ `Exit of int | `Signal of int | `Stop of int ]
| `Block_create of string * int
| `Block_destroy of string
| `Delegate of string list * string option
(* | `CRL of string *)
]
type vmm = (string * int64) list
let pp_vmm ppf vmm =
Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) ppf vmm
let pp_event ppf = function
| `Startup -> Fmt.(pf ppf "STARTUP")
| `Login (ip, port) -> Fmt.pf ppf "LOGIN %a:%d" Ipaddr.V4.pp_hum ip port
| `Logout (ip, port) -> Fmt.pf ppf "LOGOUT %a:%d" Ipaddr.V4.pp_hum ip port
| `VM_start (pid, taps, block) ->
Fmt.pf ppf "STARTED %d (tap %a, block %a)"
pid Fmt.(list ~sep:(unit "; ") string) taps
Fmt.(option ~none:(unit "no") string) block
| `VM_stop (pid, code) ->
let s, c = match code with
| `Exit n -> "exit", n
| `Signal n -> "signal", n
| `Stop n -> "stop", n
in
Fmt.pf ppf "STOPPED %d with %s %a" pid s Fmt.Dump.signal c
| `Block_create (name, size) ->
Fmt.pf ppf "BLOCK_CREATE %s %d" name size
| `Block_destroy name -> Fmt.pf ppf "BLOCK_DESTROY %s" name
| `Delegate (bridges, block) ->
Fmt.pf ppf "DELEGATE %a, block %a"
Fmt.(list ~sep:(unit "; ") string) bridges
Fmt.(option ~none:(unit "no") string) block
(* | `CRL of string *)
type ifdata = {
name : string ;
flags : int32 ;
send_length : int32 ;
max_send_length : int32 ;
send_drops : int32 ;
mtu : int32 ;
baudrate : int64 ;
input_packets : int64 ;
input_errors : int64 ;
output_packets : int64 ;
output_errors : int64 ;
collisions : int64 ;
input_bytes : int64 ;
output_bytes : int64 ;
input_mcast : int64 ;
output_mcast : int64 ;
input_dropped : int64 ;
output_dropped : int64 ;
}
type msg = hdr * event
let pp_ifdata ppf i =
Fmt.pf ppf "name %s flags %lX send_length %lu max_send_length %lu send_drops %lu mtu %lu baudrate %Lu input_packets %Lu input_errors %Lu output_packets %Lu output_errors %Lu collisions %Lu input_bytes %Lu output_bytes %Lu input_mcast %Lu output_mcast %Lu input_dropped %Lu output_dropped %Lu"
i.name i.flags i.send_length i.max_send_length i.send_drops i.mtu i.baudrate i.input_packets i.input_errors i.output_packets i.output_errors i.collisions i.input_bytes i.output_bytes i.input_mcast i.output_mcast i.input_dropped i.output_dropped
let pp db ppf (hdr, event) =
Fmt.pf ppf "%a %a" (pp_hdr db) hdr pp_event event
type t = rusage * vmm option * ifdata list
let pp ppf (ru, vmm, ifs) =
Fmt.pf ppf "%a@.%a@.%a"
pp_rusage ru
Fmt.(option ~none:(unit "no vmm stats") pp_vmm) vmm
Fmt.(list ~sep:(unit "@.@.") pp_ifdata) ifs
end
type process_exit = [ `Exit of int | `Signal of int | `Stop of int ]
let pp_process_exit ppf = function
| `Exit n -> Fmt.pf ppf "exit %a (%d)" Fmt.Dump.signal n n
| `Signal n -> Fmt.pf ppf "signal %a (%d)" Fmt.Dump.signal n n
| `Stop n -> Fmt.pf ppf "stop %a (%d)" Fmt.Dump.signal n n
module Log = struct
type log_event = [
| `Login of id * Ipaddr.V4.t * int
| `Logout of id * Ipaddr.V4.t * int
| `Startup
| `Vm_start of id * int * string list * string option
| `Vm_stop of id * int * process_exit
]
let name = function
| `Startup -> []
| `Login (name, _, _) -> name
| `Logout (name, _, _) -> name
| `Vm_start (name, _, _ ,_) -> name
| `Vm_stop (name, _, _) -> name
let pp_log_event ppf = function
| `Startup -> Fmt.(pf ppf "startup")
| `Login (name, ip, port) -> Fmt.pf ppf "%a login %a:%d" pp_id name Ipaddr.V4.pp_hum ip port
| `Logout (name, ip, port) -> Fmt.pf ppf "%a logout %a:%d" pp_id name Ipaddr.V4.pp_hum ip port
| `Vm_start (name, pid, taps, block) ->
Fmt.pf ppf "%a started %d (tap %a, block %a)"
pp_id name pid Fmt.(list ~sep:(unit "; ") string) taps
Fmt.(option ~none:(unit "no") string) block
| `Vm_stop (name, pid, code) ->
Fmt.pf ppf "%a stopped %d with %a" pp_id name pid pp_process_exit code
type t = Ptime.t * log_event
let pp ppf (ts, ev) =
Fmt.pf ppf "%a: %a" (Ptime.pp_rfc3339 ()) ts pp_log_event ev
end

158
src/vmm_core.mli Normal file
View file

@ -0,0 +1,158 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
val tmpdir : Fpath.t
val dbdir : Fpath.t
type service = [ `Console | `Log | `Stats | `Vmmd ]
val socket_path : service -> string
val pp_socket : service Fmt.t
module I : sig type t = int val compare : int -> int -> int end
module IS : sig
include Set.S with type elt = I.t
end
val pp_is : IS.t Fmt.t
module IM : sig
include Map.S with type key = I.t
end
type id = string list
val string_of_id : string list -> string
val id_of_string : string -> string list
val drop_super : super:string list -> sub:string list -> string list option
val is_sub_id : super:string list -> sub:string list -> bool
val domain : 'a list -> 'a list
val pp_id : id Fmt.t
type bridge =
[ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int
| `Internal of string ]
val eq_bridge : bridge -> bridge -> bool
val pp_bridge : bridge Fmt.t
type policy = {
vms : int;
cpuids : IS.t;
memory : int;
block : int option;
bridges : bridge Astring.String.Map.t;
}
val eq_policy : policy -> policy -> bool
val pp_policy : policy Fmt.t
val sub_bridges : bridge Astring.String.map -> bridge Astring.String.map -> bool
val sub_block : 'a option -> 'a option -> bool
val sub_cpu : IS.t -> IS.t -> bool
val is_sub : super:policy -> sub:policy -> bool
type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ]
val pp_vmtype : vmtype Fmt.t
type vm_config = {
cpuid : int;
requested_memory : int;
block_device : string option;
network : string list;
vmimage : vmtype * Cstruct.t;
argv : string list option;
}
val pp_image : (vmtype * Cstruct.t) Fmt.t
val pp_vm_config : vm_config Fmt.t
val good_bridge : id -> 'a Astring.String.map -> bool
val vm_matches_res : policy -> vm_config -> bool
val check_policies :
vm_config -> policy list -> (unit, [> `Msg of string ]) Result.result
type vm = {
config : vm_config;
cmd : Bos.Cmd.t;
pid : int;
taps : string list;
stdout : Unix.file_descr;
}
val pp_vm : vm Fmt.t
val translate_tap : vm -> string -> string option
module Stats : sig
type rusage = {
utime : int64 * int;
stime : int64 * int;
maxrss : int64;
ixrss : int64;
idrss : int64;
isrss : int64;
minflt : int64;
majflt : int64;
nswap : int64;
inblock : int64;
outblock : int64;
msgsnd : int64;
msgrcv : int64;
nsignals : int64;
nvcsw : int64;
nivcsw : int64;
}
val pp_rusage : rusage Fmt.t
type vmm = (string * int64) list
val pp_vmm : vmm Fmt.t
type ifdata = {
name : string;
flags : int32;
send_length : int32;
max_send_length : int32;
send_drops : int32;
mtu : int32;
baudrate : int64;
input_packets : int64;
input_errors : int64;
output_packets : int64;
output_errors : int64;
collisions : int64;
input_bytes : int64;
output_bytes : int64;
input_mcast : int64;
output_mcast : int64;
input_dropped : int64;
output_dropped : int64;
}
val pp_ifdata : ifdata Fmt.t
type t = rusage * vmm option * ifdata list
val pp : t Fmt.t
end
type process_exit = [ `Exit of int | `Signal of int | `Stop of int ]
val pp_process_exit : process_exit Fmt.t
module Log : sig
type log_event = [
| `Login of id * Ipaddr.V4.t * int
| `Logout of id * Ipaddr.V4.t * int
| `Startup
| `Vm_start of id * int * string list * string option
| `Vm_stop of id * int * process_exit ]
val name : log_event -> id
val pp_log_event : log_event Fmt.t
type t = Ptime.t * log_event
val pp : t Fmt.t
end

View file

@ -1,550 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Astring
open Vmm_core
open Rresult
open R.Infix
type ('a, 'b, 'c) t = {
cmp : 'b -> 'b -> bool ;
console_socket : 'a ;
console_counter : int ;
console_requests : (('a, 'b, 'c) t -> ('a, 'b, 'c) t * [ `Raw of 'a * string | `Tls of 'b * string ] list) IM.t ;
console_attached : 'b String.Map.t ; (* vm_name -> socket *)
console_version : Vmm_wire.version ;
stats_socket : 'a option ;
stats_counter : int ;
stats_requests : ('b * int * (string -> string option)) IM.t ;
stats_version : Vmm_wire.version ;
log_socket : 'a ;
log_counter : int ;
log_requests : ('b * int) IM.t ;
log_attached : ('b * string) list String.Map.t ;
log_version : Vmm_wire.version ;
client_version : Vmm_wire.version ;
(* TODO: refine, maybe:
bridges : (Macaddr.t String.Map.t * String.Set.t) String.Map.t ; *)
used_bridges : String.Set.t String.Map.t ;
(* TODO: used block devices (since each may only be active once) *)
resources : Vmm_resources.t ;
tasks : 'c String.Map.t ;
crls : X509.CRL.c list ;
}
let init cmp console_socket stats_socket log_socket =
(* error hard on permission denied etc. *)
let crls = Fpath.(dbdir / "crls") in
(Bos.OS.Dir.exists crls >>= function
| true -> Ok true
| false -> Bos.OS.Dir.create crls) >>= fun _ ->
let err _ x = x in
Bos.OS.Dir.fold_contents ~elements:`Files ~traverse:`None ~err
(fun f acc ->
acc >>= fun acc ->
Bos.OS.File.read f >>= fun data ->
match X509.Encoding.crl_of_cstruct (Cstruct.of_string data) with
| None -> R.error_msgf "couldn't parse CRL %a" Fpath.pp f
| Some crl -> Ok (crl :: acc))
(Ok [])
crls >>= fun crls ->
crls >>= fun crls ->
Ok {
cmp ;
console_socket ; console_counter = 1 ; console_requests = IM.empty ;
console_attached = String.Map.empty ; console_version = `WV0 ;
stats_socket ; stats_counter = 1 ; stats_requests = IM.empty ;
stats_version = `WV1 ;
log_socket ; log_counter = 1 ; log_attached = String.Map.empty ;
log_version = `WV0 ; log_requests = IM.empty ;
client_version = `WV0 ;
used_bridges = String.Map.empty ;
resources = Vmm_resources.empty ;
tasks = String.Map.empty ;
crls
}
let asn_version = `AV0
let log state (hdr, event) =
let pre = string_of_id hdr.Log.context in
let out = match String.Map.find pre state.log_attached with
| None -> []
| Some x -> x
in
let data = Vmm_wire.Log.data state.log_counter state.log_version hdr event in
let tls = Vmm_wire.Client.log hdr event state.client_version in
let log_counter = succ state.log_counter in
Logs.debug (fun m -> m "LOG %a" (Log.pp []) (hdr, event)) ;
({ state with log_counter },
`Raw (state.log_socket, data) :: List.map (fun (s, _) -> `Tls (s, tls)) out)
let stat state str =
match state.stats_socket with
| None -> []
| Some s -> [ `Raw (s, str) ]
let handle_disconnect state t =
Logs.err (fun m -> m "disconnect!!") ;
let rem, console_attached =
String.Map.partition (fun _ s -> state.cmp s t) state.console_attached
in
let out, console_counter =
List.fold_left (fun (acc, ctr) name ->
(acc ^ Vmm_wire.Console.detach ctr state.console_version name, succ ctr))
("", state.console_counter)
(fst (List.split (String.Map.bindings rem)))
in
let log_attached = String.Map.fold (fun k v n ->
match List.filter (fun (e, _) -> not (state.cmp t e)) v with
| [] -> n
| xs -> String.Map.add k xs n)
state.log_attached String.Map.empty
in
let out =
if String.length out = 0 then
[]
else
[ (state.console_socket, out) ]
in
{ state with console_attached ; console_counter ; log_attached }, out
let handle_create t vm_config policies =
let full = fullname vm_config in
(if Vmm_resources.exists t.resources full then
Error (`Msg "VM with same name is already running")
else
Ok ()) >>= fun () ->
Logs.debug (fun m -> m "now checking dynamic policies") ;
Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () ->
(* prepare VM: save VM image to disk, create fifo, ... *)
Vmm_commands.prepare vm_config >>= fun taps ->
Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
Ok (fun t s ->
(* actually execute the vm *)
Vmm_commands.exec vm_config taps >>= fun vm ->
Logs.debug (fun m -> m "exec()ed vm") ;
Vmm_resources.insert t.resources full vm >>= fun resources ->
let used_bridges =
List.fold_left2 (fun b br ta ->
let old = match String.Map.find br b with
| None -> String.Set.empty
| Some x -> x
in
String.Map.add br (String.Set.add ta old) b)
t.used_bridges vm_config.network taps
in
let t = { t with resources ; used_bridges } in
let t, out = log t (Log.hdr vm_config.prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in
let tls_out = Vmm_wire.success ~msg:"VM started" 0 t.client_version in
Ok (t, `Tls (s, tls_out) :: out, vm))
let setup_stats t vm =
let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version (vm_id vm.config) vm.pid vm.taps in
let t = { t with stats_counter = succ t.stats_counter } in
Ok (t, stat t stat_out)
let handle_shutdown t vm r =
(match Vmm_commands.shutdown vm with
| Ok () -> ()
| Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ;
let resources =
match Vmm_resources.remove t.resources (fullname vm.config) vm with
| Ok resources -> resources
| Error (`Msg e) ->
Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ;
t.resources
in
let used_bridges =
List.fold_left2 (fun b br ta ->
let old = match String.Map.find br b with
| None -> String.Set.empty
| Some x -> x
in
String.Map.add br (String.Set.remove ta old) b)
t.used_bridges vm.config.network vm.taps
in
let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version (vm_id vm.config) in
let tasks = String.Map.remove (vm_id vm.config) t.tasks in
let t = { t with stats_counter = succ t.stats_counter ; resources ; used_bridges ; tasks } in
let t, outs = log t (Log.hdr vm.config.prefix vm.config.vname,
`VM_stop (vm.pid, r))
in
(t, stat t stat_out @ outs)
let handle_command t s prefix perms hdr buf =
let res =
if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then
Error (`Msg "unknown client version")
else match Vmm_wire.Client.cmd_of_int hdr.Vmm_wire.tag with
| None -> Error (`Msg "unknown command")
| Some x when cmd_allowed perms x ->
begin
Vmm_wire.decode_str buf >>= fun (buf, _l) ->
let arg = if String.length buf = 0 then prefix else prefix @ [buf] in
let vmid = string_of_id arg in
match x with
| Info ->
begin match Vmm_resources.find t.resources arg with
| None ->
Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ;
R.error_msgf "info: %s not found" buf
| Some x ->
let data =
Vmm_resources.fold (fun acc vm ->
acc ^ Vmm_wire.Client.encode_vm vm.config.vname vm)
"" x
in
let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in
Ok (t, [ `Tls (s, out) ])
end
| Destroy_vm ->
begin match Vmm_resources.find_vm t.resources arg with
| Some vm ->
Vmm_commands.destroy vm ;
let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
Ok (t, [ `Tls (s, out) ])
| _ ->
Error (`Msg ("destroy: not found " ^ buf))
end
| Attach ->
(* TODO: get (optionally) <since> from client, instead of hardcoding Ptime.epoch below *)
let on_success t =
let cons = Vmm_wire.Console.history t.console_counter t.console_version vmid Ptime.epoch in
let old = match String.Map.find vmid t.console_attached with
| None -> []
| Some s ->
let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
[ `Tls (s, out) ]
in
let console_attached = String.Map.add vmid s t.console_attached in
{ t with console_counter = succ t.console_counter ; console_attached },
`Raw (t.console_socket, cons) :: old
in
let cons = Vmm_wire.Console.attach t.console_counter t.console_version vmid in
let console_requests = IM.add t.console_counter on_success t.console_requests in
Ok ({ t with console_counter = succ t.console_counter ; console_requests },
[ `Raw (t.console_socket, cons) ])
| Detach ->
let cons = Vmm_wire.Console.detach t.console_counter t.console_version vmid in
(match String.Map.find vmid t.console_attached with
| None -> Error (`Msg "not attached")
| Some x when t.cmp x s -> Ok (String.Map.remove vmid t.console_attached)
| Some _ -> Error (`Msg "this socket is not attached")) >>= fun console_attached ->
let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in
Ok ({ t with console_counter = succ t.console_counter ; console_attached },
[ `Raw (t.console_socket, cons) ; `Tls (s, out) ])
| Statistics ->
begin match t.stats_socket with
| None -> Error (`Msg "no statistics available")
| Some _ -> match Vmm_resources.find_vm t.resources arg with
| Some vm ->
let stat_out = Vmm_wire.Stats.stat t.stats_counter t.stats_version vmid in
let d = (s, hdr.Vmm_wire.id, translate_tap vm) in
let stats_requests = IM.add t.stats_counter d t.stats_requests in
Ok ({ t with stats_counter = succ t.stats_counter ; stats_requests },
stat t stat_out)
| _ -> Error (`Msg ("statistics: not found " ^ buf))
end
| Log ->
begin
let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in
let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in
let log_counter = succ t.log_counter in
Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ])
end
| Create_block | Destroy_block -> Error (`Msg "NYI")
end
| Some _ -> Error (`Msg "unauthorised command")
in
match res with
| Ok r -> r
| Error (`Msg msg) ->
Logs.debug (fun m -> m "error while processing command: %s" msg) ;
let out = Vmm_wire.fail ~msg hdr.Vmm_wire.id t.client_version in
(t, [ `Tls (s, out) ])
let handle_single_revocation t prefix serial =
let id = identifier serial in
(match Vmm_resources.find t.resources (prefix @ [ id ]) with
| None -> ()
| Some e -> Vmm_resources.iter Vmm_commands.destroy e) ;
(* also revoke all active sessions!? *)
(* TODO: maybe we need a vmm_resources like structure for sessions as well!? *)
let log_attached, kill =
let pid = string_of_id prefix in
match String.Map.find pid t.log_attached with
| None -> t.log_attached, []
| Some xs ->
(* those where snd v = serial: drop *)
let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in
String.Map.add pid keep t.log_attached, drop
in
(* two things:
1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above]
2 revoked CA certs need to wipe subtree (all entries where k starts with prefix @ serial) *)
let log_attached, kill =
String.Map.fold (fun k' v (l, k) ->
if is_sub_id ~super:(prefix@[id]) ~sub:(id_of_string k') then
(l, v @ k)
else
(String.Map.add k' v l, k))
log_attached
(String.Map.empty, kill)
in
let state, out =
List.fold_left (fun (s, out) (t, _) ->
let s', out' = handle_disconnect s t in
s', out @ out')
({ t with log_attached }, [])
kill
in
(state,
List.map (fun x -> `Raw x) out,
List.map fst kill)
let handle_revocation t s leaf chain ca prefix =
Vmm_asn.crl_of_cert leaf >>= fun crl ->
(* verify data (must be signed by the last cert of the chain (or cacert if chain is empty))! *)
let issuer = match chain with
| subca::_ -> subca
| [] -> ca
in
let time = Ptime_clock.now () in
(if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () ->
(* the this_update must be > now, next_update < now, this_update > <local>.this_update, number > <local>.number *)
(* TODO: can we have something better for uniqueness of CRL? *)
let local = try Some (List.find (fun crl -> X509.CRL.verify crl issuer) t.crls) with Not_found -> None in
(match local with
| None -> Ok ()
| Some local -> match X509.CRL.crl_number local, X509.CRL.crl_number crl with
| None, _ -> Ok ()
| Some _, None -> Error (`Msg "CRL number not present")
| Some x, Some y -> if y > x then Ok () else Error (`Msg "CRL number not increased")) >>= fun () ->
(* filename should be whatever_dir / crls / <id> *)
let filename = Fpath.(dbdir / "crls" / string_of_id prefix) in
Bos.OS.File.delete filename >>= fun () ->
Bos.OS.File.write filename (Cstruct.to_string (X509.Encoding.crl_to_cstruct crl)) >>= fun () ->
(* remove crl with same issuer from crls, and inject this one into state *)
let crls =
match local with
| None -> crl :: t.crls
| Some _ -> crl :: List.filter (fun c -> c <> crl) t.crls
in
(* iterate over revoked serials, find active resources, and kill them *)
let newly_revoked =
let old = match local with
| Some x -> List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates x)
| None -> []
in
let new_rev = List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates crl) in
List.filter (fun n -> not (List.mem n old)) new_rev
in
let t, out, close =
List.fold_left (fun (t, out, close) serial ->
let t', out', close' = handle_single_revocation t prefix serial in
(t', out @ out', close @ close'))
(t, [], []) newly_revoked
in
let tls_out = Vmm_wire.success ~msg:"updated revocation list" 0 t.client_version in
Ok ({ t with crls }, `Tls (s, tls_out) :: out, `Close close)
let handle_initial t s addr chain ca =
separate_chain chain >>= fun (leaf, chain) ->
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 prefix = List.map id chain in
let login_hdr, login_ev = Log.hdr prefix (id leaf), `Login addr in
let t, out = log t (login_hdr, login_ev) in
let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in
Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms ->
(if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then
(* convert certificate to vm_config *)
Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config ->
Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ;
(* 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 t, task =
let force = List.mem `Force_create perms in
if force then
let fid = vm_id vm_config in
match String.Map.find fid t.tasks with
| None -> t, None
| Some task ->
let kill () =
match Vmm_resources.find_vm t.resources (fullname vm_config) with
| None ->
Logs.err (fun m -> m "found a task, but no vm for %a (%s)"
pp_id (fullname vm_config) fid)
| Some vm ->
Logs.debug (fun m -> m "killing %a now" pp_vm vm) ;
Vmm_commands.destroy vm
in
let tasks = String.Map.remove fid t.tasks in
({ t with tasks }, Some (kill, task))
else
t, None
in
let next t sleeper =
handle_create t vm_config policies >>= fun cont ->
let id = vm_id vm_config in
let cons = Vmm_wire.Console.add t.console_counter t.console_version id in
let tasks = String.Map.add id sleeper t.tasks in
Ok ({ t with console_counter = succ t.console_counter ; tasks },
[ `Raw (t.console_socket, cons) ],
cont)
in
Ok (t, [], `Create (task, next))
else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then
handle_revocation t s leaf chain ca prefix
else
let log_attached =
if cmd_allowed perms Log then
let pre = string_of_id prefix in
let v = match String.Map.find pre t.log_attached with
| None -> []
| Some xs -> xs
in
String.Map.add pre ((s, id leaf) :: v) t.log_attached
else
t.log_attached
in
Ok ({ t with log_attached }, [], `Loop (prefix, perms))
) >>= fun (t, outs, res) ->
Ok (t, initial_out :: out @ outs, res)
let handle_stat state hdr data =
let open Vmm_wire in
if not (version_eq hdr.version state.stats_version) then begin
Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
state, []
end else if hdr.tag = success_tag then
state, []
else
match IM.find hdr.id state.stats_requests with
| exception Not_found ->
Logs.err (fun m -> m "couldn't find stat request") ;
state, []
| (s, req_id, f) ->
let stats_requests = IM.remove hdr.id state.stats_requests in
let state = { state with stats_requests } in
let out =
match Stats.int_to_op hdr.tag with
| Some Stats.Stat_reply ->
begin match Stats.decode_stats (Cstruct.of_string data) with
| Ok (ru, vmm, ifs) ->
let ifs =
List.map
(fun x ->
match f x.name with
| Some name -> { x with name }
| None -> x)
ifs
in
let data = Cstruct.to_string (Stats.encode_stats (ru, vmm, ifs)) in
let out = Client.stat data req_id state.client_version in
[ `Tls (s, out) ]
| Error (`Msg msg) ->
Logs.err (fun m -> m "error %s while decode statistics" msg) ;
let out = fail req_id state.client_version in
[ `Tls (s, out) ]
end
| None when hdr.tag = fail_tag ->
let out = fail ~msg:data req_id state.client_version in
[ `Tls (s, out) ]
| _ ->
Logs.err (fun m -> m "unexpected reply from stat") ;
[]
in
(state, out)
let handle_cons state hdr data =
let open Vmm_wire in
if not (version_eq hdr.version state.console_version) then begin
Logs.warn (fun m -> m "ignoring message with unknown console version") ;
state, []
end else match Console.int_to_op hdr.tag with
| Some Console.Data ->
begin match decode_str data with
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while decoding console message %s" msg) ;
(state, [])
| Ok (file, off) ->
(match String.Map.find file state.console_attached with
| Some s ->
let out = Client.console off file data state.client_version in
(state, [ `Tls (s, out) ])
| None ->
(* TODO: should detach? *)
Logs.err (fun m -> m "couldn't find attached console for %s" file) ;
(state, []))
end
| None when hdr.tag = success_tag ->
(match IM.find hdr.id state.console_requests with
| exception Not_found ->
(state, [])
| cont ->
let state', outs = cont state in
let console_requests = IM.remove hdr.id state.console_requests in
({ state' with console_requests }, outs))
| None when hdr.tag = fail_tag ->
(match IM.find hdr.id state.console_requests with
| exception Not_found ->
Logs.err (fun m -> m "fail couldn't find request id") ;
(state, [])
| _ ->
Logs.err (fun m -> m "failed while trying to do something on console") ;
let console_requests = IM.remove hdr.id state.console_requests in
({ state with console_requests }, []))
| _ ->
Logs.err (fun m -> m "unexpected message received from console socket") ;
(state, [])
let handle_log state hdr buf =
let open Vmm_wire in
let open Vmm_wire.Log in
if not (version_eq hdr.version state.log_version) then begin
Logs.warn (fun m -> m "ignoring message with unknown stats version") ;
state, []
end else match IM.find hdr.id state.log_requests with
| exception Not_found ->
Logs.warn (fun m -> m "(ignored) coudn't find log request") ;
(state, [])
| (s, rid) ->
let r = match int_to_op hdr.tag with
| Some Data ->
decode_log_hdr (Cstruct.of_string buf) >>= fun (hdr, rest) ->
decode_event rest >>= fun event ->
let tls = Vmm_wire.Client.log hdr event state.client_version in
Ok (state, [ `Tls (s, tls) ])
| None when hdr.tag = success_tag ->
let log_requests = IM.remove hdr.id state.log_requests in
let tls = Vmm_wire.success rid state.client_version in
Ok ({ state with log_requests }, [ `Tls (s, tls) ])
| None when hdr.tag = fail_tag ->
let log_requests = IM.remove hdr.id state.log_requests in
let tls = Vmm_wire.fail rid state.client_version in
Ok ({ state with log_requests }, [ `Tls (s, tls) ])
| _ ->
Logs.err (fun m -> m "couldn't parse log reply") ;
let log_requests = IM.remove hdr.id state.log_requests in
Ok ({ state with log_requests }, [])
in
match r with
| Ok (s, out) -> s, out
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while processing log %s" msg) ;
state, []

View file

@ -2,6 +2,11 @@
open Lwt.Infix
let pp_sockaddr ppf = function
| Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str
| Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d"
(Unix.string_of_inet_addr addr) port
let pp_process_status ppf = function
| Unix.WEXITED c -> Fmt.pf ppf "exited with %d" c
| Unix.WSIGNALED s -> Fmt.pf ppf "killed by signal %a" Fmt.Dump.signal s
@ -27,7 +32,7 @@ let rec waitpid pid =
let wait_and_clear pid stdout =
Logs.debug (fun m -> m "waitpid() for pid %d" pid) ;
waitpid pid >|= fun r ->
Vmm_commands.close_no_err stdout ;
Vmm_unix.close_no_err stdout ;
match r with
| Error () ->
Logs.err (fun m -> m "waitpid() for %d returned error" pid) ;
@ -36,8 +41,8 @@ let wait_and_clear pid stdout =
Logs.debug (fun m -> m "pid %d exited: %a" pid pp_process_status s) ;
ret s
let read_exactly s =
let buf = Bytes.create 8 in
let read_wire s =
let buf = Bytes.create 4 in
let rec r b i l =
Lwt.catch (fun () ->
Lwt_unix.read s b i l >>= function
@ -53,29 +58,28 @@ let read_exactly s =
let err = Printexc.to_string e in
Logs.err (fun m -> m "exception %s while reading" err) ;
Lwt.return (Error `Exception))
in
r buf 0 8 >>= function
r buf 0 4 >>= function
| Error e -> Lwt.return (Error e)
| Ok () ->
match Vmm_wire.parse_header (Bytes.to_string buf) with
| Error (`Msg m) -> Lwt.return (Error (`Msg m))
| Ok hdr ->
let l = hdr.Vmm_wire.length in
if l > 0 then
let b = Bytes.create l in
r b 0 l >|= function
| Error e -> Error e
| Ok () ->
(* Logs.debug (fun m -> m "read hdr %a, body %a"
let len = Cstruct.BE.get_uint32 (Cstruct.of_bytes buf) 0 in
if len > 0l then
let b = Bytes.create (Int32.to_int len) in
r b 0 (Int32.to_int len) >|= function
| Error e -> Error e
| Ok () ->
(* Logs.debug (fun m -> m "read hdr %a, body %a"
Cstruct.hexdump_pp (Cstruct.of_bytes buf)
Cstruct.hexdump_pp (Cstruct.of_bytes b)) ; *)
Ok (hdr, Bytes.to_string b)
else
Lwt.return (Ok (hdr, ""))
match Vmm_asn.wire_of_cstruct (Cstruct.of_bytes b) with
| Ok w -> Ok w
| Error (`Msg msg) ->
Logs.err (fun m -> m "error %s while parsing data" msg) ;
Error `Exception
else
Lwt.return (Error `Eof)
let write_raw s buf =
let buf = Bytes.unsafe_of_string buf in
let rec w off l =
Lwt.catch (fun () ->
Lwt_unix.send s buf off l [] >>= fun n ->
@ -87,5 +91,42 @@ let write_raw s buf =
Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ;
Lwt.return (Error `Exception))
in
(* Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *)
(* Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *)
w 0 (Bytes.length buf)
let write_wire s wire =
let data = Vmm_asn.wire_to_cstruct wire in
let dlen = Cstruct.create 4 in
Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ;
let buf = Cstruct.(to_bytes (append dlen data)) in
write_raw s buf
let safe_close fd =
Lwt.catch
(fun () -> Lwt_unix.close fd)
(fun _ -> Lwt.return_unit)
let read_from_file file =
Lwt.catch (fun () ->
Lwt_unix.stat file >>= fun stat ->
let size = stat.Lwt_unix.st_size in
Lwt_unix.openfile file Lwt_unix.[O_RDONLY] 0 >>= fun fd ->
Lwt.catch (fun () ->
let buf = Bytes.create size in
let rec read off =
Lwt_unix.read fd buf off (size - off) >>= fun bytes ->
if bytes + off = size then
Lwt.return_unit
else
read (bytes + off)
in
read 0 >>= fun () ->
safe_close fd >|= fun () ->
Cstruct.of_bytes buf)
(fun e ->
Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ;
safe_close fd >|= fun () ->
Cstruct.empty))
(fun e ->
Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ;
Lwt.return Cstruct.empty)

24
src/vmm_lwt.mli Normal file
View file

@ -0,0 +1,24 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
val pp_sockaddr : Format.formatter -> Lwt_unix.sockaddr -> unit
val pp_process_status : Format.formatter -> Unix.process_status -> unit
val ret : Unix.process_status -> Vmm_core.process_exit
val waitpid : int -> (int * Lwt_unix.process_status, unit) result Lwt.t
val wait_and_clear : int -> Unix.file_descr -> Vmm_core.process_exit Lwt.t
val read_wire : Lwt_unix.file_descr ->
(Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t
val write_raw :
Lwt_unix.file_descr -> bytes -> (unit, [> `Exception ]) result Lwt.t
val write_wire :
Lwt_unix.file_descr -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t
val safe_close : Lwt_unix.file_descr -> unit Lwt.t
val read_from_file : string -> Cstruct.t Lwt.t

View file

@ -1,8 +1,5 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Astring
open Rresult.R.Infix
open Vmm_core
type res_entry = {
@ -10,118 +7,113 @@ type res_entry = {
used_memory : int ;
}
let pp_res_entry ppf res =
Fmt.pf ppf "%d vms %d memory" res.running_vms res.used_memory
let empty_res = { running_vms = 0 ; used_memory = 0 }
let check_resource (policy : delegation) (vm : vm_config) (res : res_entry) =
succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory
let check_resource (policy : policy) (vm : vm_config) (res : res_entry) =
succ res.running_vms <= policy.vms &&
res.used_memory + vm.requested_memory <= policy.memory &&
vm_matches_res policy vm
let check_resource_policy (policy : policy) (res : res_entry) =
res.running_vms <= policy.vms && res.used_memory <= policy.memory
let add (vm : vm) (res : res_entry) =
{ running_vms = succ res.running_vms ;
used_memory = vm.config.requested_memory + res.used_memory }
let rem (vm : vm) (res : res_entry) =
{ running_vms = pred res.running_vms ;
used_memory = res.used_memory - vm.config.requested_memory }
type entry =
| Leaf of vm
| Subtree of res_entry * entry String.Map.t
| Vm of vm
| Policy of policy
type t = entry String.Map.t
type t = entry Vmm_trie.t
let empty = String.Map.empty
let pp ppf t =
Vmm_trie.fold [] t
(fun id ele () -> match ele with
| Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config
| Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p)
()
let check_dynamic m vm policies =
(* for each policy (string * delegation), we need to look that vm + dynamic <= delegation *)
let rec go m = function
| [] -> Ok ()
| (nam,delegation)::rest ->
match String.Map.find nam m with
| None -> Ok ()
| Some (Leaf _) -> Error (`Msg "didn't expect a leaf here")
| Some (Subtree (r, m)) ->
if check_resource delegation vm r then
go m rest
else
Error (`Msg ("overcommitted at " ^ nam))
in
go m policies
let empty = Vmm_trie.empty
let rec pp_entry ppf = function
| Leaf vm -> pp_vm ppf vm
| Subtree (res, m) ->
Fmt.pf ppf "%a %a"
pp_res_entry res
Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry))
(String.Map.bindings m)
let fold t name f g acc =
Vmm_trie.fold name t (fun prefix entry acc ->
match entry with
| Vm vm -> f prefix vm acc
| Policy p -> g prefix p acc) acc
let pp ppf map =
Fmt.pf ppf "%a"
Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry))
(String.Map.bindings map)
(* we should hide this type and confirm the following invariant:
- in case Vm, there are no siblings *)
let find t name =
let rec find r m = function
| [] -> Some (Subtree (r, m))
| x::xs -> match String.Map.find x m with
| None -> None
| Some (Subtree (r, m)) -> find r m xs
| Some (Leaf vm) -> Some (Leaf vm)
in
find empty_res t name
let resource_usage t name =
Vmm_trie.fold name t (fun _ entry acc ->
match entry with
| Policy _ -> acc
| Vm vm -> add vm acc)
empty_res
let exists t name = match find t name with None -> false | Some _ -> true
let find_vm t name = match find t name with
| Some (Leaf vm) -> Some vm
let find_vm t name = match Vmm_trie.find name t with
| Some (Vm vm) -> Some vm
| _ -> None
let rec iter f = function
| Leaf vm -> f vm
| Subtree (_, m) -> List.iter (fun (_, e) -> iter f e) (String.Map.bindings m)
let find_policy t name = match Vmm_trie.find name t with
| Some (Policy p) -> Some p
| _ -> None
let rec fold f acc = function
| Leaf vm -> f acc vm
| Subtree (_, m) ->
List.fold_left (fun acc (_, e) -> fold f acc e) acc (String.Map.bindings m)
let remove_vm t name = match find_vm t name with
| None -> Error (`Msg "unknown vm")
| Some _ -> Ok (Vmm_trie.remove name t)
let insert m name v =
let rec insert m = function
| [] -> Error (`Msg "ran out of labels during insert, this should not happen")
| [l] ->
begin match String.Map.find l m with
| None -> Ok (String.Map.add l (Leaf v) m)
| Some (Subtree _) -> Error (`Msg "found a subtree as last label")
| Some (Leaf _) -> Ok (String.Map.add l (Leaf v) m)
end
| l::ls ->
match String.Map.find l m with
| None ->
insert String.Map.empty ls >>= fun sub ->
Ok (String.Map.add l (Subtree (add v empty_res, sub)) m)
| Some (Subtree (r, m')) ->
insert m' ls >>= fun sub ->
Ok (String.Map.add l (Subtree (add v r, sub)) m)
| Some (Leaf _) -> Error (`Msg "should not happen: found leaf while still having labels")
in
insert m name
let remove_policy t name = match find_policy t name with
| None -> Error (`Msg "unknown policy")
| Some _ -> Ok (Vmm_trie.remove name t)
let remove m name vm =
let rec del m = function
| [] -> Error (`Msg "should not happen: empty labels in remove")
| [l] -> Ok (String.Map.remove l m)
| l::ls -> match String.Map.find l m with
| None -> Error (`Msg "should not happen: found nothing in remove while still had some labels")
| Some (Subtree (r, m')) ->
del m' ls >>= fun m' ->
if String.Map.is_empty m' then
Ok (String.Map.remove l m)
else
let res = rem vm r in
Ok (String.Map.add l (Subtree (res, m')) m)
| Some (Leaf _) -> Error (`Msg "should not happen: found a leaf, but had some labels")
in
del m name
let check_vm_policy t name vm =
let dom = domain name in
let res = resource_usage t dom in
match Vmm_trie.find dom t with
| None -> true
| Some (Vm _) -> assert false
| Some (Policy p) -> check_resource p vm res
let insert_vm t name vm =
if check_vm_policy t name vm.config then
match Vmm_trie.insert name (Vm vm) t with
| t', None -> Ok t'
| _, Some _ -> Error (`Msg "vm already exists")
else
Error (`Msg "resource policy mismatch")
let check_policy_above t name p =
let above = Vmm_trie.collect name t in
List.for_all (fun (_, node) -> match node with
| Vm _ -> assert false
| Policy p' -> is_sub ~super:p' ~sub:p)
above
let check_policy_below t name p =
Vmm_trie.fold name t (fun name entry res ->
match name with
| [] -> res
| _ ->
match res, entry with
| Ok p, Policy p' -> if is_sub ~super:p ~sub:p then Ok p' else Error ()
| Ok p, Vm vm ->
let cfg = vm.config in
if IS.mem cfg.cpuid p.cpuids && good_bridge cfg.network p.bridges
then Ok p
else Error ()
| res, _ -> res)
(Ok p)
let insert_policy t name p =
let dom = domain name in
match
check_policy_above t dom p,
check_policy_below t name p,
check_resource_policy p (resource_usage t dom)
with
| true, Ok _, true -> Ok (fst (Vmm_trie.insert name (Policy p) t))
| false, _, _ -> Error (`Msg "policy violates other policies above")
| _, Error (), _ -> Error (`Msg "policy violates other policies below")
| _, _, false -> Error (`Msg "more resources used than policy would allow")

View file

@ -1,6 +1,6 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(** A tree data structure tracking dynamic resource usage.
(** A tree data structure including policies and dynamic usage.
Considering delegation of resources to someone, and further delegation
to others - using a process which is not controlled by the authority -
@ -14,43 +14,37 @@
(** The type of the resource tree. *)
type t
(** The type of the resource tree entry. *)
type entry
(** [empty] is the empty tree. *)
val empty : t
(** [pp ppf t] pretty prints the tree. *)
val pp : t Fmt.t
(** [pp_entry ppf e] pretty prints the entry. *)
val pp_entry : entry Fmt.t
(** [check_dynamic t vm delegates] checks whether creating [vm] would violate
the policies of the [delegates] with respect to the running vms. *)
val check_dynamic : t ->
Vmm_core.vm_config -> (string * Vmm_core.delegation) list ->
(unit, [> `Msg of string ]) result
(** [exists t id] is [true] if the [id] already exists, [false] otherwise. *)
val exists : t -> Vmm_core.id -> bool
(** [find t id] is either [Some entry] or [None]. *)
val find : t -> Vmm_core.id -> entry option
(** [find_vm t id] is either [Some vm] or [None]. *)
val find_vm : t -> Vmm_core.id -> Vmm_core.vm option
(** [iter f entry] applies [f] to each vm of [entry]. *)
val iter : (Vmm_core.vm -> unit) -> entry -> unit
(** [find_policy t id] is either [Some policy] or [None]. *)
val find_policy : t -> Vmm_core.id -> Vmm_core.policy option
(** [fold f entry acc] folds [f] over [entry]. *)
val fold : ('a -> Vmm_core.vm -> 'a) -> 'a -> entry -> 'a
(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be
allowed under the current policies. *)
val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> bool
(** [insert t id vm] inserts [vm] under [id] in [t], and returns the new [t] or
an error. It also updates the resource usages on the path. *)
val insert : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or
an error. *)
val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
(** [remove t id vm] removes [id] from [t], and returns the new [t] or an
error. This also updates the resources usages on the path. *)
val remove : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result
(** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns
the new [t] or an error. *)
val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result
(** [remove_vm t id] removes vm [id] from [t]. *)
val remove_vm : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
(** [remove_policy t id] removes policy [id] from [t]. *)
val remove_policy : t -> Vmm_core.id -> (t, [> `Msg of string ]) result
(** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *)
val fold : t -> Vmm_core.id ->
(Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) ->
(Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a
(** [pp] is a pretty printer for [t]. *)
val pp : t Fmt.t

View file

@ -2,23 +2,41 @@
(* a ring buffer with N strings, dropping old ones *)
type t = {
data : (Ptime.t * string) array ;
type 'a t = {
data : (Ptime.t * 'a) array ;
mutable write : int ;
size : int ;
}
let create ?(size = 1024) () =
{ data = Array.make 1024 (Ptime.min, "") ; write = 0 ; size }
let create ?(size = 1024) neutral () =
{ data = Array.make 1024 (Ptime.min, neutral) ; write = 0 ; size }
let inc t = (succ t.write) mod t.size
let write t v =
Array.set t.data t.write v ;
let write t entry =
Array.set t.data t.write entry ;
t.write <- inc t
let dec t n = (pred n + t.size) mod t.size
let written (ts, _) = not (Ptime.equal ts Ptime.min)
let read t =
let rec go s acc idx =
if idx = s then (* don't read it twice *)
acc
else
let entry = Array.get t.data idx in
if written entry then go s (entry :: acc) (dec t idx)
else acc
in
let idx = dec t t.write in
let s =
let entry = Array.get t.data idx in
if written entry then [entry] else []
in
go idx s (dec t idx)
let earlier ts than =
if ts = Ptime.min then true
else Ptime.is_earlier ts ~than

9
src/vmm_ring.mli Normal file
View file

@ -0,0 +1,9 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
type 'a t
val create : ?size:int -> 'a -> unit -> 'a t
val write : 'a t -> Ptime.t * 'a -> unit
val read : 'a t -> (Ptime.t * 'a) list
val read_history : 'a t -> Ptime.t -> (Ptime.t * 'a) list

View file

@ -1,59 +1,92 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
open Rresult
open Rresult.R.Infix
let read_tls t =
let rec r_n buf off tot =
let l = tot - off in
if l = 0 then
Lwt.return (Ok ())
else
Lwt.catch (fun () ->
Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function
| 0 ->
Logs.err (fun m -> m "TLS: end of file") ;
Lwt.return (Error `Eof)
| x when x == l -> Lwt.return (Ok ())
| x when x < l -> r_n buf (off + x) tot
| _ ->
Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ;
Lwt.return (Error `Toomuch))
(function
| Tls_lwt.Tls_failure a ->
Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ;
Lwt.return (Error `Exception)
| e ->
Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ;
Lwt.return (Error `Exception))
in
let buf = Cstruct.create 8 in
r_n buf 0 8 >>= function
| Error e -> Lwt.return (Error e)
| Ok () ->
match Vmm_wire.parse_header (Cstruct.to_string buf) with
| Error (`Msg m) -> Lwt.return (Error (`Msg m))
| Ok hdr ->
let l = hdr.Vmm_wire.length in
if l > 0 then
let b = Cstruct.create l in
r_n b 0 l >|= function
| Error e -> Error e
| Ok () ->
(* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a"
hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag
Cstruct.hexdump_pp b) ; *)
Ok (hdr, Cstruct.to_string b)
(* we skip all non-albatross certificates *)
let cert_name cert =
match X509.Extension.unsupported cert Vmm_asn.oid with
| None -> Ok None
| Some (_, data) ->
let name = X509.common_name_to_string cert in
if name = "" then
match Vmm_asn.cert_extension_of_cstruct data with
| Error (`Msg _) -> Error (`Msg "couldn't parse albatross extension")
| Ok (_, `Policy_cmd (`Policy_add _)) -> Error (`Msg "policy add may not have an empty name")
| _ -> Ok None
else Ok (Some name)
let name chain =
List.fold_left (fun acc cert ->
match acc, cert_name cert with
| Error e, _ -> Error e
| _, Error e -> Error e
| Ok acc, Ok None -> Ok acc
| Ok acc, Ok Some data -> Ok (data :: acc))
(Ok []) chain
(* 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 -> Error `Not_present
| Some (_, data) ->
match Vmm_asn.cert_extension_of_cstruct data with
| Error (`Msg p) -> Error (`Parse p)
| Ok (v, wire) ->
if not (Vmm_commands.version_eq v version) then
Error (`Version v)
else
Lwt.return (Ok (hdr, ""))
Ok wire
let write_tls s buf =
(* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *)
Lwt.catch
(fun () -> Tls_lwt.Unix.write s (Cstruct.of_string buf) >|= fun () -> Ok ())
(function
| Tls_lwt.Tls_failure a ->
Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
Lwt.return (Error `Exception)
| e ->
Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ;
Lwt.return (Error `Exception))
let extract_policies version chain =
List.fold_left (fun acc cert ->
match acc, wire_command_of_cert version cert with
| Error e, _ -> Error e
| Ok acc, Error `Not_present -> Ok acc
| Ok _, Error (`Parse msg) -> Error (`Msg msg)
| Ok _, Error (`Version received) ->
R.error_msgf "unexpected version %a (expected %a)"
Vmm_commands.pp_version received
Vmm_commands.pp_version version
| Ok (prefix, acc), Ok (`Policy_cmd (`Policy_add p)) ->
(cert_name cert >>| function
| None -> prefix
| Some x -> x :: prefix) >>| fun name ->
(name, (name, p) :: acc)
| _, Ok wire ->
R.error_msgf "unexpected wire %a" Vmm_commands.pp wire)
(Ok ([], [])) chain
let handle _addr version chain =
separate_chain chain >>= fun (leaf, rest) ->
name chain >>= fun name ->
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 rest)) ;
extract_policies version rest >>= fun (_, policies) ->
(* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
match wire_command_of_cert version leaf with
| Error (`Parse p) -> Error (`Msg p)
| Error (`Not_present) ->
Error (`Msg "leaf certificate does not contain an albatross extension")
| Error (`Version received) ->
R.error_msgf "unexpected version %a (expected %a)"
Vmm_commands.pp_version received
Vmm_commands.pp_version version
| Ok wire ->
(* we only allow some commands via certificate *)
match wire with
| `Console_cmd (`Console_subscribe _)
| `Stats_cmd `Stats_subscribe
| `Log_cmd (`Log_subscribe _)
| `Vm_cmd _
| `Policy_cmd `Policy_info -> Ok (name, policies, wire)
| _ -> Error (`Msg "unexpected command")

10
src/vmm_tls.mli Normal file
View file

@ -0,0 +1,10 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
val wire_command_of_cert : Vmm_commands.version -> X509.t ->
(Vmm_commands.t, [> `Parse of string | `Not_present | `Version of Vmm_commands.version ]) result
val handle :
'a -> Vmm_commands.version ->
X509.t list ->
(Vmm_core.id * (Vmm_core.id * Vmm_core.policy) list * Vmm_commands.t,
[> `Msg of string ]) Result.result

69
src/vmm_tls_lwt.ml Normal file
View file

@ -0,0 +1,69 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let read_tls t =
let rec r_n buf off tot =
let l = tot - off in
if l = 0 then
Lwt.return (Ok ())
else
Lwt.catch (fun () ->
Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function
| 0 ->
Logs.err (fun m -> m "TLS: end of file") ;
Lwt.return (Error `Eof)
| x when x == l -> Lwt.return (Ok ())
| x when x < l -> r_n buf (off + x) tot
| _ ->
Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ;
Lwt.return (Error `Toomuch))
(function
| Tls_lwt.Tls_failure a ->
Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ;
Lwt.return (Error `Exception)
| e ->
Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ;
Lwt.return (Error `Exception))
in
let buf = Cstruct.create 4 in
r_n buf 0 4 >>= function
| Error e -> Lwt.return (Error e)
| Ok () ->
let len = Cstruct.BE.get_uint32 buf 0 in
if len > 0l then
let b = Cstruct.create (Int32.to_int len) in
r_n b 0 (Int32.to_int len) >|= function
| Error e -> Error e
| Ok () ->
(* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a"
hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag
Cstruct.hexdump_pp b) ; *)
match Vmm_asn.wire_of_cstruct b with
| Ok w -> Ok w
| Error (`Msg msg) ->
Logs.err (fun m -> m "error %s while parsing data" msg) ;
Error `Exception
else
Lwt.return (Error `Eof)
let write_tls s wire =
let data = Vmm_asn.wire_to_cstruct wire in
let dlen = Cstruct.create 4 in
Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ;
let buf = Cstruct.(append dlen data) in
(* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *)
Lwt.catch
(fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ())
(function
| Tls_lwt.Tls_failure a ->
Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
Lwt.return (Error `Exception)
| e ->
Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ;
Lwt.return (Error `Exception))
let close tls =
Lwt.catch
(fun () -> Tls_lwt.Unix.close tls)
(fun _ -> Lwt.return_unit)

9
src/vmm_tls_lwt.mli Normal file
View file

@ -0,0 +1,9 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
val read_tls : Tls_lwt.Unix.t ->
(Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t
val write_tls :
Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t
val close : Tls_lwt.Unix.t -> unit Lwt.t

99
src/vmm_trie.ml Normal file
View file

@ -0,0 +1,99 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Astring
type 'a t = N of 'a option * 'a t String.Map.t
let empty = N (None, String.Map.empty)
let insert id e t =
let rec go (N (es, m)) = function
| [] ->
begin match es with
| None -> N (Some e, m), None
| Some es' -> N (Some e, m), Some es'
end
| x::xs ->
let n = match String.Map.find_opt x m with
| None -> empty
| Some n -> n
in
let entry, ret = go n xs in
N (es, String.Map.add x entry m), ret
in
go t id
let remove id t =
let rec go (N (es, m)) = function
| [] -> if String.Map.is_empty m then None else Some (N (None, m))
| x::xs ->
let n' = match String.Map.find_opt x m with
| None -> None
| Some n -> go n xs
in
let m' = match n' with
| None -> String.Map.remove x m
| Some entry -> String.Map.add x entry m
in
if String.Map.is_empty m' && es = None then None else Some (N (es, m'))
in
match go t id with
| None -> empty
| Some n -> n
let find id t =
let rec go (N (es, m)) = function
| [] -> es
| x::xs ->
match String.Map.find_opt x m with
| None -> None
| Some n -> go n xs
in
go t id
let collect id t =
let rec go acc prefix (N (es, m)) =
let acc' =
match es with
| None -> acc
| Some e -> (prefix, e) :: acc
in
function
| [] -> acc'
| x::xs ->
match String.Map.find_opt x m with
| None -> acc'
| Some n -> go acc' (prefix @ [ x ]) n xs
in
go [] [] t id
let all t =
let rec go acc prefix (N (es, m)) =
let acc' =
match es with
| None -> acc
| Some e -> (prefix, e) :: acc
in
List.fold_left (fun acc (name, node) ->
go acc (prefix@[name]) node)
acc' (String.Map.bindings m)
in
go [] [] t
let fold id t f acc =
let rec explore (N (es, m)) prefix acc =
let acc' =
String.Map.fold (fun name node acc -> explore node (prefix@[name]) acc)
m acc
in
match es with
| None -> acc'
| Some e -> f prefix e acc'
and down prefix (N (es, m)) =
match prefix with
| [] -> explore (N (es, m)) [] acc
| x :: xs -> match String.Map.find_opt x m with
| None -> acc
| Some n -> down xs n
in
down id t

19
src/vmm_trie.mli Normal file
View file

@ -0,0 +1,19 @@
(* (c) 2018 Hannes Mehnert, all rights reserved *)
open Vmm_core
type 'a t
val empty : 'a t
val insert : id -> 'a -> 'a t -> 'a t * 'a option
val remove : id -> 'a t -> 'a t
val find : id -> 'a t -> 'a option
val collect : id -> 'a t -> (id * 'a) list
val all : 'a t -> (id * 'a) list
val fold : id -> 'a t -> (id -> 'a -> 'b -> 'b) -> 'b -> 'b

180
src/vmm_unix.ml Normal file
View file

@ -0,0 +1,180 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Rresult
(* bits copied over from Bos *)
(*---------------------------------------------------------------------------
Copyright (c) 2014 Daniel C. Bünzli
Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
---------------------------------------------------------------------------*)
let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e)
let err_empty_line = "no command, empty command line"
let err_file f e = R.error_msgf "%a: %a" Fpath.pp f pp_unix_error e
let rec openfile fn mode perm = try Unix.openfile fn mode perm with
| Unix.Unix_error (Unix.EINTR, _, _) -> openfile fn mode perm
let fd_for_file flag f =
try Ok (openfile (Fpath.to_string f) (Unix.O_CLOEXEC :: flag) 0o644)
with Unix.Unix_error (e, _, _) -> err_file f e
let read_fd_for_file = fd_for_file Unix.[ O_RDONLY ]
let write_fd_for_file = fd_for_file Unix.[ O_WRONLY ; O_APPEND ]
let null = match read_fd_for_file (Fpath.v "/dev/null") with
| Ok fd -> fd
| Error _ -> invalid_arg "cannot read /dev/null"
let rec create_process prog args stdout stderr =
try Unix.create_process prog args null stdout stderr with
| Unix.Unix_error (Unix.EINTR, _, _) ->
create_process prog args stdout stderr
let rec close fd =
try Unix.close fd with
| Unix.Unix_error (Unix.EINTR, _, _) -> close fd
let close_no_err fd = try close fd with _ -> ()
(* own code starts here
(c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Vmm_core
let rec mkfifo name =
try Unix.mkfifo (Fpath.to_string name) 0o640 with
| Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name
let image_file, fifo_file =
((fun name -> Fpath.(tmpdir / (string_of_id name) + "img")),
(fun name -> Fpath.(tmpdir / "fifo" / (string_of_id name))))
let rec fifo_exists file =
try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with
| Unix.Unix_error (Unix.ENOENT, _, _) -> Error (`Msg "noent")
| Unix.Unix_error (Unix.EINTR, _, _) -> fifo_exists file
| Unix.Unix_error (e, _, _) ->
R.error_msgf "file %a exists: %s" Fpath.pp file (Unix.error_message e)
let uname () =
let cmd = Bos.Cmd.(v "uname" % "-s") in
lazy Bos.OS.Cmd.(run_out cmd |> out_string)
let create_tap bridge =
Lazy.force (uname ()) >>= fun (sys, _) ->
match sys with
| x when x = "FreeBSD" ->
let cmd = Bos.Cmd.(v "ifconfig" % "tap" % "create") in
Bos.OS.Cmd.run_out cmd |> Bos.OS.Cmd.out_string >>= fun (name, _) ->
Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % bridge % "addm" % name) >>= fun () ->
Ok name
| x when x = "Linux" ->
let prefix = "vmmtap" in
let rec find_n x =
let nam = prefix ^ string_of_int x in
match Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % nam) with
| Error _ -> nam
| Ok _ -> find_n (succ x)
in
let tap = find_n 0 in
Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "add" % "mode" % "tap" % tap) >>= fun () ->
Bos.OS.Cmd.run Bos.Cmd.(v "brctl" % "addif" % bridge % tap) >>= fun () ->
Ok tap
| x -> Error (`Msg ("unsupported operating system " ^ x))
let destroy_tap tapname =
Lazy.force (uname ()) >>= fun (sys, _) ->
match sys with
| x when x = "FreeBSD" ->
Bos.OS.Cmd.run Bos.Cmd.(v "ifconfig" % tapname % "destroy")
| x when x = "Linux" ->
Bos.OS.Cmd.run Bos.Cmd.(v "ip" % "tuntap" % "del" % "dev" % tapname % "mode" % "tap")
| x -> Error (`Msg ("unsupported operating system " ^ x))
let prepare name vm =
(match vm.vmimage with
| `Hvt_amd64, blob -> Ok blob
| `Hvt_amd64_compressed, blob ->
begin match Vmm_compress.uncompress (Cstruct.to_string blob) with
| Ok blob -> Ok (Cstruct.of_string blob)
| Error () -> Error (`Msg "failed to uncompress")
end
| `Hvt_arm64, _ -> Error (`Msg "no amd64 hvt image found")) >>= fun image ->
let fifo = fifo_file name in
(match fifo_exists fifo with
| Ok true -> Ok ()
| Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo"))
| Error _ ->
try Ok (mkfifo fifo) with
| Unix.Unix_error (e, f, _) ->
Logs.err (fun m -> m "%a error in %s: %a" Fpath.pp fifo f pp_unix_error e) ;
Error (`Msg "while creating fifo")) >>= fun () ->
List.fold_left (fun acc b ->
acc >>= fun acc ->
create_tap b >>= fun tap ->
Ok (tap :: acc))
(Ok []) vm.network >>= fun taps ->
Bos.OS.File.write (image_file name) (Cstruct.to_string image) >>= fun () ->
Ok (List.rev taps)
let shutdown name vm =
(* same order as prepare! *)
Bos.OS.File.delete (image_file name) >>= fun () ->
Bos.OS.File.delete (fifo_file name) >>= fun () ->
List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps
let cpuset cpu =
Lazy.force (uname ()) >>= fun (sys, _) ->
let cpustring = string_of_int cpu in
match sys with
| x when x = "FreeBSD" ->
Ok ([ "cpuset" ; "-l" ; cpustring ])
| x when x = "Linux" ->
Ok ([ "taskset" ; "-c" ; cpustring ])
| x -> Error (`Msg ("unsupported operating system " ^ x))
let exec name vm taps =
let net = List.map (fun t -> "--net=" ^ t) taps in
let argv = match vm.argv with None -> [] | Some xs -> xs in
(match taps with
| [] -> Ok Fpath.(dbdir / "solo5-hvt.none")
| [_] -> Ok Fpath.(dbdir / "solo5-hvt.net")
| _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin ->
cpuset vm.cpuid >>= fun cpuset ->
let mem = "--mem=" ^ string_of_int vm.requested_memory in
let cmd =
Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net %
"--" % p (image_file name) %% of_list argv)
in
let line = Bos.Cmd.to_list cmd in
let prog = try List.hd line with Failure _ -> failwith err_empty_line in
let line = Array.of_list line in
let fifo = fifo_file name in
Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo);
write_fd_for_file fifo >>= fun stdout ->
Logs.debug (fun m -> m "opened file descriptor!");
try
Logs.debug (fun m -> m "creating process");
let pid = create_process prog line stdout stdout in
Logs.debug (fun m -> m "created process %d: %a" pid Bos.Cmd.pp cmd) ;
(* this should get rid of the vmimage from vmmd's memory! *)
let config = { vm with vmimage = (fst vm.vmimage, Cstruct.create 0) } in
Ok { config ; cmd ; pid ; taps ; stdout }
with
Unix.Unix_error (e, _, _) ->
close_no_err stdout;
R.error_msgf "cmd %a exits: %a" Bos.Cmd.pp cmd pp_unix_error e
let destroy vm = Unix.kill vm.pid 15 (* 15 is SIGTERM *)

15
src/vmm_unix.mli Normal file
View file

@ -0,0 +1,15 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Rresult
open Vmm_core
val prepare : id -> vm_config -> (string list, [> R.msg ]) result
val shutdown : id -> vm -> (unit, [> R.msg ]) result
val exec : id -> vm_config -> string list -> (vm, [> R.msg ]) result
val destroy : vm -> unit
val close_no_err : Unix.file_descr -> unit

200
src/vmm_vmmd.ml Normal file
View file

@ -0,0 +1,200 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Astring
open Vmm_core
open Rresult
open R.Infix
type 'a t = {
wire_version : Vmm_commands.version ;
console_counter : int64 ;
stats_counter : int64 ;
log_counter : int64 ;
resources : Vmm_resources.t ;
tasks : 'a String.Map.t ;
}
let init wire_version = {
wire_version ;
console_counter = 1L ;
stats_counter = 1L ;
log_counter = 1L ;
resources = Vmm_resources.empty ;
tasks = String.Map.empty ;
}
type service_out = [
| `Stat of Vmm_commands.wire
| `Log of Vmm_commands.wire
| `Cons of Vmm_commands.wire
]
type out = [ service_out | `Data of Vmm_commands.wire ]
let log t id event =
let data = (Ptime_clock.now (), event) in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; id } in
let log_counter = Int64.succ t.log_counter in
Logs.debug (fun m -> m "log %a" Log.pp data) ;
({ t with log_counter }, `Log (header, `Data (`Log_data data)))
let handle_create t hdr vm_config =
let name = hdr.Vmm_commands.id in
(match Vmm_resources.find_vm t.resources name with
| Some _ -> Error (`Msg "VM with same name is already running")
| None -> Ok ()) >>= fun () ->
Logs.debug (fun m -> m "now checking resource policies") ;
(if Vmm_resources.check_vm_policy t.resources name vm_config then
Ok ()
else
Error (`Msg "resource policies don't allow this")) >>= fun () ->
(* prepare VM: save VM image to disk, create fifo, ... *)
Vmm_unix.prepare name vm_config >>= fun taps ->
Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ;
let cons_out =
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in
(header, `Command (`Console_cmd `Console_add))
in
Ok ({ t with console_counter = Int64.succ t.console_counter },
[ `Cons cons_out ],
`Create (fun t task ->
(* actually execute the vm *)
Vmm_unix.exec name vm_config taps >>= fun vm ->
Logs.debug (fun m -> m "exec()ed vm") ;
Vmm_resources.insert_vm t.resources name vm >>= fun resources ->
let tasks = String.Map.add (string_of_id name) task t.tasks in
let t = { t with resources ; tasks } in
let t, out = log t name (`Vm_start (name, vm.pid, vm.taps, None)) in
let data = `Success (`String "created VM") in
Ok (t, [ `Data (hdr, data) ; out ], name, vm)))
let setup_stats t name vm =
let stat_out = `Stats_add (vm.pid, vm.taps) in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
let t = { t with stats_counter = Int64.succ t.stats_counter } in
t, `Stat (header, `Command (`Stats_cmd stat_out))
let handle_shutdown t name vm r =
(match Vmm_unix.shutdown name vm with
| Ok () -> ()
| Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ;
let resources = match Vmm_resources.remove_vm t.resources name with
| Error (`Msg e) ->
Logs.warn (fun m -> m "%s while removing vm %a from resources" e pp_vm vm) ;
t.resources
| Ok resources -> resources
in
let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in
let tasks = String.Map.remove (string_of_id name) t.tasks in
let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in
let t, logout = log t name (`Vm_stop (name, vm.pid, r))
in
(t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ])
let handle_command t (header, payload) =
let msg_to_err = function
| Ok x -> x
| Error (`Msg msg) ->
Logs.debug (fun m -> m "error while processing command: %s" msg) ;
(t, [ `Data (header, `Failure msg) ], `End)
in
let reply x = `Data (header, `Success x) in
msg_to_err (
let id = header.Vmm_commands.id in
match payload with
| `Command (`Policy_cmd pc) ->
begin match pc with
| `Policy_remove ->
Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ;
Vmm_resources.remove_policy t.resources id >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "removed policy") ], `End)
| `Policy_add policy ->
Logs.debug (fun m -> m "insert policy %a" pp_id id) ;
let same_policy = match Vmm_resources.find_policy t.resources id with
| None -> false
| Some p' -> eq_policy policy p'
in
if same_policy then
Ok (t, [ reply (`String "no modification of policy") ], `End)
else
Vmm_resources.insert_policy t.resources id policy >>= fun resources ->
Ok ({ t with resources }, [ reply (`String "added policy") ], `End)
| `Policy_info ->
begin
Logs.debug (fun m -> m "policy %a" pp_id id) ;
let policies =
Vmm_resources.fold t.resources id
(fun _ _ policies -> policies)
(fun prefix policy policies-> (prefix, policy) :: policies)
[]
in
match policies with
| [] ->
Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ;
Error (`Msg "policy: not found")
| _ ->
Ok (t, [ reply (`Policies policies) ], `End)
end
end
| `Command (`Vm_cmd vc) ->
begin match vc with
| `Vm_info ->
Logs.debug (fun m -> m "info %a" pp_id id) ;
let vms =
Vmm_resources.fold t.resources id
(fun id vm vms -> (id, vm.config) :: vms)
(fun _ _ vms-> vms)
[]
in
begin match vms with
| [] ->
Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ;
Error (`Msg "info: not found")
| _ ->
Ok (t, [ reply (`Vms vms) ], `End)
end
| `Vm_create vm_config ->
handle_create t header vm_config
| `Vm_force_create vm_config ->
let resources =
match Vmm_resources.remove_vm t.resources id with
| Error _ -> t.resources
| Ok r -> r
in
if Vmm_resources.check_vm_policy resources id vm_config then
begin match Vmm_resources.find_vm t.resources id with
| None -> handle_create t header vm_config
| Some vm ->
Vmm_unix.destroy vm ;
let id_str = string_of_id id in
match String.Map.find_opt id_str t.tasks with
| None -> handle_create t header vm_config
| Some task ->
let tasks = String.Map.remove id_str t.tasks in
let t = { t with tasks } in
Ok (t, [], `Wait_and_create
(task, fun t -> msg_to_err @@ handle_create t header vm_config))
end
else
Error (`Msg "wouldn't match policy")
| `Vm_destroy ->
begin match Vmm_resources.find_vm t.resources id with
| Some vm ->
Vmm_unix.destroy vm ;
let id_str = string_of_id id in
let out, next =
let s = reply (`String "destroyed vm") in
match String.Map.find_opt id_str t.tasks with
| None -> [ s ], `End
| Some t -> [], `Wait (t, s)
in
let tasks = String.Map.remove id_str t.tasks in
Ok ({ t with tasks }, out, next)
| None -> Error (`Msg "destroy: not found")
end
end
| _ ->
Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ;
Error (`Msg "unknown command"))

27
src/vmm_vmmd.mli Normal file
View file

@ -0,0 +1,27 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
type 'a t
val init : Vmm_commands.version -> 'a t
type service_out = [
| `Stat of Vmm_commands.wire
| `Log of Vmm_commands.wire
| `Cons of Vmm_commands.wire
]
type out = [ service_out | `Data of Vmm_commands.wire ]
val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm ->
[ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list
val handle_command : 'a t -> Vmm_commands.wire ->
'a t * out list *
[ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> `Msg of string ]) result
| `End
| `Wait of 'a * out
| `Wait_and_create of 'a * ('a t -> 'a t * out list *
[ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result
| `End ]) ]
val setup_stats : 'a t -> Vmm_core.id -> Vmm_core.vm -> 'a t * out

View file

@ -1,697 +0,0 @@
(* (c) 2017 Hannes Mehnert, all rights reserved *)
(* the wire protocol - length prepended binary data *)
(* each message (on all channels) is prefixed by a common header:
- length (16 bit) spanning the message (excluding the 8 bytes header)
- id (16 bit) unique id chosen by sender (for request/reply) - 0 shouldn't be used (reserved for log/console messages which do not correspond to a request)
- version (16 bit) the version used on this channel
- tag (16 bit) the type of message
Version and tag are protocol-specific - the channel between vmm and console
uses different tags and mayuse a different version than between vmm and
client. *)
open Astring
open Vmm_core
type version = [ `WV0 | `WV1 ]
let version_to_int = function
| `WV0 -> 0
| `WV1 -> 1
let version_of_int = function
| 0 -> Ok `WV0
| 1 -> Ok `WV1
| _ -> Error (`Msg "unknown wire version")
let version_eq a b = match a, b with
| `WV0, `WV0 -> true
| `WV1, `WV1 -> true
| _ -> false
let pp_version ppf v =
Fmt.string ppf (match v with
| `WV0 -> "wire version 0"
| `WV1 -> "wire version 1")
type header = {
length : int ;
id : int ;
version : version ;
tag : int ;
}
open Rresult
open R.Infix
let check_len cs l =
if Cstruct.len cs < l then
Error (`Msg "underflow")
else
Ok ()
let check_exact cs l =
if Cstruct.len cs = l then
Ok ()
else
Error (`Msg "bad length")
let empty = Cstruct.create 0
let null cs = if Cstruct.len cs = 0 then Ok () else Error (`Msg "trailing bytes")
let parse_header buf =
let cs = Cstruct.of_string buf in
check_len cs 8 >>= fun () ->
let length = Cstruct.BE.get_uint16 cs 0
and id = Cstruct.BE.get_uint16 cs 2
and version = Cstruct.BE.get_uint16 cs 4
and tag = Cstruct.BE.get_uint16 cs 6
in
version_of_int version >>= fun version ->
Ok { length ; id ; version ; tag }
let create_header { length ; id ; version ; tag } =
let hdr = Cstruct.create 8 in
Cstruct.BE.set_uint16 hdr 0 length ;
Cstruct.BE.set_uint16 hdr 2 id ;
Cstruct.BE.set_uint16 hdr 4 (version_to_int version) ;
Cstruct.BE.set_uint16 hdr 6 tag ;
hdr
let decode_string cs =
check_len cs 2 >>= fun () ->
let l = Cstruct.BE.get_uint16 cs 0 in
check_len cs (2 + l) >>= fun () ->
let str = Cstruct.(to_string (sub cs 2 l)) in
Ok (str, l + 2)
(* external use only *)
let decode_str str =
if String.length str = 0 then
Ok ("", 0)
else
decode_string (Cstruct.of_string str)
let decode_strings cs =
let rec go acc buf =
if Cstruct.len buf = 0 then
Ok (List.rev acc)
else
decode_string buf >>= fun (x, l) ->
go (x :: acc) (Cstruct.shift buf l)
in
go [] cs
let encode_string str =
let l = String.length str in
let cs = Cstruct.create (2 + l) in
Cstruct.BE.set_uint16 cs 0 l ;
Cstruct.blit_from_string str 0 cs 2 l ;
cs, 2 + l
let encode_strings xs =
Cstruct.concat
(List.map (fun s -> fst (encode_string s)) xs)
let max = Int64.of_int max_int
let min = Int64.of_int min_int
let decode_int ?(off = 0) cs =
let i = Cstruct.BE.get_uint64 cs off in
if i > max then
Error (`Msg "int too big")
else if i < min then
Error (`Msg "int too small")
else
Ok (Int64.to_int i)
let encode_int i =
let cs = Cstruct.create 8 in
Cstruct.BE.set_uint64 cs 0 (Int64.of_int i) ;
cs
(* TODO: 32 bit system clean *)
let decode_pid cs =
check_len cs 4 >>= fun () ->
let pid = Cstruct.BE.get_uint32 cs 0 in
Ok (Int32.to_int pid)
(* TODO: can we do sth more appropriate than raise? *)
let encode_pid pid =
let cs = Cstruct.create 4 in
if Int32.to_int Int32.max_int > pid &&
Int32.to_int Int32.min_int < pid
then begin
Cstruct.BE.set_uint32 cs 0 (Int32.of_int pid) ;
cs
end else
invalid_arg "pid too big"
let decode_ptime cs =
check_len cs 16 >>= fun () ->
decode_int cs >>= fun d ->
let ps = Cstruct.BE.get_uint64 cs 8 in
Ok (Ptime.v (d, ps))
(* EXPORT only *)
let decode_ts ?(off = 0) buf =
let cs = Cstruct.of_string buf in
let cs = Cstruct.shift cs off in
decode_ptime cs
let encode_ptime ts =
let d, ps = Ptime.(Span.to_d_ps (to_span ts)) in
let cs = Cstruct.create 16 in
Cstruct.BE.set_uint64 cs 0 (Int64.of_int d) ;
Cstruct.BE.set_uint64 cs 8 ps ;
cs
let fail_tag = 0xFFFE
let success_tag = 0xFFFF
let may_enc_str = function
| None -> empty, 0
| Some msg -> encode_string msg
let success ?msg id version =
let data, length = may_enc_str msg in
let r =
Cstruct.append
(create_header { length ; id ; version ; tag = success_tag }) data
in
Cstruct.to_string r
let fail ?msg id version =
let data, length = may_enc_str msg in
let r =
Cstruct.append
(create_header { length ; id ; version ; tag = fail_tag }) data
in
Cstruct.to_string r
module Console = struct
[%%cenum
type op =
| Add_console
| Attach_console
| Detach_console
| History
| Data
[@@uint16_t]
]
let encode id version op ?payload nam =
let data, l = encode_string nam in
let length, p =
match payload with
| None -> l, empty
| Some x -> l + Cstruct.len x, x
and tag = op_to_int op
in
let r =
Cstruct.concat
[ (create_header { length ; id ; version ; tag }) ; data ; p ]
in
Cstruct.to_string r
let data ?(id = 0) v file ts msg =
let payload =
let ts = encode_ptime ts
and data, _ = encode_string msg
in
Cstruct.append ts data
in
encode id v Data ~payload file
let add id v name = encode id v Add_console name
let attach id v name = encode id v Attach_console name
let detach id v name = encode id v Detach_console name
let history id v name since =
let payload = encode_ptime since in
encode id v History ~payload name
end
module Stats = struct
[%%cenum
type op =
| Add
| Remove
| Stat_request
| Stat_reply
[@@uint16_t]
]
let encode id version op ?payload nam =
let data, l = encode_string nam in
let length, p =
match payload with
| None -> l, empty
| Some x -> l + Cstruct.len x, x
and tag = op_to_int op
in
let r =
Cstruct.concat [ create_header { length ; version ; id ; tag } ; data ; p ]
in
Cstruct.to_string r
let encode_rusage ru =
let cs = Cstruct.create (18 * 8) in
Cstruct.BE.set_uint64 cs 0 (fst ru.utime) ;
Cstruct.BE.set_uint64 cs 8 (Int64.of_int (snd ru.utime)) ;
Cstruct.BE.set_uint64 cs 16 (fst ru.stime) ;
Cstruct.BE.set_uint64 cs 24 (Int64.of_int (snd ru.stime)) ;
Cstruct.BE.set_uint64 cs 32 ru.maxrss ;
Cstruct.BE.set_uint64 cs 40 ru.ixrss ;
Cstruct.BE.set_uint64 cs 48 ru.idrss ;
Cstruct.BE.set_uint64 cs 56 ru.isrss ;
Cstruct.BE.set_uint64 cs 64 ru.minflt ;
Cstruct.BE.set_uint64 cs 72 ru.majflt ;
Cstruct.BE.set_uint64 cs 80 ru.nswap ;
Cstruct.BE.set_uint64 cs 88 ru.inblock ;
Cstruct.BE.set_uint64 cs 96 ru.outblock ;
Cstruct.BE.set_uint64 cs 104 ru.msgsnd ;
Cstruct.BE.set_uint64 cs 112 ru.msgrcv ;
Cstruct.BE.set_uint64 cs 120 ru.nsignals ;
Cstruct.BE.set_uint64 cs 128 ru.nvcsw ;
Cstruct.BE.set_uint64 cs 136 ru.nivcsw ;
cs
let decode_rusage cs =
check_exact cs 144 >>= fun () ->
(decode_int ~off:8 cs >>= fun ms ->
Ok (Cstruct.BE.get_uint64 cs 0, ms)) >>= fun utime ->
(decode_int ~off:24 cs >>= fun ms ->
Ok (Cstruct.BE.get_uint64 cs 16, ms)) >>= fun stime ->
let maxrss = Cstruct.BE.get_uint64 cs 32
and ixrss = Cstruct.BE.get_uint64 cs 40
and idrss = Cstruct.BE.get_uint64 cs 48
and isrss = Cstruct.BE.get_uint64 cs 56
and minflt = Cstruct.BE.get_uint64 cs 64
and majflt = Cstruct.BE.get_uint64 cs 72
and nswap = Cstruct.BE.get_uint64 cs 80
and inblock = Cstruct.BE.get_uint64 cs 88
and outblock = Cstruct.BE.get_uint64 cs 96
and msgsnd = Cstruct.BE.get_uint64 cs 104
and msgrcv = Cstruct.BE.get_uint64 cs 112
and nsignals = Cstruct.BE.get_uint64 cs 120
and nvcsw = Cstruct.BE.get_uint64 cs 128
and nivcsw = Cstruct.BE.get_uint64 cs 136
in
Ok { utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ;
nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw }
let encode_ifdata i =
let name, _ = encode_string i.name in
let cs = Cstruct.create (12 * 8 + 5 * 4) in
Cstruct.BE.set_uint32 cs 0 i.flags ;
Cstruct.BE.set_uint32 cs 4 i.send_length ;
Cstruct.BE.set_uint32 cs 8 i.max_send_length ;
Cstruct.BE.set_uint32 cs 12 i.send_drops ;
Cstruct.BE.set_uint32 cs 16 i.mtu ;
Cstruct.BE.set_uint64 cs 20 i.baudrate ;
Cstruct.BE.set_uint64 cs 28 i.input_packets ;
Cstruct.BE.set_uint64 cs 36 i.input_errors ;
Cstruct.BE.set_uint64 cs 44 i.output_packets ;
Cstruct.BE.set_uint64 cs 52 i.output_errors ;
Cstruct.BE.set_uint64 cs 60 i.collisions ;
Cstruct.BE.set_uint64 cs 68 i.input_bytes ;
Cstruct.BE.set_uint64 cs 76 i.output_bytes ;
Cstruct.BE.set_uint64 cs 84 i.input_mcast ;
Cstruct.BE.set_uint64 cs 92 i.output_mcast ;
Cstruct.BE.set_uint64 cs 100 i.input_dropped ;
Cstruct.BE.set_uint64 cs 108 i.output_dropped ;
Cstruct.append name cs
let decode_ifdata buf =
decode_string buf >>= fun (name, l) ->
check_len buf (l + 116) >>= fun () ->
let cs = Cstruct.shift buf l in
let flags = Cstruct.BE.get_uint32 cs 0
and send_length = Cstruct.BE.get_uint32 cs 4
and max_send_length = Cstruct.BE.get_uint32 cs 8
and send_drops = Cstruct.BE.get_uint32 cs 12
and mtu = Cstruct.BE.get_uint32 cs 16
and baudrate = Cstruct.BE.get_uint64 cs 20
and input_packets = Cstruct.BE.get_uint64 cs 28
and input_errors = Cstruct.BE.get_uint64 cs 36
and output_packets = Cstruct.BE.get_uint64 cs 44
and output_errors = Cstruct.BE.get_uint64 cs 52
and collisions = Cstruct.BE.get_uint64 cs 60
and input_bytes = Cstruct.BE.get_uint64 cs 68
and output_bytes = Cstruct.BE.get_uint64 cs 76
and input_mcast = Cstruct.BE.get_uint64 cs 84
and output_mcast = Cstruct.BE.get_uint64 cs 92
and input_dropped = Cstruct.BE.get_uint64 cs 100
and output_dropped = Cstruct.BE.get_uint64 cs 108
in
Ok ({ name ; flags ; send_length ; max_send_length ; send_drops ; mtu ;
baudrate ; input_packets ; input_errors ; output_packets ;
output_errors ; collisions ; input_bytes ; output_bytes ; input_mcast ;
output_mcast ; input_dropped ; output_dropped },
l + 116)
let add id v nam pid taps =
let payload = Cstruct.append (encode_pid pid) (encode_strings taps) in
encode id v Add ~payload nam
let remove id v nam = encode id v Remove nam
let stat id v nam = encode id v Stat_request nam
let stat_reply id version payload =
let length = Cstruct.len payload
and tag = op_to_int Stat_reply
in
let r =
Cstruct.append (create_header { length ; id ; version ; tag }) payload
in
Cstruct.to_string r
let encode_int64 i =
let cs = Cstruct.create 8 in
Cstruct.BE.set_uint64 cs 0 i ;
cs
let decode_int64 ?(off = 0) cs =
check_len cs (8 + off) >>= fun () ->
Ok (Cstruct.BE.get_uint64 cs off)
let encode_vmm_stats xs =
encode_int (List.length xs) ::
List.flatten
(List.map (fun (k, v) -> [ fst (encode_string k) ; encode_int64 v ]) xs)
let decode_vmm_stats cs =
let rec go acc ctr buf =
if ctr = 0 then
Ok (List.rev acc, buf)
else
decode_string buf >>= fun (str, off) ->
decode_int64 ~off buf >>= fun v ->
go ((str, v) :: acc) (pred ctr) (Cstruct.shift buf (off + 8))
in
decode_int cs >>= fun stat_num ->
go [] stat_num (Cstruct.shift cs 8)
let encode_stats (ru, vmm, ifd) =
Cstruct.concat
(encode_rusage ru ::
encode_vmm_stats vmm @
encode_int (List.length ifd) :: List.map encode_ifdata ifd)
let decode_stats cs =
check_len cs 144 >>= fun () ->
let ru, rest = Cstruct.split cs 144 in
decode_rusage ru >>= fun ru ->
decode_vmm_stats rest >>= fun (vmm, rest) ->
let rec go acc ctr buf =
if ctr = 0 then
Ok (List.rev acc, buf)
else
decode_ifdata buf >>= fun (this, used) ->
go (this :: acc) (pred ctr) (Cstruct.shift buf used)
in
decode_int rest >>= fun num_if ->
go [] num_if (Cstruct.shift rest 8) >>= fun (ifs, _rest) ->
Ok (ru, vmm, ifs)
let decode_pid_taps data =
decode_pid data >>= fun pid ->
decode_strings (Cstruct.shift data 4) >>= fun taps ->
Ok (pid, taps)
end
module Log = struct
[%%cenum
type op =
| Data
| History
[@@uint16_t]
]
let history id version ctx ts =
let tag = op_to_int History in
let nam, _ = encode_string ctx in
let payload = Cstruct.append nam (encode_ptime ts) in
let length = Cstruct.len payload in
let r =
Cstruct.append (create_header { length ; version ; id ; tag }) payload
in
Cstruct.to_string r
let encode_log_hdr ?(drop_context = false) hdr =
let ts = encode_ptime hdr.Log.ts
and ctx, _ = encode_string (if drop_context then "" else (string_of_id hdr.Log.context))
and name, _ = encode_string hdr.Log.name
in
Cstruct.concat [ ts ; ctx ; name ]
let decode_log_hdr cs =
decode_ptime cs >>= fun ts ->
let r = Cstruct.shift cs 16 in
decode_string r >>= fun (ctx, l) ->
let context = id_of_string ctx in
let r = Cstruct.shift r l in
decode_string r >>= fun (name, l) ->
Ok ({ Log.ts ; context ; name }, Cstruct.shift r l)
let encode_addr ip port =
let cs = Cstruct.create 6 in
Cstruct.BE.set_uint32 cs 0 (Ipaddr.V4.to_int32 ip) ;
Cstruct.BE.set_uint16 cs 4 port ;
cs
let decode_addr cs =
check_len cs 6 >>= fun () ->
let ip = Ipaddr.V4.of_int32 (Cstruct.BE.get_uint32 cs 0)
and port = Cstruct.BE.get_uint16 cs 4
in
Ok (ip, port)
let encode_vm (pid, taps, block) =
let cs = encode_pid pid in
let bl, _ = encode_string (match block with None -> "" | Some x -> x) in
let taps = encode_strings taps in
Cstruct.concat [ cs ; bl ; taps ]
let decode_vm cs =
decode_pid cs >>= fun pid ->
let r = Cstruct.shift cs 4 in
decode_string r >>= fun (block, l) ->
let block = if block = "" then None else Some block in
decode_strings (Cstruct.shift r l) >>= fun taps ->
Ok (pid, taps, block)
let encode_pid_exit pid c =
let r, c = match c with
| `Exit n -> 0, n
| `Signal n -> 1, n
| `Stop n -> 2, n
in
let cs = Cstruct.create 1 in
Cstruct.set_uint8 cs 0 r ;
let pid = encode_pid pid
and code = encode_int c
in
Cstruct.concat [ pid ; cs ; code ]
let decode_pid_exit cs =
check_len cs 13 >>= fun () ->
decode_pid cs >>= fun pid ->
let r = Cstruct.get_uint8 cs 4 in
let code = Cstruct.shift cs 5 in
decode_int code >>= fun c ->
(match r with
| 0 -> Ok (`Exit c)
| 1 -> Ok (`Signal c)
| 2 -> Ok (`Stop c)
| _ -> Error (`Msg "couldn't parse exit status")) >>= fun r ->
Ok (pid, r)
let encode_block nam siz =
Cstruct.append (fst (encode_string nam)) (encode_int siz)
let decode_block cs =
decode_string cs >>= fun (nam, l) ->
check_len cs (l + 8) >>= fun () ->
decode_int ~off:l cs >>= fun siz ->
Ok (nam, siz)
let encode_delegate bridges bs =
Cstruct.append
(fst (encode_string (match bs with None -> "" | Some x -> x)))
(encode_strings bridges)
let decode_delegate buf =
decode_string buf >>= fun (bs, l) ->
let bs = if bs = "" then None else Some bs in
decode_strings (Cstruct.shift buf l) >>= fun bridges ->
Ok (bridges, bs)
let encode_event ev =
let tag, data = match ev with
| `Startup -> 0, empty
| `Login (ip, port) -> 1, encode_addr ip port
| `Logout (ip, port) -> 2, encode_addr ip port
| `VM_start vm -> 3, encode_vm vm
| `VM_stop (pid, c) -> 4, encode_pid_exit pid c
| `Block_create (nam, siz) -> 5, encode_block nam siz
| `Block_destroy nam -> 6, fst (encode_string nam)
| `Delegate (bridges, bs) -> 7, encode_delegate bridges bs
in
let cs = Cstruct.create 2 in
Cstruct.BE.set_uint16 cs 0 tag ;
Cstruct.append cs data
let decode_event cs =
check_len cs 2 >>= fun () ->
let data = Cstruct.(shift cs 2) in
match Cstruct.BE.get_uint16 cs 0 with
| 0 -> Ok `Startup
| 1 -> decode_addr data >>= fun addr -> Ok (`Login addr)
| 2 -> decode_addr data >>= fun addr -> Ok (`Logout addr)
| 3 -> decode_vm data >>= fun vm -> Ok (`VM_start vm)
| 4 -> decode_pid_exit data >>= fun ex -> Ok (`VM_stop ex)
| 5 -> decode_block data >>= fun bl -> Ok (`Block_create bl)
| 6 -> decode_string data >>= fun (nam, _) -> Ok (`Block_destroy nam)
| 7 -> decode_delegate data >>= fun d -> Ok (`Delegate d)
| x -> R.error_msgf "couldn't parse event type %d" x
let data id version hdr event =
let hdr = encode_log_hdr hdr
and ev = encode_event event
in
let payload = Cstruct.append hdr ev in
let length = Cstruct.len payload
and tag = op_to_int Data
in
let r =
Cstruct.append (create_header { length ; id ; version ; tag }) payload
in
Cstruct.to_string r
end
module Client = struct
let cmd_to_int = function
| Info -> 0
| Destroy_vm -> 1
| Create_block -> 2
| Destroy_block -> 3
| Statistics -> 4
| Attach -> 5
| Detach -> 6
| Log -> 7
and cmd_of_int = function
| 0 -> Some Info
| 1 -> Some Destroy_vm
| 2 -> Some Create_block
| 3 -> Some Destroy_block
| 4 -> Some Statistics
| 5 -> Some Attach
| 6 -> Some Detach
| 7 -> Some Log
| _ -> None
let console_msg_tag = 0xFFF0
let log_msg_tag = 0xFFF1
let stat_msg_tag = 0xFFF2
let info_msg_tag = 0xFFF3
let cmd ?arg it id version =
let pay, length = may_enc_str arg
and tag = cmd_to_int it
in
let hdr = create_header { length ; id ; version ; tag } in
Cstruct.(to_string (append hdr pay))
let log hdr event version =
let payload =
Cstruct.append
(Log.encode_log_hdr ~drop_context:true hdr)
(Log.encode_event event)
in
let length = Cstruct.len payload in
let r =
Cstruct.append
(create_header { length ; id = 0 ; version ; tag = log_msg_tag })
payload
in
Cstruct.to_string r
let stat data id version =
let length = String.length data in
let hdr = create_header { length ; id ; version ; tag = stat_msg_tag } in
Cstruct.to_string hdr ^ data
let console off name payload version =
let name = match List.rev (id_of_string name) with
| leaf::_ -> leaf
| [] -> "none"
in
let nam, l = encode_string name in
let payload, length =
let p' = Astring.String.drop ~max:off payload in
p', l + String.length p'
in
let hdr =
create_header { length ; id = 0 ; version ; tag = console_msg_tag }
in
Cstruct.(to_string (append hdr nam)) ^ payload
let encode_vm name vm =
let name, _ = encode_string name
and cs, _ = encode_string (Bos.Cmd.to_string vm.cmd)
and pid = encode_pid vm.pid
and taps = encode_strings vm.taps
in
let tapc = encode_int (Cstruct.len taps) in
let r = Cstruct.concat [ name ; cs ; pid ; tapc ; taps ] in
Cstruct.to_string r
let info data id version =
let length = String.length data in
let hdr = create_header { length ; id ; version ; tag = info_msg_tag } in
Cstruct.to_string hdr ^ data
let decode_vm cs =
decode_string cs >>= fun (name, l) ->
decode_string (Cstruct.shift cs l) >>= fun (cmd, l') ->
decode_pid (Cstruct.shift cs (l + l')) >>= fun pid ->
decode_int ~off:(l + l' + 4) cs >>= fun tapc ->
let taps = Cstruct.sub cs (l + l' + 12) tapc in
decode_strings taps >>= fun taps ->
Ok ((name, cmd, pid, taps), Cstruct.shift cs (l + l' + 12 + tapc))
let decode_info data =
let rec go acc buf =
if Cstruct.len buf = 0 then
Ok (List.rev acc)
else
decode_vm buf >>= fun (vm, rest) ->
go (vm :: acc) rest
in
go [] (Cstruct.of_string data)
let decode_stat data =
Stats.decode_stats (Cstruct.of_string data)
let decode_log data =
let cs = Cstruct.of_string data in
Log.decode_log_hdr cs >>= fun (hdr, rest) ->
Log.decode_event rest >>= fun event ->
Ok (hdr, event)
let decode_console data =
let cs = Cstruct.of_string data in
decode_string cs >>= fun (name, l) ->
decode_ptime (Cstruct.shift cs l) >>= fun ts ->
decode_string (Cstruct.shift cs (l + 16)) >>= fun (line, _) ->
Ok (name, ts, line)
end

View file

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

View file

@ -1,221 +0,0 @@
(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *)
open Astring
open Rresult.R.Infix
open Vmm_core
external sysctl_rusage : int -> rusage = "vmmanage_sysctl_rusage"
external sysctl_ifcount : unit -> int = "vmmanage_sysctl_ifcount"
external sysctl_ifdata : int -> ifdata = "vmmanage_sysctl_ifdata"
type vmctx
external vmmapi_open : string -> vmctx = "vmmanage_vmmapi_open"
external vmmapi_close : vmctx -> unit = "vmmanage_vmmapi_close"
external vmmapi_statnames : vmctx -> string list = "vmmanage_vmmapi_statnames"
external vmmapi_stats : vmctx -> int64 list = "vmmanage_vmmapi_stats"
let my_version = `WV1
let descr = ref []
type t = {
pid_nic : ((vmctx, int) result * (int * string) list) IM.t ;
pid_rusage : rusage IM.t ;
pid_vmmapi : (string * int64) list IM.t ;
nic_ifdata : ifdata String.Map.t ;
vmid_pid : int String.Map.t ;
}
let pp_strings pp taps = Fmt.(list ~sep:(unit ",@ ") string) pp taps
let empty () =
{ pid_nic = IM.empty ; pid_rusage = IM.empty ; pid_vmmapi = IM.empty ; nic_ifdata = String.Map.empty ; vmid_pid = String.Map.empty }
let rec wrap f arg =
try Some (f arg) with
| Unix.Unix_error (Unix.EINTR, _, _) -> wrap f arg
| e ->
Logs.err (fun m -> m "exception %s" (Printexc.to_string e)) ;
None
let fill_descr ctx =
match !descr with
| [] ->
begin match wrap vmmapi_statnames ctx with
| None ->
Logs.err (fun m -> m "vmmapi_statnames failed, shouldn't happen") ;
()
| Some d ->
Logs.info (fun m -> m "descr are %a" pp_strings d) ;
descr := d
end
| ds -> Logs.info (fun m -> m "%d descr are already present" (List.length ds))
let open_vmmapi ?(retries = 4) pid =
let name = "ukvm" ^ string_of_int pid in
if retries = 0 then begin
Logs.debug (fun m -> m "(ignored 0) vmmapi_open failed for %d" pid) ;
Error 0
end else
match wrap vmmapi_open name with
| None ->
let left = max 0 (pred retries) in
Logs.warn (fun m -> m "(ignored, %d attempts left) vmmapi_open failed for %d" left pid) ;
Error left
| Some vmctx ->
Logs.info (fun m -> m "vmmapi_open succeeded for %d" pid) ;
fill_descr vmctx ;
Ok vmctx
let try_open_vmmapi pid_nic =
IM.fold (fun pid (vmctx, nics) fresh ->
let vmctx =
match vmctx with
| Ok vmctx -> Ok vmctx
| Error retries -> open_vmmapi ~retries pid
in
IM.add pid (vmctx, nics) fresh)
pid_nic IM.empty
let gather pid vmctx nics =
wrap sysctl_rusage pid,
(match vmctx with
| Error _ -> None
| Ok vmctx -> wrap vmmapi_stats vmctx),
List.fold_left (fun ifd (nic, nname) ->
match wrap sysctl_ifdata nic with
| None ->
Logs.warn (fun m -> m "failed to get ifdata for %s" nname) ;
ifd
| Some data ->
Logs.debug (fun m -> m "adding ifdata for %s" nname) ;
String.Map.add data.name data ifd)
String.Map.empty nics
let tick t =
Logs.debug (fun m -> m "tick with %d vms" (IM.cardinal t.pid_nic)) ;
let pid_rusage, pid_vmmapi, nic_ifdata =
IM.fold (fun pid (vmctx, nics) (rus, vmms, ifds) ->
let ru, vmm, ifd = gather pid vmctx nics in
(match ru with
| None ->
Logs.warn (fun m -> m "failed to get rusage for %d" pid) ;
rus
| Some ru ->
Logs.debug (fun m -> m "adding resource usage for %d" pid) ;
IM.add pid ru rus),
(match vmm with
| None ->
Logs.warn (fun m -> m "failed to get vmmapi_stats for %d" pid) ;
vmms
| Some vmm ->
Logs.debug (fun m -> m "adding vmmapi_stats for %d" pid) ;
IM.add pid (List.combine !descr vmm) vmms),
String.Map.union (fun _k a _b -> Some a) ifd ifds)
t.pid_nic (IM.empty, IM.empty, String.Map.empty)
in
let pid_nic = try_open_vmmapi t.pid_nic in
{ t with pid_rusage ; pid_vmmapi ; nic_ifdata ; pid_nic }
let add_pid t vmid pid nics =
match wrap sysctl_ifcount () with
| None ->
Logs.err (fun m -> m "sysctl ifcount failed for %d %a" pid pp_strings nics) ;
Error (`Msg "sysctl ifcount failed")
| Some max_nic ->
let rec go cnt acc id =
if id > 0 && cnt > 0 then
match wrap sysctl_ifdata id with
| Some ifd when List.mem ifd.name nics ->
go (pred cnt) ((id, ifd.name) :: acc) (pred id)
| _ -> go cnt acc (pred id)
else
List.rev acc
in
Ok (go (List.length nics) [] max_nic) >>= fun nic_ids ->
let vmctx = open_vmmapi pid in
Logs.info (fun m -> m "adding %d %a with vmctx %b" pid pp_strings nics
(match vmctx with Error _ -> false | Ok _ -> true)) ;
let pid_nic = IM.add pid (vmctx, nic_ids) t.pid_nic
and vmid_pid = String.Map.add vmid pid t.vmid_pid
in
Ok { t with pid_nic ; vmid_pid }
let stats t vmid =
Logs.debug (fun m -> m "querying statistics for vmid %s" vmid) ;
match String.Map.find vmid t.vmid_pid with
| None -> Error (`Msg ("unknown vm " ^ vmid))
| Some pid ->
Logs.debug (fun m -> m "querying statistics for %d" pid) ;
try
let _, nics = IM.find pid t.pid_nic
and ru = IM.find pid t.pid_rusage
and vmm =
try IM.find pid t.pid_vmmapi with
| Not_found ->
Logs.err (fun m -> m "failed to find vmm stats for %d" pid);
[]
in
match
List.fold_left (fun acc nic ->
match String.Map.find nic t.nic_ifdata, acc with
| None, _ -> None
| _, None -> None
| Some ifd, Some acc -> Some (ifd :: acc))
(Some []) (snd (List.split nics))
with
| None -> Error (`Msg "failed to find interface statistics")
| Some ifd -> Ok (ru, vmm, ifd)
with
| _ -> Error (`Msg "failed to find resource usage")
let remove_vmid t vmid =
Logs.info (fun m -> m "removing vmid %s" vmid) ;
match String.Map.find vmid t.vmid_pid with
| None -> Logs.warn (fun m -> m "no pid found for %s" vmid) ; t
| Some pid ->
Logs.info (fun m -> m "removing pid %d" pid) ;
(try
match IM.find pid t.pid_nic with
| Ok vmctx, _ -> ignore (wrap vmmapi_close vmctx)
| Error _, _ -> ()
with
_ -> ()) ;
let pid_nic = IM.remove pid t.pid_nic
and vmid_pid = String.Map.remove vmid t.vmid_pid
in
{ t with pid_nic ; vmid_pid }
let remove_vmids t vmids =
List.fold_left remove_vmid t vmids
let handle t hdr buf =
let open Vmm_wire in
let open Vmm_wire.Stats in
let cs = Cstruct.of_string buf in
let r =
if not (version_eq my_version hdr.version) then
Error (`Msg "cannot handle version")
else
decode_string cs >>= fun (name, off) ->
match int_to_op hdr.tag with
| Some Add ->
decode_pid_taps (Cstruct.shift cs off) >>= fun (pid, taps) ->
add_pid t name pid taps >>= fun t ->
Ok (t, `Add name, success ~msg:"added" hdr.id my_version)
| Some Remove ->
let t = remove_vmid t name in
Ok (t, `Remove name, success ~msg:"removed" hdr.id my_version)
| Some Stat_request ->
stats t name >>= fun s ->
Ok (t, `None, stat_reply hdr.id my_version (encode_stats s))
| _ -> Error (`Msg "unknown command")
in
match r with
| Ok (t, action, out) -> t, action, out
| Error (`Msg msg) ->
Logs.err (fun m -> m "error while processing %s" msg) ;
t, `None, fail ~msg hdr.id my_version