move stuff around

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

_tags

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

app/vmmc_local.ml

@@ -326,7 +326,7 @@ let default_cmd =
     `P "$(tname) connects to vmmd via a local socket" ]
   in
   Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)),
-  Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man
+  Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man
 
 let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ]
 

app/vmmc_remote.ml

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

app/vmmd_console.ml

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

app/vmmd_influx.ml

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

app/vmmd_stats.ml

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

app/vmmd_tls.ml

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

app/vmmp_request.ml

@@ -1,5 +1,78 @@
 (* (c) 2017 Hannes Mehnert, all rights reserved *)
 
+open Vmm_provision
+
+open Rresult.R.Infix
+
+open Vmm_asn
+
+let vm_csr key name image cpuid requested_memory argv block_device network force compression =
+  let vm_config =
+    let vmimage = match compression with
+      | 0 -> `Hvt_amd64, image
+      | level ->
+        let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
+        `Hvt_amd64_compressed, Cstruct.of_string img
+    and argv = match argv with [] -> None | xs -> Some xs
+    in
+    Vmm_core.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage }
+  in
+  let cmd = if force then `Vm_force_create vm_config else `Vm_create vm_config in
+  let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, `Vm_cmd cmd))) ]
+  and name = [ `CN name ]
+  in
+  X509.CA.request name ~extensions:[`Extensions exts] key
+
+let jump _ name key image mem cpu args block net force compression =
+  Nocrypto_entropy_unix.initialize () ;
+  match
+    priv_key key name >>= fun key ->
+    (Bos.OS.File.read (Fpath.v image) >>= fun s ->
+     Ok (Cstruct.of_string s)) >>= fun image ->
+    let csr = vm_csr key name image cpu mem args block net force compression in
+    let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in
+    Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
+  with
+  | Ok () -> `Ok ()
+  | Error (`Msg m) -> `Error (false, m)
+
+open Cmdliner
+
+let cpu =
+  let doc = "CPUid" in
+  Arg.(required & pos 3 (some int) None & info [] ~doc)
+
+let image =
+  let doc = "Image file to provision" in
+  Arg.(required & pos 1 (some file) None & info [] ~doc)
+
+let args =
+  let doc = "Boot arguments" in
+  Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
+
+let block =
+  let doc = "Block device name" in
+  Arg.(value & opt (some string) None & info [ "block" ] ~doc)
+
+let net =
+  let doc = "Network device" in
+  Arg.(value & opt_all string [] & info [ "net" ] ~doc)
+
+let force =
+  let doc = "Force creation (destroy VM with same name if it exists)" in
+  Arg.(value & flag & info [ "force" ] ~doc)
+
+let compress_level =
+  let doc = "Compression level (0 for no compression)" in
+  Arg.(value & opt int 4 & info [ "compression-level" ] ~doc)
+
+let cmd =
+  Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)),
+  Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%"
+
+let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1
+(* (c) 2017 Hannes Mehnert, all rights reserved *)
+
 open Vmm_provision
 open Vmm_asn
 
@@ -77,6 +150,6 @@ let bridge =
 
 let cmd =
   Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)),
-  Term.info "vmm_req_delegation" ~version:"%%VERSION_NUM%%"
+  Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%"
 
 let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

app/vmmp_sign.ml

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

myocamlbuild.ml

@@ -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));
+        (S ([A "app/libvmm_stats_stubs.a"] @ vmm_lib));
-      dep ["link"; "ocaml"; "use_vmm_stats"] ["stats/libvmm_stats_stubs.a"];
+      dep ["link"; "ocaml"; "use_vmm_stats"] ["app/libvmm_stats_stubs.a"];
-      dep ["link"; "ocaml"; "link_vmm_stats"] ["stats/libvmm_stats_stubs.a"];
+      dep ["link"; "ocaml"; "link_vmm_stats"] ["app/libvmm_stats_stubs.a"];
     | _ -> ()
   end

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"
+homepage: "https://github.com/hannesm/albatross"
-dev-repo: "https://github.com/hannesm/vmm.git"
+dev-repo: "git+https://github.com/hannesm/albatross.git"
-bug-reports: "https://github.com/hannesm/vmm/issues"
+bug-reports: "https://github.com/hannesm/albatross/issues"
-available: [ ocaml-version >= "4.05.0"]
 
 depends: [
+  "ocaml" {>= "4.05.0"}
   "ocamlfind" {build}
   "ocamlbuild" {build}
   "topkg" {build}
@@ -32,3 +32,4 @@ depends: [
 build: [
   [ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ]
 ]
+synopsis: "Albatross - orchestrate and manage MirageOS unikernels"

packaging/create_package.sh

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

packaging/rc.d/albatross_console

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

packaging/rc.d/albatross_log

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

packaging/rc.d/albatross_stat

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

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"

pkg/pkg.ml

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

provision/vmm_gen_ca.ml

@@ -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

provision/vmm_req_vm.ml

@@ -1,73 +0,0 @@
-(* (c) 2017 Hannes Mehnert, all rights reserved *)
-
-open Vmm_provision
-
-open Rresult.R.Infix
-
-open Vmm_asn
-
-let vm_csr key name image cpuid requested_memory argv block_device network force compression =
-  let vm_config =
-    let vmimage = match compression with
-      | 0 -> `Hvt_amd64, image
-      | level ->
-        let img = Vmm_compress.compress ~level (Cstruct.to_string image) in
-        `Hvt_amd64_compressed, Cstruct.of_string img
-    and argv = match argv with [] -> None | xs -> Some xs
-    in
-    Vmm_core.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage }
-  in
-  let cmd = if force then `Vm_force_create vm_config else `Vm_create vm_config in
-  let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, `Vm_cmd cmd))) ]
-  and name = [ `CN name ]
-  in
-  X509.CA.request name ~extensions:[`Extensions exts] key
-
-let jump _ name key image mem cpu args block net force compression =
-  Nocrypto_entropy_unix.initialize () ;
-  match
-    priv_key key name >>= fun key ->
-    (Bos.OS.File.read (Fpath.v image) >>= fun s ->
-     Ok (Cstruct.of_string s)) >>= fun image ->
-    let csr = vm_csr key name image cpu mem args block net force compression in
-    let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in
-    Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc)
-  with
-  | Ok () -> `Ok ()
-  | Error (`Msg m) -> `Error (false, m)
-
-open Cmdliner
-
-let cpu =
-  let doc = "CPUid" in
-  Arg.(required & pos 3 (some int) None & info [] ~doc)
-
-let image =
-  let doc = "Image file to provision" in
-  Arg.(required & pos 1 (some file) None & info [] ~doc)
-
-let args =
-  let doc = "Boot arguments" in
-  Arg.(value & opt_all string [] & info [ "arg" ] ~doc)
-
-let block =
-  let doc = "Block device name" in
-  Arg.(value & opt (some string) None & info [ "block" ] ~doc)
-
-let net =
-  let doc = "Network device" in
-  Arg.(value & opt_all string [] & info [ "net" ] ~doc)
-
-let force =
-  let doc = "Force creation (destroy VM with same name if it exists)" in
-  Arg.(value & flag & info [ "force" ] ~doc)
-
-let compress_level =
-  let doc = "Compression level (0 for no compression)" in
-  Arg.(value & opt int 4 & info [ "compression-level" ] ~doc)
-
-let cmd =
-  Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)),
-  Term.info "vmm_req_vm" ~version:"%%VERSION_NUM%%"
-
-let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1

src/albatross.mllib

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

src/vmm_asn.ml

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

src/vmm_asn.mli

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

src/vmm_core.ml

@@ -177,16 +177,6 @@ let translate_tap vm tap =
   | [ (_, b) ] -> Some b
   | _ -> None
 
-let name cert = X509.common_name_to_string cert
-
-(* this separates the leaf and top-level certificate from the chain,
-   and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA')
-   in which subCA' signed leaf *)
-let separate_chain = function
-  | [] -> Error (`Msg "empty chain")
-  | [ leaf ] -> Ok (leaf, [])
-  | leaf :: xs -> Ok (leaf, List.rev xs)
-
 module Stats = struct
   type rusage = {
     utime : (int64 * int) ;

src/vmm_core.mli

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

src/vmm_tls.ml

@@ -1,8 +1,29 @@
 (* (c) 2018 Hannes Mehnert, all rights reserved *)
 
+open Rresult
 open Rresult.R.Infix
 
-open Vmm_core
+let name cert = X509.common_name_to_string cert
+
+(* this separates the leaf and top-level certificate from the chain,
+   and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA')
+   in which subCA' signed leaf *)
+let separate_chain = function
+  | [] -> Error (`Msg "empty chain")
+  | [ leaf ] -> Ok (leaf, [])
+  | leaf :: xs -> Ok (leaf, List.rev xs)
+
+let wire_command_of_cert version cert =
+  match X509.Extension.unsupported cert Vmm_asn.oid with
+  | None -> R.error_msgf "albatross OID is not present in certificate (%a)" Asn.OID.pp Vmm_asn.oid
+  | Some (_, data) ->
+    Vmm_asn.cert_extension_of_cstruct data >>= fun (v, wire) ->
+    if not (Vmm_commands.version_eq v version) then
+      R.error_msgf "unexpected version %a (expected %a)"
+        Vmm_commands.pp_version v
+        Vmm_commands.pp_version version
+    else
+      Ok wire
 
 (* let check_policy =
      (* get names and static resources *)
@@ -28,7 +49,7 @@ let handle _addr version chain =
   (* TODO: inspect top-level-cert of chain. *)
   (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *)
   (* TODO: update policies (parse chain for policy, and apply them)! *)
-  Vmm_asn.wire_command_of_cert version leaf >>= fun wire ->
+  wire_command_of_cert version leaf >>= fun wire ->
   (* we only allow some commands via certificate *)
   match wire with
   | `Console_cmd (`Console_subscribe _)

src/vmm_tls.mli

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

stats/libvmm_stats_stubs.clib

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