diff --git a/README.md b/README.md index 9c7b89d..47b41ab 100644 --- a/README.md +++ b/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_sign`: signs a certificate signing request Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation and an overview. diff --git a/_tags b/_tags index 07bee85..5080875 100644 --- a/_tags +++ b/_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 -: package(decompress) -: package(asn1-combinators) : package(lwt lwt.unix) : package(lwt tls.lwt) : package(x509) +: package(ptime.clock.os) -: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress) -: package(nocrypto tls.lwt nocrypto.lwt) -: package(tls.lwt) -: package(nocrypto tls.lwt nocrypto.lwt) +: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix) +: package(ptime.clock.os) +: package(ptime.clock.os) +: package(ptime.clock.os) +: package(tls.lwt ptime.clock.os) +: link_vmm_stats, package(asn1-combinators) -: package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt decompress) +: package(nocrypto tls.lwt nocrypto.lwt) + +: package(nocrypto.unix ptime.clock.os x509) +: package(nocrypto.unix ptime.clock.os x509) + +: package(nocrypto.unix ptime.clock.os x509) -: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt decompress) -: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt decompress) diff --git a/provision/vmm_provision.ml b/app/vmm_provision.ml similarity index 100% rename from provision/vmm_provision.ml rename to app/vmm_provision.ml diff --git a/stats/vmm_stats.ml b/app/vmm_stats_pure.ml similarity index 100% rename from stats/vmm_stats.ml rename to app/vmm_stats_pure.ml diff --git a/stats/vmm_stats_stubs.c b/app/vmm_stats_stubs.c similarity index 100% rename from stats/vmm_stats_stubs.c rename to app/vmm_stats_stubs.c diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml new file mode 100644 index 0000000..e69de29 diff --git a/app/vmmc.ml b/app/vmmc_local.ml similarity index 99% rename from app/vmmc.ml rename to app/vmmc_local.ml index d0d2889..5816b4f 100644 --- a/app/vmmc.ml +++ b/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 ] diff --git a/app/vmm_client.ml b/app/vmmc_remote.ml similarity index 89% rename from app/vmm_client.ml rename to app/vmmc_remote.ml index 1083b08..5572a8f 100644 --- a/app/vmm_client.ml +++ b/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 diff --git a/app/vmm_console.ml b/app/vmmd_console.ml similarity index 99% rename from app/vmm_console.ml rename to app/vmmd_console.ml index 16ac1ea..9f025ae 100644 --- a/app/vmm_console.ml +++ b/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 diff --git a/app/vmm_influxdb_stats.ml b/app/vmmd_influx.ml similarity index 99% rename from app/vmm_influxdb_stats.ml rename to app/vmmd_influx.ml index f53ce3c..2170fec 100644 --- a/app/vmm_influxdb_stats.ml +++ b/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 diff --git a/app/vmm_log.ml b/app/vmmd_log.ml similarity index 100% rename from app/vmm_log.ml rename to app/vmmd_log.ml diff --git a/stats/vmm_stats_lwt.ml b/app/vmmd_stats.ml similarity index 93% rename from stats/vmm_stats_lwt.ml rename to app/vmmd_stats.ml index 0763592..dfe28d9 100644 --- a/stats/vmm_stats_lwt.ml +++ b/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 diff --git a/app/vmm_tls_endpoint.ml b/app/vmmd_tls.ml similarity index 99% rename from app/vmm_tls_endpoint.ml rename to app/vmmd_tls.ml index cb1a230..6694efe 100644 --- a/app/vmm_tls_endpoint.ml +++ b/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 diff --git a/provision/vmm_req_delegation.ml b/app/vmmp_request.ml similarity index 52% rename from provision/vmm_req_delegation.ml rename to app/vmmp_request.ml index dcdd32e..caa9110 100644 --- a/provision/vmm_req_delegation.ml +++ b/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 diff --git a/provision/vmm_sign.ml b/app/vmmp_sign.ml similarity index 62% rename from provision/vmm_sign.ml rename to app/vmmp_sign.ml index 4ac30d9..6737d72 100644 --- a/provision/vmm_sign.ml +++ b/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 diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 7f9eb76..2093954 100644 --- a/myocamlbuild.ml +++ b/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)); - 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 diff --git a/opam b/opam index 79e236f..6d8816a 100644 --- a/opam +++ b/opam @@ -1,12 +1,12 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "Hannes Mehnert " authors: ["Hannes Mehnert "] -homepage: "https://github.com/hannesm/vmm" -dev-repo: "https://github.com/hannesm/vmm.git" -bug-reports: "https://github.com/hannesm/vmm/issues" -available: [ ocaml-version >= "4.05.0"] +homepage: "https://github.com/hannesm/albatross" +dev-repo: "git+https://github.com/hannesm/albatross.git" +bug-reports: "https://github.com/hannesm/albatross/issues" depends: [ + "ocaml" {>= "4.05.0"} "ocamlfind" {build} "ocamlbuild" {build} "topkg" {build} @@ -32,3 +32,4 @@ depends: [ build: [ [ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ] ] +synopsis: "Albatross - orchestrate and manage MirageOS unikernels" diff --git a/packaging/create_package.sh b/packaging/create_package.sh index b54f753..a54e5ff 100755 --- a/packaging/create_package.sh +++ b/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 \ - $rootdir/usr/local/libexec/albatross/vmm_stats_lwt +install -U $basedir/_build/app/vmmd_stats.native \ + $rootdir/usr/local/libexec/albatross/vmmd_stats -install -U $basedir/_build/app/vmmc.native \ - $rootdir/usr/local/sbin/vmmc +install -U $basedir/_build/app/vmm_local.native \ + $rootdir/usr/local/sbin/vmm_local # create +MANIFEST flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + | diff --git a/packaging/rc.d/albatross_console b/packaging/rc.d/albatross_console index 7b3df7b..ef8845f 100755 --- a/packaging/rc.d/albatross_console +++ b/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}" \ diff --git a/packaging/rc.d/albatross_log b/packaging/rc.d/albatross_log index e49b02e..f44b2ea 100755 --- a/packaging/rc.d/albatross_log +++ b/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 () { diff --git a/packaging/rc.d/albatross_stat b/packaging/rc.d/albatross_stat index 04b215d..305f6cc 100755 --- a/packaging/rc.d/albatross_stat +++ b/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}" \ diff --git a/pkg/META b/pkg/META index 9f42198..29b861c 100644 --- a/pkg/META +++ b/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" diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 0d66ebe..97a095f 100644 --- a/pkg/pkg.ml +++ b/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/vmm_log" ; - Pkg.bin "app/vmm_client" ; - Pkg.bin "app/vmm_tls_endpoint" ; - Pkg.bin "app/vmmc" ; - Pkg.bin "provision/vmm_req_delegation" ; - Pkg.bin "provision/vmm_req_vm" ; - Pkg.bin "provision/vmm_sign" ; - Pkg.bin "provision/vmm_gen_ca" ; - (* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *) - Pkg.bin "stats/vmm_stats_lwt" ; - Pkg.bin "app/vmm_influxdb_stats" ; + Pkg.bin "app/vmmd_console" ; + Pkg.bin "app/vmmd_log" ; + Pkg.bin "app/vmmd_stats" ; + Pkg.bin "app/vmmd_tls" ; + Pkg.bin "app/vmmd_influx" ; + Pkg.bin "app/vmmc_local" ; + Pkg.bin "app/vmmc_remote" ; + Pkg.bin "app/vmmc_bistro" ; + Pkg.bin "app/vmmp_request" ; + Pkg.bin "app/vmmp_sign" ; ] diff --git a/provision/vmm_gen_ca.ml b/provision/vmm_gen_ca.ml deleted file mode 100644 index 738cceb..0000000 --- a/provision/vmm_gen_ca.ml +++ /dev/null @@ -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 diff --git a/provision/vmm_req_vm.ml b/provision/vmm_req_vm.ml deleted file mode 100644 index f5cde5f..0000000 --- a/provision/vmm_req_vm.ml +++ /dev/null @@ -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 diff --git a/src/albatross.mllib b/src/albatross.mllib deleted file mode 100644 index 54e58a8..0000000 --- a/src/albatross.mllib +++ /dev/null @@ -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 diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index cde00f6..834504f 100644 --- a/src/vmm_asn.ml +++ b/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 diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 6310794..2b4c48e 100644 --- a/src/vmm_asn.mli +++ b/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 diff --git a/src/vmm_core.ml b/src/vmm_core.ml index f04437f..63abb84 100644 --- a/src/vmm_core.ml +++ b/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) ; diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 479c7ef..a464914 100644 --- a/src/vmm_core.mli +++ b/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; diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 06df530..2000cb7 100644 --- a/src/vmm_tls.ml +++ b/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 _) diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index ebb5e2f..6505d41 100644 --- a/src/vmm_tls.mli +++ b/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 -> diff --git a/stats/libvmm_stats_stubs.clib b/stats/libvmm_stats_stubs.clib deleted file mode 100644 index 209b378..0000000 --- a/stats/libvmm_stats_stubs.clib +++ /dev/null @@ -1 +0,0 @@ -vmm_stats_stubs.o