commit
0ce16cbf6b
2
.merlin
2
.merlin
|
@ -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
3
.ocamlinit
Normal 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"
|
|
@ -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
|
||||
|
|
42
README.md
42
README.md
|
@ -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
29
_tags
|
@ -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
147
app/vmm_cli.ml
Normal 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)
|
|
@ -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
|
|
@ -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
|
162
app/vmm_log.ml
162
app/vmm_log.ml
|
@ -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
|
|
@ -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
|
|
@ -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
196
app/vmm_stats_pure.ml
Normal 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
256
app/vmmc_bistro.ml
Normal 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
215
app/vmmc_local.ml
Normal 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
75
app/vmmc_remote.ml
Normal 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
|
410
app/vmmd.ml
410
app/vmmd.ml
|
@ -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
185
app/vmmd_console.ml
Normal 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
|
|
@ -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
193
app/vmmd_log.ml
Normal 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
|
|
@ -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
201
app/vmmd_tls.ml
Normal 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
166
app/vmmp_ca.ml
Normal 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
180
app/vmmp_request.ml
Normal 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
|
|
@ -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
14
opam
|
@ -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
83
packaging/MANIFEST
Normal 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
52
packaging/create_package.sh
Executable 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/
|
39
packaging/rc.d/albatross_console
Executable file
39
packaging/rc.d/albatross_console
Executable 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
74
packaging/rc.d/albatross_daemon
Executable 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
47
packaging/rc.d/albatross_log
Executable 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
39
packaging/rc.d/albatross_stat
Executable 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
73
packaging/rc.d/albatross_x
Executable 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
|
||||
|
5
pkg/META
5
pkg/META
|
@ -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"
|
||||
|
|
23
pkg/pkg.ml
23
pkg/pkg.ml
|
@ -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" ;
|
||||
]
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
545
src/vmm_asn.ml
545
src/vmm_asn.ml
|
@ -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
|
||||
|
|
164
src/vmm_asn.mli
164
src/vmm_asn.mli
|
@ -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
|
||||
|
|
|
@ -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 *)
|
||||
|
|
|
@ -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
4
src/vmm_compress.mli
Normal file
|
@ -0,0 +1,4 @@
|
|||
(* (c) 2018 Hannes Mehnert, all rights reserved *)
|
||||
|
||||
val compress : ?level:int -> string -> string
|
||||
val uncompress : string -> (string, unit) result
|
383
src/vmm_core.ml
383
src/vmm_core.ml
|
@ -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
158
src/vmm_core.mli
Normal 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
|
|
@ -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, []
|
|
@ -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
24
src/vmm_lwt.mli
Normal 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
|
|
@ -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")
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
9
src/vmm_ring.mli
Normal 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
|
143
src/vmm_tls.ml
143
src/vmm_tls.ml
|
@ -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
10
src/vmm_tls.mli
Normal 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
69
src/vmm_tls_lwt.ml
Normal 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
9
src/vmm_tls_lwt.mli
Normal 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
99
src/vmm_trie.ml
Normal 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
19
src/vmm_trie.mli
Normal 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
180
src/vmm_unix.ml
Normal 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
15
src/vmm_unix.mli
Normal 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
200
src/vmm_vmmd.ml
Normal 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
27
src/vmm_vmmd.mli
Normal 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
|
697
src/vmm_wire.ml
697
src/vmm_wire.ml
|
@ -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
|
|
@ -1 +0,0 @@
|
|||
vmm_stats_stubs.o
|
|
@ -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
|
Loading…
Reference in a new issue