From 02be3f4528f94ec300663441e1cb512f9f20aee2 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 26 May 2017 16:30:34 +0200 Subject: [PATCH] initial --- .gitignore | 2 + .merlin | 9 + CHANGES.md | 0 LICENSE.md | 0 README.md | 153 +++++++ _tags | 17 + app/vmm_client.ml | 189 +++++++++ app/vmm_console.ml | 179 +++++++++ app/vmm_log.ml | 127 ++++++ app/vmmd.ml | 244 ++++++++++++ myocamlbuild.ml | 18 + opam | 25 ++ pkg/META | 7 + pkg/pkg.ml | 21 + provision/vmm_gen_ca.ml | 50 +++ provision/vmm_provision.ml | 135 +++++++ provision/vmm_req_delegation.ml | 85 ++++ provision/vmm_req_permissions.ml | 46 +++ provision/vmm_req_vm.ml | 70 ++++ provision/vmm_revoke.ml | 78 ++++ provision/vmm_sign.ml | 285 +++++++++++++ src/vmm_asn.ml | 210 ++++++++++ src/vmm_asn.mli | 161 ++++++++ src/vmm_commands.ml | 186 +++++++++ src/vmm_commands.mli | 21 + src/vmm_core.ml | 376 ++++++++++++++++++ src/vmm_engine.ml | 507 +++++++++++++++++++++++ src/vmm_lwt.ml | 56 +++ src/vmm_resources.ml | 125 ++++++ src/vmm_resources.mli | 56 +++ src/vmm_ring.ml | 38 ++ src/vmm_tls.ml | 35 ++ src/vmm_wire.ml | 662 +++++++++++++++++++++++++++++++ stats/libvmm_stats_stubs.clib | 1 + stats/vmm_stats.ml | 126 ++++++ stats/vmm_stats_lwt.ml | 78 ++++ stats/vmm_stats_stubs.c | 152 +++++++ 37 files changed, 4530 insertions(+) create mode 100644 .gitignore create mode 100644 .merlin create mode 100644 CHANGES.md create mode 100644 LICENSE.md create mode 100644 README.md create mode 100644 _tags create mode 100644 app/vmm_client.ml create mode 100644 app/vmm_console.ml create mode 100644 app/vmm_log.ml create mode 100644 app/vmmd.ml create mode 100644 myocamlbuild.ml create mode 100644 opam create mode 100644 pkg/META create mode 100644 pkg/pkg.ml create mode 100644 provision/vmm_gen_ca.ml create mode 100644 provision/vmm_provision.ml create mode 100644 provision/vmm_req_delegation.ml create mode 100644 provision/vmm_req_permissions.ml create mode 100644 provision/vmm_req_vm.ml create mode 100644 provision/vmm_revoke.ml create mode 100644 provision/vmm_sign.ml create mode 100644 src/vmm_asn.ml create mode 100644 src/vmm_asn.mli create mode 100644 src/vmm_commands.ml create mode 100644 src/vmm_commands.mli create mode 100644 src/vmm_core.ml create mode 100644 src/vmm_engine.ml create mode 100644 src/vmm_lwt.ml create mode 100644 src/vmm_resources.ml create mode 100644 src/vmm_resources.mli create mode 100644 src/vmm_ring.ml create mode 100644 src/vmm_tls.ml create mode 100644 src/vmm_wire.ml create mode 100644 stats/libvmm_stats_stubs.clib create mode 100644 stats/vmm_stats.ml create mode 100644 stats/vmm_stats_lwt.ml create mode 100644 stats/vmm_stats_stubs.c diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c44364a --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +_build +vmm.install diff --git a/.merlin b/.merlin new file mode 100644 index 0000000..09b0e65 --- /dev/null +++ b/.merlin @@ -0,0 +1,9 @@ +S src +S stats +S app +S provision + +B _build/** + +PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex cstruct.ppx duration +PKG ptime ptime.clock.os ipaddr.unix \ No newline at end of file diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..e69de29 diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..e69de29 diff --git a/README.md b/README.md new file mode 100644 index 0000000..f83401f --- /dev/null +++ b/README.md @@ -0,0 +1,153 @@ +# Managing virtual machines + +A set of binaries to manage, provision, and deploy virtual machine images. This +is very much work in progress, don't expect anything stable. + +Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation +and an overview. + +The implementation uses explicit errors (no exceptions), and make mostly use of +the (blocking!) Bos library for operating system commands. A thin layer of Lwt +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. + +It requires some pinned packages: +- `asn1-combinators https://github.com/hannesm/ocaml-asn-combinators.git#enum` +- `x509 https://github.com/hannesm/ocaml-x509.git#crl` +- `tls https://github.com/hannesm/ocaml-tls.git#changes` +- on FreeBSD, `solo5-kernel-ukvm https://github.com/solo5/solo5.git` + +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 +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 +to be executed on. Of course you can conflate everything into a single +development system or your server, all up to you and your security scenario. + +Exact file transfer operations between these machines is not in scope of this +document, but kept abstract as `COPY`. Some commands require superuser +privileges (use `sudo`, `su`, or `doas`), I prefixed them with `#`. + +File endings used in this document: +- `.db` for CA databases +- `.pem` for (PEM-encoded) signed certificates +- `.key` for (PEM-encoded) private keys +- `.req` for (PEM-encoded) certificate signing requests + +## Setup a certificate authority + +The first step is to setup a certificate authority (private key and CA +certificate). The CA private key can sign and revoke everything, you should +better keep it in a safe place (air-gapped machine etc.) - not on the server! + +``` +CA> vmm_gen_ca ca ca.db [--days 3650] [--server "server"] [--server-days 365] +``` + +This generated five files: +- `ca.key` which is the CA private key +- `cacert.pem` which is the CA certificate +- `ca.db` which contains a map between serial number and name of issued certificates +- `server.pem` is the server certificate +- `server.key` is the private key of the server + +## Server setup + +If you have installed this package on your development machine, follow some more +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 build +DEV> mv ukvm-bin /tmp/ukvm-bin.none +DEV> cd ../device-usage/network +DEV> mirage configure -t ukvm +DEV> mirage build +DEV> mv ukvm-bin /tmp/ukvm-bin.net +DEV> cd ../../.. +DEV> COPY /tmp/ukvm-bin.none /tmp/ukvm-bin.net SRV: +DEV> COPY vmm_console vmm_log vmm_stats_lwt vmmd SRV: +``` + +``` +SRV> vmm_console -vv cons.sock & +SRV> vmm_log -vv log.out log.sock & +SRV> vmm_stats_lwt -vv stat.sock & #optional +SRV# vmmd -vv . cacert.pem server.pem server.key +``` + +Some setup for network interfaces is needed, depending on your operating system. +You can also add NAT to allow your virtual machines to talk to the outside +world, or add your external interface to the bridge directly, or just keep your +VMs local. + +``` +# FreeBSD +SRV# ifconfig bridge create +SRV# ifconfig bridge0 name ext +SRV# sysctl net.link.tap.up_on_open=1 +# Linux +SRV# brctl addbr ext +``` + +## Provision our first virtual machine + +We will delegate some resource to a certificate and key we keep on our +development machine. + +``` +DEV> vmm_req_delegation dev 2 1024 --cpu 1 --bridge ext/10.0.0.2/10.0.0.5/10.0.0.1/24 +DEV> COPY dev.req CA: +``` + +This produced two files, dev.req and dev.key. Keep the key in a safe place! + +``` +CA> vmm_sign ca.db cacert.pem ca.key dev.req [--days 10] +CA> COPY dev.pem DEV: +``` + +Now, our DEV machine can use its delegation certificate for issuing other +certificates. We'll create a certificate for interactive use, and one +containing the hello unikernel. + +``` +DEV> vmm_req_permissions admin --permission all +DEV> vmm_sign dev.db dev.pem dev.key admin.req +``` + +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 512 1 +DEV> vmm_sign dev.db dev.pem dev.key hello.req +``` + +This produced three more files, `hello.{req,key,pem}` and modified `dev.db`. + +To actually deploy anything, the server needs the chain (i.e. the vm certificate +and the delegation certificate). Our client needs the main CA certificate to +authenticate the server itself. + +``` +CA> COPY cacert.pem DEV: +DEV> cat admin.pem dev.pem > admin.bundle +DEV> cat hello.pem dev.pem > hello.bundle +``` + +And deploying (watch the output of the processes started on the server above!): + +``` +DEV> vmm_client cacert.pem hello.bundle hello.key SRV:1025 +DEV> vmm_client cacert.pem admin.bundle hello.key SRV:1025 --db dev.db +``` + +Commands are at the moment `info`, `statistics`, `destroy`, `attach`, `detach`, +and `log`. diff --git a/_tags b/_tags new file mode 100644 index 0000000..97e0a41 --- /dev/null +++ b/_tags @@ -0,0 +1,17 @@ +true : bin_annot, safe_string, principal +true : warn(+A-44) +true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration) +"src" : include + +: package(cstruct.ppx) +: package(asn1-combinators) +: package(lwt) +: package(lwt tls.lwt) + +: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix) +: package(nocrypto tls.lwt nocrypto.lwt) +: package(tls.lwt) + +: package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt) + +: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt) \ No newline at end of file diff --git a/app/vmm_client.ml b/app/vmm_client.ml new file mode 100644 index 0000000..1f9bac2 --- /dev/null +++ b/app/vmm_client.ml @@ -0,0 +1,189 @@ +(* (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, ifd) -> + Logs.app (fun m -> m "statistics: %a %a" + pp_rusage ru 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 = + Lwt.catch (fun () -> + 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 + | Ok (hdr, data) -> + Logs.debug (fun m -> m "read from tls 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 (Cstruct.of_string data)) ; + process db hdr data ; + read_tls_write_cons db t) + (fun _ -> Lwt.return_unit) + +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 >>= fun () -> + Logs.debug (fun m -> m "wrote %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ; + read_cons_write_tls db t) + (fun _ -> 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 + Vmm_tls.read_tls t >|= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) + | Ok (hdr, data) -> process db hdr data + 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 diff --git a/app/vmm_console.ml b/app/vmm_console.ml new file mode 100644 index 0000000..03e282b --- /dev/null +++ b/app/vmm_console.ml @@ -0,0 +1,179 @@ +(* (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.Set.empty + +let read_console s 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) ; + (if String.Set.mem name !active then + Vmm_lwt.write_raw s (data my_version name t line) + else + Lwt.return_unit) >>= fun () -> + 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.(v (Filename.get_temp_dir_name ()) / 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 s 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 s name ring f) ; + Ok "reading" + | None -> + Error (`Msg "opening") + +let attach 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.Set.add name !active ; + Lwt.return (Ok "attached") + +let detach name = + active := String.Set.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)) 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 () + | Ok (hdr, data) -> + (if not (version_eq hdr.version my_version) then + Lwt.return (Error (`Msg "ignoring data with bad version")) + else + match Console.int_to_op hdr.tag with + | Some Add -> + (match decode_str data with + | Error e -> Lwt.return (Error e) + | Ok (name, _) -> add_fifo s name) + | Some Attach -> + (match decode_str data with + | Error e -> Lwt.return (Error e) + | Ok (name, _) -> attach name) + | Some Detach -> + (match decode_str data with + | Error e -> Lwt.return (Error e) + | Ok (name, _) -> detach name) + | Some History -> + (match decode_str data with + | Error e -> Lwt.return (Error e) + | Ok (name, off) -> 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)) >>= fun () -> + loop () + in + loop () + +let jump _ file = + Sys.(set_signal sigpipe Signal_ignore) ; + Lwt_main.run + (let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.(Versioned.bind_2 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 onto" in + Arg.(value & pos 0 string "" & info [] ~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 diff --git a/app/vmm_log.ml b/app/vmm_log.ml new file mode 100644 index 0000000..46bd879 --- /dev/null +++ b/app/vmm_log.ml @@ -0,0 +1,127 @@ +(* (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 handle fd ring s addr () = + Logs.info (fun m -> m "handling connection") ; + 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 () + | Ok (hdr, data) -> + (if not (version_eq hdr.version my_version) then + Lwt.return (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 _ -> ()) ; + write_complete fd data >>= fun () -> + Lwt.return (Ok None) + | Some History -> + begin match decode_str data with + | Error e -> Lwt.return (Error e) + | Ok (str, off) -> match decode_ts ~off data with + | Error e -> Lwt.return (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 *) + Lwt_list.iter_s (fun 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 + Vmm_lwt.write_raw s (Cstruct.to_string hdr ^ x)) + (List.rev res) >>= fun () -> + Lwt.return (Ok None) + end + | _ -> + Logs.err (fun m -> m "didn't understand log command %d" hdr.tag) ; + 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: %s" msg) ; + Vmm_lwt.write_raw s (fail ~msg hdr.id my_version)) >>= fun () -> + loop () + in + Lwt.catch loop (fun e -> 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 -> + let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.(Versioned.bind_2 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 onto" in + Arg.(required & pos 1 (some string) None & info [] ~doc) + +let file = + let doc = "File to write to" in + Arg.(required & pos 0 (some string) None & info [] ~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 diff --git a/app/vmmd.ml b/app/vmmd.ml new file mode 100644 index 0000000..6a30ac6 --- /dev/null +++ b/app/vmmd.ml @@ -0,0 +1,244 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix + +let write_tls state t data = + Lwt.catch (fun () -> Vmm_tls.write_tls (fst t) data) + (fun e -> + let state', out = Vmm_engine.handle_disconnect !state t in + state := state' ; + Lwt_list.iter_s (fun (s, data) -> Vmm_lwt.write_raw s data) out >>= fun () -> + raise e) + +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) -> Vmm_lwt.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 = Unix.gettimeofday () 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))) ; + Lwt.fail e) >>= fun () -> + (match Tls_lwt.Unix.epoch (fst t) with + | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain + | `Error -> 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 () -> + (match next with + | `Create cont -> + (match cont !state t with + | Ok (state', outs, vm) -> + state := state' ; + process state outs >>= fun () -> + 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 + state := state' ; + process state outs) ; + Lwt.return_unit + | 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) ]) >>= fun () -> + Tls_lwt.Unix.close (fst t) + | `Loop (prefix, perms) -> + let rec loop () = + Vmm_tls.read_tls (fst t) >>= function + | Error (`Msg msg) -> + Logs.err (fun m -> m "reading client %a error: %s" pp_sockaddr t msg) ; + loop () + | 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 + Lwt.catch loop (fun e -> + let state', cons = Vmm_engine.handle_disconnect !state t in + state := state' ; + Lwt_list.iter_s (fun (s, data) -> Vmm_lwt.write_raw s data) cons >>= fun () -> + raise e) + | `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)) + | 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) + +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 ; + Versioned.bind_2 s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () -> + listen s 10 ; + Lwt.return s + +let init_exception () = + Lwt.async_exception_hook := (function + | Tls_lwt.Tls_failure a -> + Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) + | exn -> + Logs.err (fun m -> m "exception: %s" (Printexc.to_string exn))) + +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 + | 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 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 + | 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 + | 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 jump _ dir cacert cert priv_key = + Sys.(set_signal sigpipe Signal_ignore) ; + Lwt_main.run + (init_exception () ; + let d = Fpath.v dir in + let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.set_close_on_exec c ; + Lwt_unix.(connect c (ADDR_UNIX Fpath.(to_string (d / "cons" + "sock")))) >>= fun () -> + Lwt.catch (fun () -> + let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.set_close_on_exec s ; + Lwt_unix.(connect s (ADDR_UNIX Fpath.(to_string (d / "stat" + "sock")))) >|= fun () -> + Some s) + (function + | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return None + | e -> Lwt.fail e) >>= fun s -> + let l = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.set_close_on_exec l ; + Lwt_unix.(connect l (ADDR_UNIX Fpath.(to_string (d / "log" + "sock")))) >>= fun () -> + server_socket 1025 >>= 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 + (match Vmm_engine.init d 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) ; + 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 () -> handle ca state t) ; + 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 ()) + +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 wdir = + let doc = "Working directory (unix domain sockets, etc.)" in + Arg.(required & pos 0 (some dir) None & info [] ~doc) + +let cacert = + let doc = "CA certificate" in + Arg.(required & pos 1 (some file) None & info [] ~doc) + +let cert = + let doc = "Certificate" in + Arg.(required & pos 2 (some file) None & info [] ~doc) + +let key = + let doc = "Private key" in + Arg.(required & pos 3 (some file) None & info [] ~doc) + +let cmd = + Term.(ret (const jump $ setup_log $ wdir $ cacert $ cert $ key)), + Term.info "vmmd" ~version:"%%VERSION_NUM%%" + +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 0000000..1ff3526 --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,18 @@ +open Ocamlbuild_plugin + +let to_opt = List.fold_left (fun acc x -> [A "-ccopt"; A x] @ acc) [] +let ccopt = to_opt [ "-O3" ; "-Wall" ] + +let () = + dispatch begin function + | After_rules -> + flag ["c"; "compile"] (S ccopt) ; + flag ["link"; "library"; "ocaml"; "byte"; "use_vmm_stats"] + (S ([A "-dllib"; A "-lvmm_stats_stubs"])); + flag ["link"; "library"; "ocaml"; "native"; "use_vmm_stats"] + (S ([A "-cclib"; A "-lvmm_stats_stubs"])); + flag ["link"; "ocaml"; "link_vmm_stats"] (A "stats/libvmm_stats_stubs.a"); + dep ["link"; "ocaml"; "use_vmm_stats"] ["stats/libvmm_stats_stubs.a"]; + dep ["link"; "ocaml"; "link_vmm_stats"] ["stats/libvmm_stats_stubs.a"]; + | _ -> () + end diff --git a/opam b/opam new file mode 100644 index 0000000..21461c6 --- /dev/null +++ b/opam @@ -0,0 +1,25 @@ +opam-version: "1.2" +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.04.0"] + +depends: [ + "ocamlfind" {build} + "ocamlbuild" {build} + "topkg" {build} + "lwt" + "ipaddr" {>= "2.2.0"} + "hex" + "cstruct" + "ppx_cstruct" {build} + "logs" "rresult" "bos" "ptime" "cmdliner" "fmt" "astring" + "x509" "tls" "nocrypto" "asn1-combinators" + "duration" +] + +build: [ + [ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ] +] diff --git a/pkg/META b/pkg/META new file mode 100644 index 0000000..aa06bc0 --- /dev/null +++ b/pkg/META @@ -0,0 +1,7 @@ +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" +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 new file mode 100644 index 0000000..d786be0 --- /dev/null +++ b/pkg/pkg.ml @@ -0,0 +1,21 @@ +#!/usr/bin/env ocaml +#use "topfind" +#require "topkg" +open Topkg + +let () = + Pkg.describe "vmm" @@ 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" ; + ] diff --git a/provision/vmm_gen_ca.ml b/provision/vmm_gen_ca.ml new file mode 100644 index 0000000..738cceb --- /dev/null +++ b/provision/vmm_gen_ca.ml @@ -0,0 +1,50 @@ +(* (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_provision.ml b/provision/vmm_provision.ml new file mode 100644 index 0000000..01abb19 --- /dev/null +++ b/provision/vmm_provision.ml @@ -0,0 +1,135 @@ +(* (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 asn1_of_unix ts = + let tm = Unix.gmtime ts in + { Asn.Time.date = Unix.(tm.tm_year + 1900, (tm.tm_mon + 1), tm.tm_mday) ; + time = Unix.(tm.tm_hour, tm.tm_min, tm.tm_sec, 0.) ; + tz = None } + +let timestamps validity = + let valid = Duration.to_f validity + and now = Unix.time () + in + let start = asn1_of_unix now + and expire = asn1_of_unix (now +. valid) + in + (start, expire) + +let rec safe f arg = + try Ok (f arg) with + | Unix.Unix_error (Unix.EINTR, _, _) -> safe f arg + | Unix.Unix_error (e, _, _) -> Error (`Msg (Unix.error_message e)) + +(* TODO: is this useful elsewhere? *) +let append name data = + let open Rresult.R.Infix in + let buf = Bytes.unsafe_of_string data in + let nam = Fpath.to_string name in + safe Unix.(openfile nam [ O_APPEND ; O_CREAT ; O_WRONLY ]) 0o644 >>= fun fd -> + let len = String.length data in + let rec go off = + let l = len - off in + safe (Unix.write fd buf off) l >>= fun w -> + if l = w then Ok () + else go (w + off) + in + go 0 >>= fun () -> + safe Unix.close fd + +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 sign ?dbname ?certname extensions issuer key csr delta = + let open Rresult.R.Infix in + (match certname with + | Some x -> Ok x + | None -> + (try Ok (List.find (function `CN _ -> true | _ -> false) (X509.CA.info csr).X509.CA.subject) + with Not_found -> Error (`Msg "unable to discover certificate name")) >>= fun nam -> + 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 -> + let valid_from, valid_until = timestamps delta in + (match dbname with + | None -> Ok extensions (* evil hack to avoid issuer + public key for CA cert *) + | Some _ -> + match key with + | `RSA priv -> + let capub = `RSA (Nocrypto.Rsa.pub_of_priv priv) in + Ok (extensions @ key_ids (X509.CA.info csr).X509.CA.public_key capub)) >>= fun extensions -> + 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 -> + 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) + +let priv_key ?(bits = 2048) fn name = + let open Rresult.R.Infix in + match fn with + | None -> + let priv = `RSA (Nocrypto.Rsa.generate bits) in + Bos.OS.File.write ~mode:0o400 Fpath.(v name + "key") (Cstruct.to_string (X509.Encoding.Pem.Private_key.to_pem_cstruct1 priv)) >>= fun () -> + Ok priv + | Some fn -> + Bos.OS.File.read (Fpath.v fn) >>= fun s -> + Ok (X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string s)) + +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) + +let cacert = + let doc = "cacert" in + Arg.(required & pos 1 (some file) None & info [] ~doc) + +let key = + let doc = "Private key" in + Arg.(value & opt (some file) None & info [ "key" ] ~doc) + +let db = + let doc = "Database" in + Arg.(required & pos 0 (some string) None & info [] ~doc) + +let mem = + let doc = "Memory to provision" in + Arg.(required & pos 2 (some int) None & info [] ~doc) diff --git a/provision/vmm_req_delegation.ml b/provision/vmm_req_delegation.ml new file mode 100644 index 0000000..f7b6677 --- /dev/null +++ b/provision/vmm_req_delegation.ml @@ -0,0 +1,85 @@ +(* (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 bridges)) ] + 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 diff --git a/provision/vmm_req_permissions.ml b/provision/vmm_req_permissions.ml new file mode 100644 index 0000000..72abcc2 --- /dev/null +++ b/provision/vmm_req_permissions.ml @@ -0,0 +1,46 @@ +(* (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 diff --git a/provision/vmm_req_vm.ml b/provision/vmm_req_vm.ml new file mode 100644 index 0000000..605fb45 --- /dev/null +++ b/provision/vmm_req_vm.ml @@ -0,0 +1,70 @@ +(* (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 = + 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)) ] + 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_to_cstruct (`Ukvm_amd64, image))) ; + (false, `Unsupported (Oid.permissions, permissions_to_cstruct [ `Image ])) ; + ] @ 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 = + 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 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 cmd = + Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net)), + Term.info "vmm_req_vm" ~version:"%%VERSION_NUM%%" + +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/provision/vmm_revoke.ml b/provision/vmm_revoke.ml new file mode 100644 index 0000000..11d3f09 --- /dev/null +++ b/provision/vmm_revoke.ml @@ -0,0 +1,78 @@ +(* (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 = asn1_of_unix (Unix.time ()) 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 diff --git a/provision/vmm_sign.ml b/provision/vmm_sign.ml new file mode 100644 index 0000000..8a63eaa --- /dev/null +++ b/provision/vmm_sign.ml @@ -0,0 +1,285 @@ +(* (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 + let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct [ `Image ]) :: 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 diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml new file mode 100644 index 0000000..64c968b --- /dev/null +++ b/src/vmm_asn.ml @@ -0,0 +1,210 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Vmm_core + +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.bit_string_flags [ + 0, `All ; + 1, `Info ; + 2, `Image ; + 3, `Block ; + 4, `Statistics ; + 5, `Console ; + 6, `Log ; + 7, `Crl ; + ] + +let decode_strict codec cs = + try + let (a, cs) = Asn.decode_exn codec cs in + if Cstruct.len cs = 0 then + Ok a + else + Error (`Msg "trailing bytes") + with + | e -> Error (`Msg (Printexc.to_string e)) + +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.int +let ints_of_cstruct, ints_to_cstruct = projections_of Asn.(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) + in + Asn.map f g Asn.octet_string + +let bridge = + let f = function + | `C1 nam -> `Internal nam + | `C2 (nam, s, e, r, n) -> `External (nam, s, e, r, n) + and g = function + | `Internal nam -> `C1 nam + | `External (nam, s, e, r, n) -> `C2 (nam, s, e, r, n) + in + Asn.map f g @@ + Asn.(choice2 + (explicit 0 utf8_string) + (explicit 1 (sequence5 + (required ~label:"name" utf8_string) + (required ~label:"start" ipv4) + (required ~label:"end" ipv4) + (required ~label:"router" ipv4) + (required ~label:"netmask" int)))) + +let bridges_of_cstruct, bridges_to_cstruct = + projections_of (Asn.sequence_of bridge) + +let strings_of_cstruct, strings_to_cstruct = + projections_of Asn.(sequence_of utf8_string) + +let string_of_cstruct, string_to_cstruct = projections_of Asn.utf8_string + +let image = + let f = function + | `C1 x -> `Ukvm_amd64, x + | `C2 x -> `Ukvm_arm64, x + and g = function + | `Ukvm_amd64, x -> `C1 x + | `Ukvm_arm64, x -> `C2 x + in + Asn.map f g @@ + Asn.(choice2 + (explicit 0 octet_string) + (explicit 1 octet_string)) + +let image_of_cstruct, image_to_cstruct = projections_of image + +let permissions_of_cstruct, permissions_to_cstruct = projections_of perms + +open Rresult.R.Infix + +let req label cert oid f = + match X509.Extension.unsupported cert oid with + | None -> R.error_msgf "OID %s not present (%s)" label (Asn.OID.to_string oid) + | Some (_, data) -> f data + +let opt cert oid f = + match X509.Extension.unsupported cert oid with + | None -> Ok None + | Some (_, data) -> f data >>| fun s -> Some s + +type version = [ `AV0 ] + +let version_of_int = function + | 0 -> Ok `AV0 + | _ -> Error (`Msg "couldn't parse version") + +let version_to_int = function + | `AV0 -> 0 + +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 + in + List.fold_left add String.Map.empty xs + and cpuids = IS.of_list cpuids + 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 + in + req "crl" cert Oid.crl crl + +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 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 ; memory ; block_device ; network ; vmimage ; argv } + +let permissions_of_cert version cert = + version_of_cert version cert >>= fun () -> + req "permissions" cert Oid.permissions permissions_of_cstruct diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli new file mode 100644 index 0000000..6c290f3 --- /dev/null +++ b/src/vmm_asn.mli @@ -0,0 +1,161 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +(** ASN.1 encoding of resources and configuration *) + +(** Object Identifiers *) + +module Oid : sig + + (** {1 Object identifiers} *) + + (** OIDs in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.42) *) + + (** [version] specifies an [INTEGER] describing the version. *) + val version : Asn.OID.t + + (** {2 OIDs used in delegation certificates} *) + + (** [vms] is an [INTEGER] denoting the number of virtual machines. *) + val vms : Asn.OID.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 + + (** [block] is an [INTEGER] denoting the size of block storage available for + this delegation in MB. *) + val block : Asn.OID.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 diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml new file mode 100644 index 0000000..af1683e --- /dev/null +++ b/src/vmm_commands.ml @@ -0,0 +1,186 @@ +(* (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) 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 ; Unix.O_APPEND] + +let rec waitpid flags pid = + try Unix.waitpid flags pid with + | Unix.Unix_error (Unix.EINTR, _, _) -> waitpid flags pid + +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 e -> () + +(* own code starts here + (c) 2017 Hannes Mehnert, all rights reserved *) + +open Vmm_core + +let rec mkfifo name = + try Unix.mkfifo name 0o640 with + | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name + +let tmpfile vm suffix = + let name = filename vm in + Fpath.(v (Filename.get_temp_dir_name ()) / name + suffix) + +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 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 prepare vm = + let vmimage = tmpfile vm "img" in + (match vm.vmimage with + | `Ukvm_amd64, blob -> Ok blob + | _ -> Error (`Msg "no amd64 ukvm image found")) >>= fun image -> + Bos.OS.File.write vmimage (Cstruct.to_string image) >>= fun () -> + let fifo = tmpfile vm "fifo" 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 (Fpath.to_string 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 -> + Ok (fifo, vmimage, List.rev taps) + +let shutdown vm = + List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps >>= fun () -> + let fifo = tmpfile vm.config "fifo" in + Bos.OS.File.delete fifo >>= fun () -> + let vmimage = tmpfile vm.config "img" in + Bos.OS.File.delete vmimage + +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 dir vm fifo vmimage 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.(dir / "ukvm-bin.none") + | [_] -> Ok Fpath.(dir / "ukvm-bin.net") + | _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin -> + cpuset vm.cpuid >>= fun cpuset -> + let cmd = Bos.Cmd.(of_list cpuset % p bin %% of_list net % "--" % p vmimage %% 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 + 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) ; + Ok { config = vm ; 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 9 diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli new file mode 100644 index 0000000..8b4658b --- /dev/null +++ b/src/vmm_commands.mli @@ -0,0 +1,21 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Rresult + +open Vmm_core + +val tmpfile : vm_config -> string -> Fpath.t + +val prepare : vm_config -> (Fpath.t * Fpath.t * string list, [> R.msg ]) result + +val shutdown : vm -> (unit, [> R.msg ]) result + +val exec : Fpath.t -> vm_config -> Fpath.t -> Fpath.t -> string list -> (vm, [> R.msg ]) result + +val destroy : vm -> unit + +val close_no_err : Unix.file_descr -> unit + +val create_tap : string -> (string, [> R.msg ]) result + +val create_bridge : string -> (unit, [> R.msg ]) result diff --git a/src/vmm_core.ml b/src/vmm_core.ml new file mode 100644 index 0000000..2733db6 --- /dev/null +++ b/src/vmm_core.ml @@ -0,0 +1,376 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Astring + +open Rresult.R.Infix + +module I = struct + type t = int + let compare : int -> int -> int = compare +end + +module IS = Set.Make(I) +module IM = Map.Make(I) + +type permission = + [ `All | `Info | `Image | `Block | `Statistics | `Console | `Log | `Crl ] + +let pp_permission ppf = function + | `All -> Fmt.pf ppf "all" + | `Info -> Fmt.pf ppf "info" + | `Image -> Fmt.pf ppf "image" + | `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" + +let permission_of_string = function + | x when x = "all" -> Some `All + | x when x = "info" -> Some `Info + | x when x = "image" -> Some `Image + | 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 + | _ -> None + +type cmd = + [ `Info + | `Destroy_image + | `Create_block + | `Destroy_block + | `Statistics + | `Attach + | `Detach + | `Log + ] + +let pp_cmd ppf = function + | `Info -> Fmt.pf ppf "info" + | `Destroy_image -> 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_image + | 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_image -> `Image + | `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 ] + +let pp_vmtype ppf = function + | `Ukvm_amd64 -> Fmt.pf ppf "ukvm-amd64" + | `Ukvm_arm64 -> Fmt.pf ppf "ukvm-arm64" + +type id = string list + +let string_of_id ids = String.concat ~sep:"." ids + +let id_of_string str = String.cuts ~sep:"." str + +let drop_super ~super ~sub = + let rec go sup sub = match sup, sub with + | [], xs -> Some (List.rev xs) + | _, [] -> None + | x::xs, z::zs -> if String.equal x z then go xs zs else None + in + go (List.rev super) (List.rev sub) + +let is_sub_id ~super ~sub = + match drop_super ~super ~sub with None -> false | Some _ -> true + +let pp_id ppf ids = + Fmt.(pf ppf "%a" (list ~sep:(unit ".") string) ids) + +let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is) + +type bridge = [ + | `Internal of string + | `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int +] + +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 = { + vms : int ; + cpuids : IS.t ; + memory : int ; + block : int option ; + 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" + res.vms pp_is res.cpuids res.memory + Fmt.(option ~none:(unit "no") int) res.block + Fmt.(list ~sep:(unit ", ") pp_bridge) + (List.map snd (String.Map.bindings res.bridges)) + +let sub_bridges super sub = + String.Map.for_all (fun idx v -> + match String.Map.find idx super, v with + | None, _ -> false + | Some (`Internal nam), `Internal nam' -> String.compare nam nam' = 0 + | Some (`External (nam, supf, supl, gw, nm)), + `External (nam', subf, subl, gw', nm') -> + String.compare nam nam' = 0 && nm = nm' && + Ipaddr.V4.compare supf subf <= 0 && Ipaddr.V4.compare supl subl >= 0 + | _ -> false) + sub + +let sub_block super sub = + match super, sub with + | None, None -> true + | Some _, None -> true + | Some x, Some y -> x >= y + | None, Some _ -> false + +let sub_cpu super sub = IS.subset sub super + +let is_sub ~super ~sub = + sub.vms <= super.vms && sub_cpu super.cpuids sub.cpuids && + sub.memory <= super.memory && + sub_bridges super.bridges sub.bridges && sub_block super.block sub.block + +type vm_config = { + prefix : id ; + vname : string ; + cpuid : int ; + memory : int ; + block_device : string option ; + network : string list ; + vmimage : vmtype * Cstruct.t ; + argv : string list option ; +} + +let fullname vm = vm.prefix @ [ vm.vname ] + +let filename 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 = + Fmt.pf ppf "%s cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a" + vm.vname vm.cpuid vm.memory + Fmt.(option ~none:(unit "no") string) vm.block_device + Fmt.(list ~sep:(unit ", ") string) vm.network + pp_image vm.vmimage + Fmt.(option ~none:(unit "no") (list ~sep:(unit " ") string)) vm.argv + +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) = + res.vms >= 1 && IS.mem vm.cpuid res.cpuids && + vm.memory <= res.memory && + good_bridge vm.network res.bridges + +let check_policies vm res = + let rec climb = function + | super :: sub :: xs -> + if is_sub ~super ~sub then climb (sub :: xs) + else Error (`Msg "policy violation") + | [x] -> Ok x + | [] -> Error (`Msg "empty resource list") + in + climb res >>= fun res -> + if vm_matches_res res vm then Ok () else Error (`Msg "VM does not match policy") + +type vm = { + config : vm_config ; + cmd : Bos.Cmd.t ; + pid : int ; + taps : string list ; + stdout : Unix.file_descr (* ringbuffer thingy *) +} + +let pp_vm ppf vm = + Fmt.pf ppf "pid %d@ taps %a cmdline %a" + vm.pid Fmt.(list ~sep:(unit ", ") string) vm.taps + Bos.Cmd.pp vm.cmd + +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 ; + } + + let pp_hdr db ppf 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 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 *) + ] + + 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 %d" pid s 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 msg = hdr * event + + let pp db ppf (hdr, event) = + Fmt.pf ppf "%a %a" (pp_hdr db) hdr pp_event event +end diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml new file mode 100644 index 0000000..691e461 --- /dev/null +++ b/src/vmm_engine.ml @@ -0,0 +1,507 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Astring + +open Vmm_core + +open Rresult +open R.Infix + +type ('a, 'b) t = { + dir : Fpath.t ; + cmp : 'b -> 'b -> bool ; + console_socket : 'a ; + console_counter : int ; + console_requests : (('a, 'b) t -> ('a, 'b) 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) 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 ; *) + bridges : String.Set.t String.Map.t ; + (* TODO: used block devices (since each may only be active once) *) + resources : Vmm_resources.t ; + crls : X509.CRL.c list ; +} + +let init dir cmp console_socket stats_socket log_socket = + (* error hard on permission denied etc. *) + let crls = Fpath.(dir / "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 []) + Fpath.(dir / "crls") >>= fun crls -> + crls >>= fun crls -> + Ok { + dir ; 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 = `WV0 ; + log_socket ; log_counter = 1 ; log_attached = String.Map.empty ; + log_version = `WV0 ; log_requests = IM.empty ; + client_version = `WV0 ; + bridges = String.Map.empty ; + resources = Vmm_resources.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 prefix chain cert = + Logs.debug (fun m -> m "starting with vms %a" Vmm_resources.pp t.resources) ; + (* convert certificate to vm_config *) + Vmm_asn.vm_of_cert prefix cert >>= fun vm_config -> + Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ; + (* check whether vm with same name is already running *) + 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 () -> + (* 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 res -> + (* check static policies *) + Logs.debug (fun m -> m "now checking static policies") ; + check_policies vm_config (List.map snd res) >>= fun () -> + (* check dynamic usage *) + Logs.debug (fun m -> m "now checking dynamic policies") ; + Vmm_resources.check_dynamic t.resources vm_config res >>= fun resource_usage -> + (* prepare VM: save VM image to disk, create fifo, ... *) + Vmm_commands.prepare vm_config >>= fun (fifo, vmimage, taps) -> + Logs.debug (fun m -> m "prepared vm %a" Fpath.pp vmimage) ; + Ok (filename vm_config, + fun t s -> + (* actually execute the vm *) + Vmm_commands.exec t.dir vm_config fifo vmimage taps >>= fun vm -> + Logs.debug (fun m -> m "exec()ed vm") ; + Vmm_resources.insert t.resources full vm >>= fun resources -> + Logs.debug (fun m -> m "%a" Vmm_resources.pp resources) ; + let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version vm.pid vm.taps in + let 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.bridges vm_config.network taps + in + let t = { t with resources ; stats_counter = succ t.stats_counter ; bridges } in + let t, out = log t (Log.hdr 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) :: stat t stat_out @ out, vm)) + +let handle_shutdown t vm r = + (match Vmm_commands.shutdown vm with + | Ok () -> () + | Error (`Msg e) -> Logs.warn (fun m -> m "%s during shutdown" e)) ; + let resources = + match Vmm_resources.remove t.resources (fullname vm.config) vm with + | Ok resources -> + Logs.debug (fun m -> m "shut down: %a" Vmm_resources.pp resources) ; + resources + | Error (`Msg e) -> + Logs.warn (fun m -> m "%s while removing vm" e) ; + t.resources + in + let 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.bridges vm.config.network vm.taps + in + let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version vm.pid in + let t = { t with stats_counter = succ t.stats_counter ; resources ; bridges } 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 + match x with + | `Info -> + Logs.debug (fun m -> m "resources are %a" Vmm_resources.pp t.resources) ; + 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_image -> + 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) from client, instead of hardcoding Ptime.epoch below *) + let name = String.concat ~sep:"." arg in + let on_success t = + let cons = Vmm_wire.Console.history t.console_counter t.console_version name Ptime.epoch in + let old = match String.Map.find name 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 name 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 name 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 name = String.concat ~sep:"." arg in + let cons = Vmm_wire.Console.detach t.console_counter t.console_version name in + (match String.Map.find name t.console_attached with + | None -> Error (`Msg "not attached") + | Some x when t.cmp x s -> Ok (String.Map.remove name 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 vm.Vmm_core.pid in + let stats_requests = IM.add t.stats_counter (s, hdr.Vmm_wire.id) 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 + | _ -> 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 = + match String.Map.find (string_of_id prefix) 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 (string_of_id prefix) 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.to_float_s (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 > .this_update, number > .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 x, 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 / *) + let filename = Fpath.(t.dir / "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 x -> 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 t, out = log t (Log.hdr prefix (id leaf), `Login addr) in + Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms -> + if List.mem `Image perms && Vmm_asn.contains_vm leaf then + handle_create t prefix chain leaf >>= fun (file, cont) -> + let cons = Vmm_wire.Console.add t.console_counter t.console_version file in + Ok ({ t with console_counter = succ t.console_counter }, + `Raw (t.console_socket, cons) :: out, + `Create cont) + 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 }, + out, + `Loop (prefix, perms)) + +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) -> + 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.StatReply -> + let out = Client.stat data req_id state.client_version in + [ `Tls (s, out) ] + | 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.err (fun m -> m "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, [] diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml new file mode 100644 index 0000000..81836d1 --- /dev/null +++ b/src/vmm_lwt.ml @@ -0,0 +1,56 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix + +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 +| Unix.WSTOPPED s -> Fmt.pf ppf "stopped by signal %a" Fmt.Dump.signal s + +let ret = function + | Unix.WEXITED c -> `Exit c + | Unix.WSIGNALED s -> `Signal s + | Unix.WSTOPPED s -> `Stop s + +let wait_and_clear pid stdout = + let open Lwt.Infix in + Lwt_unix.waitpid [] pid >>= fun (_, s) -> + Logs.debug (fun m -> m "pid %d exited: %a" pid pp_process_status s) ; + Vmm_commands.close_no_err stdout ; + Lwt.return (ret s) + +let read_exactly s = + let buf = Bytes.create 8 in + let rec r b i l = + Lwt_unix.read s b i l >>= function + | 0 -> Lwt.fail_with "end of file" + | n when n == l -> Lwt.return_unit + | n when n < l -> r b (i + n) (l - n) + | _ -> Lwt.fail_with "read too much" + in + r buf 0 8 >>= fun () -> + 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 >|= fun () -> + 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, "")) + +let write_raw s buf = + let buf = Bytes.unsafe_of_string buf in + let rec w off l = + Lwt_unix.send s buf off l [] >>= fun n -> + if n = l then + Lwt.return_unit + else + w (off + n) (l - n) + in + Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; + w 0 (Bytes.length buf) diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml new file mode 100644 index 0000000..fd8ae6d --- /dev/null +++ b/src/vmm_resources.ml @@ -0,0 +1,125 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Astring +open Rresult.R.Infix + +open Vmm_core + +type res_entry = { + vms : int ; + memory : int ; +} + +let pp_res_entry ppf res = + Fmt.pf ppf "%d vms %d memory" res.vms res.memory + +let empty_res = { vms = 0 ; memory = 0 } + +let check_resource (policy : delegation) (vm : vm_config) (res : res_entry) = + succ res.vms <= policy.vms && res.memory + vm.memory <= policy.memory + +let add (vm : vm) (res : res_entry) = + { vms = succ res.vms ; memory = vm.config.memory + res.memory } + +let rem (vm : vm) (res : res_entry) = + { vms = pred res.vms ; memory = res.memory - vm.config.memory } + +type entry = + | Leaf of vm + | Subtree of res_entry * entry String.Map.t + +type t = entry String.Map.t + +let empty = String.Map.empty + +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 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 pp ppf map = + Fmt.pf ppf "%a" + Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry)) + (String.Map.bindings map) + +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 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 + | _ -> None + +let rec iter f = function + | Leaf vm -> f vm + | Subtree (_, m) -> List.iter (fun (_, e) -> iter f e) (String.Map.bindings m) + +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 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 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 diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli new file mode 100644 index 0000000..697b778 --- /dev/null +++ b/src/vmm_resources.mli @@ -0,0 +1,56 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +(** A tree data structure tracking dynamic resource usage. + + Considering delegation of resources to someone, and further delegation + to others - using a process which is not controlled by the authority - + requires runtime tracking of these delegations and the actual usage: + + If Alice may create 2 virtual machines, and she delegates the same + capability further to both Bob and Charlie, the authority must still enforce + that Alice, Bob, and Charlie are able to run 2 virtual machines in total, + rather than 2 each. *) + +(** 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 + +(** [fold f entry acc] folds [f] over [entry]. *) +val fold : ('a -> Vmm_core.vm -> 'a) -> 'a -> entry -> 'a + +(** [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 + +(** [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 diff --git a/src/vmm_ring.ml b/src/vmm_ring.ml new file mode 100644 index 0000000..55ef7e3 --- /dev/null +++ b/src/vmm_ring.ml @@ -0,0 +1,38 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +(* a ring buffer with N strings, dropping old ones *) + +type t = { + data : (Ptime.t * string) array ; + mutable write : int ; + size : int ; +} + +let create ?(size = 1024) () = + { data = Array.make 1024 (Ptime.min, "") ; write = 0 ; size } + +let inc t = (succ t.write) mod t.size + +let write t v = + Array.set t.data t.write v ; + t.write <- inc t + +let dec t n = (pred n + t.size) mod t.size + +let earlier ts than = + if ts = Ptime.min then true + else Ptime.is_earlier ts ~than + +let read_history t than = + let rec go s acc idx = + if idx = s then (* don't read it twice *) + acc + else + let ts, v = Array.get t.data idx in + if earlier ts than then acc + else go s ((ts, v) :: acc) (dec t idx) + in + let idx = dec t t.write in + let ts, v = Array.get t.data idx in + if earlier ts than then [] + else go idx [(ts,v)] (dec t idx) diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml new file mode 100644 index 0000000..656d45f --- /dev/null +++ b/src/vmm_tls.ml @@ -0,0 +1,35 @@ +(* (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_unit + else + Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function + | 0 -> Lwt.fail_with "read 0 bytes" + | x when x == l -> Lwt.return_unit + | x when x < l -> r_n buf (off + x) tot + | _ -> Lwt.fail_with "overread, will never happen" + in + let buf = Cstruct.create 8 in + r_n buf 0 8 >>= fun () -> + 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 >|= fun () -> + 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) + else + Lwt.return (Ok (hdr, "")) + +let write_tls s buf = + Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; + Tls_lwt.Unix.write s (Cstruct.of_string buf) diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml new file mode 100644 index 0000000..615bcce --- /dev/null +++ b/src/vmm_wire.ml @@ -0,0 +1,662 @@ +(* (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 ] + +let version_to_int = function + | `WV0 -> 0 + +let version_of_int = function + | 0 -> Ok `WV0 + | _ -> Error (`Msg "unknown wire version") + +let version_eq a b = match a, b with + | `WV0, `WV0 -> true + +let pp_version ppf v = + Fmt.string ppf (match v with + | `WV0 -> "wire version 0") + +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 + | Attach + | Detach + | 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 name + + let attach id v name = encode id v Attach name + + let detach id v name = encode id v Detach 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 + | Statistics + | StatReply + [@@uint16_t] + ] + + let encode id version op ?payload pid = + let pid = encode_pid pid in + let length, p = + match payload with + | None -> 4, empty + | Some x -> 4 + Cstruct.len x, x + and tag = op_to_int op + in + let r = + Cstruct.concat [ create_header { length ; version ; id ; tag } ; pid ; 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_exact 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 pid taps = + let payload = encode_strings taps in + encode id v Add ~payload pid + + let remove id v pid = encode id v Remove pid + + let stat id v pid = encode id v Statistics pid + + let stat_reply id version payload = + let length = Cstruct.len payload + and tag = op_to_int StatReply + in + let r = + Cstruct.append (create_header { length ; id ; version ; tag }) payload + in + Cstruct.to_string r + + let encode_stats (ru, ifd) = + Cstruct.concat + (encode_rusage ru :: List.map encode_ifdata ifd) + + let decode_stats cs = + check_len cs 144 >>= fun () -> + let ru, ifd = Cstruct.split cs 144 in + decode_rusage ru >>= fun ru -> + let rec go acc buf = + if Cstruct.len buf = 0 then + Ok (List.rev acc) + else + decode_ifdata buf >>= fun (this, used) -> + go (this :: acc) (Cstruct.shift buf used) + in + go [] ifd >>= fun ifs -> + Ok (ru, 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_image -> 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_image + | 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 diff --git a/stats/libvmm_stats_stubs.clib b/stats/libvmm_stats_stubs.clib new file mode 100644 index 0000000..209b378 --- /dev/null +++ b/stats/libvmm_stats_stubs.clib @@ -0,0 +1 @@ +vmm_stats_stubs.o diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml new file mode 100644 index 0000000..a095d3d --- /dev/null +++ b/stats/vmm_stats.ml @@ -0,0 +1,126 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Astring + +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" + +let my_version = `WV0 + +type t = { + pid_nic : (int * string) list IM.t ; + pid_rusage : rusage IM.t ; + old_pid_rusage : rusage IM.t ; + nic_ifdata : ifdata String.Map.t ; + old_nic_ifdata : ifdata String.Map.t ; +} + +let empty () = + { pid_nic = IM.empty ; + pid_rusage = IM.empty ; nic_ifdata = String.Map.empty ; + old_pid_rusage = IM.empty ; old_nic_ifdata = String.Map.empty } + +let rec safe_sysctl f arg = + try Some (f arg) with + | Unix.Unix_error (Unix.EINTR, _, _) -> safe_sysctl f arg + | _ -> None + +let gather pid nics = + safe_sysctl sysctl_rusage pid, + List.fold_left (fun ifd (nic, _) -> + match safe_sysctl sysctl_ifdata nic with + | None -> ifd + | Some data -> String.Map.add data.name data ifd) + String.Map.empty nics + +let tick t = + let pid_rusage, nic_ifdata = + IM.fold (fun pid nics (rus, ifds) -> + let ru, ifd = gather pid nics in + (match ru with + | None -> rus + | Some ru -> IM.add pid ru rus), + String.Map.union (fun _k a _b -> Some a) ifd ifds) + t.pid_nic (IM.empty, String.Map.empty) + in + let old_pid_rusage, old_nic_ifdata = t.pid_rusage, t.nic_ifdata in + { t with pid_rusage ; nic_ifdata ; old_pid_rusage ; old_nic_ifdata } + +let add_pid t pid nics = + match safe_sysctl sysctl_ifcount () with + | None -> Error (`Msg "sysctl ifcount failed") + | Some max_nic -> + let rec go cnt acc id = + if id > 0 && cnt > 0 then + match safe_sysctl 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 + let nic_ids = go (List.length nics) [] max_nic in + let pid_nic = IM.add pid nic_ids t.pid_nic in + let ru, ifd = gather pid nic_ids in + (match ru with + | None -> () + | Some ru -> Logs.info (fun m -> m "RU %a" pp_rusage ru)) ; + Logs.info (fun m -> m "interfaces: %a" Fmt.(list ~sep:(unit ",@ ") pp_ifdata) (snd (List.split (String.Map.bindings ifd)))) ; + Ok { t with pid_nic } + +(* TODO: we can now compute deltas: t contains also old ru & ifdata *) +let stats t pid = + try + let nics = IM.find pid t.pid_nic in + let ru = IM.find pid t.pid_rusage 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, ifd) + with + | _ -> Error (`Msg "failed to find resource usage") + +let remove_pid t pid = + (* can this err? -- do I care? *) + let pid_nic = IM.remove pid t.pid_nic in + { t with pid_nic } + +open Rresult.R.Infix + +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 + match int_to_op hdr.tag with + | Some Add -> + decode_pid_taps cs >>= fun (pid, taps) -> + add_pid t pid taps >>= fun t -> + Ok (t, success ~msg:"added" hdr.id my_version) + | Some Remove -> + decode_pid cs >>= fun pid -> + let t = remove_pid t pid in + Ok (t, success ~msg:"removed" hdr.id my_version) + | Some Statistics -> + decode_pid cs >>= fun pid -> + stats t pid >>= fun s -> + Ok (t, stat_reply hdr.id my_version (encode_stats s)) + | _ -> Error (`Msg "unknown command") + in + match r with + | Ok (t, out) -> t, out + | Error (`Msg msg) -> + Logs.err (fun m -> m "error while processing %s" msg) ; + t, fail ~msg hdr.id my_version diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml new file mode 100644 index 0000000..02378c6 --- /dev/null +++ b/stats/vmm_stats_lwt.ml @@ -0,0 +1,78 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +(* the process responsible for gathering statistics (CPU + mem + network) *) + +(* a shared unix domain socket between vmmd and vmm_stats is used as + communication channel, where the vmmd can issue commands: + + - add pid taps + - remove pid + - statistics pid + + every 5 minutes, statistics of all registered pids are recorded. `statistics` + reports last recorded stats *) + +open Lwt.Infix + +let t = ref (Vmm_stats.empty ()) + +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 s addr () = + Logs.info (fun m -> m "handling stats 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 () + | Ok (hdr, data) -> + Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp (Cstruct.of_string data)) ; + let t', out = Vmm_stats.handle !t hdr data in + t := t' ; + Logs.debug (fun m -> m "sent %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ; + Vmm_lwt.write_raw s out >>= fun () -> + loop () + in + loop () + +let rec timer () = + t := Vmm_stats.tick !t ; + Lwt_unix.sleep Duration.(to_f (of_min 5)) >>= fun () -> + timer () + +let jump _ file = + Sys.(set_signal sigpipe Signal_ignore) ; + Lwt_main.run + (let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.(Versioned.bind_2 s (ADDR_UNIX file)) >>= fun () -> + Lwt_unix.listen s 1 ; + Lwt.async timer ; + 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 onto" in + Arg.(value & pos 0 string "" & info [] ~doc) + +let cmd = + Term.(ret (const jump $ setup_log $ socket)), + Term.info "vmm_stats" ~version:"%%VERSION_NUM%%" + +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/stats/vmm_stats_stubs.c b/stats/vmm_stats_stubs.c new file mode 100644 index 0000000..fc564e3 --- /dev/null +++ b/stats/vmm_stats_stubs.c @@ -0,0 +1,152 @@ +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#include +#include + +#ifdef __FreeBSD__ +#include +#endif + +#define Val32 caml_copy_int32 +#define Val64 caml_copy_int64 + +#ifdef __FreeBSD__ +CAMLprim value vmmanage_sysctl_rusage (value pid_r) { + CAMLparam1(pid_r); + CAMLlocal3(res, utime, stime); + int name[4]; + int error; + size_t len; + struct kinfo_proc p; + struct rusage ru; + + len = sizeof(p); + name[0] = CTL_KERN; + name[1] = KERN_PROC; + name[2] = KERN_PROC_PID; + name[3] = Int_val(pid_r); + + error = sysctl(name, nitems(name), &p, &len, NULL, 0); + if (error < 0) + uerror("sysctl", Nothing); + + if (ru.ru_utime.tv_usec < 0 || ru.ru_utime.tv_usec > 999999999 || + ru.ru_stime.tv_usec < 0 || ru.ru_stime.tv_usec > 999999999) + uerror("sysctl", Nothing); + + ru = p.ki_rusage; + utime = caml_alloc(2, 0); + Store_field (utime, 0, Val64(ru.ru_utime.tv_sec)); + Store_field (utime, 1, Val_int(ru.ru_utime.tv_usec)); + stime = caml_alloc(2, 0); + Store_field (stime, 0, Val64(ru.ru_stime.tv_sec)); + Store_field (stime, 1, Val_int(ru.ru_stime.tv_usec)); + res = caml_alloc(16, 0); + Store_field (res, 0, utime); + Store_field (res, 1, stime); + Store_field (res, 2, Val64(ru.ru_maxrss)); + Store_field (res, 3, Val64(ru.ru_ixrss)); + Store_field (res, 4, Val64(ru.ru_idrss)); + Store_field (res, 5, Val64(ru.ru_isrss)); + Store_field (res, 6, Val64(ru.ru_minflt)); + Store_field (res, 7, Val64(ru.ru_majflt)); + Store_field (res, 8, Val64(ru.ru_nswap)); + Store_field (res, 9, Val64(ru.ru_inblock)); + Store_field (res, 10, Val64(ru.ru_oublock)); + Store_field (res, 11, Val64(ru.ru_msgsnd)); + Store_field (res, 12, Val64(ru.ru_msgrcv)); + Store_field (res, 13, Val64(ru.ru_nsignals)); + Store_field (res, 14, Val64(ru.ru_nvcsw)); + Store_field (res, 15, Val64(ru.ru_nivcsw)); + + CAMLreturn(res); +} + +CAMLprim value vmmanage_sysctl_ifcount (value unit) { + CAMLparam1(unit); + int data = 0; + size_t dlen = 0; + int name[5]; + + name[0] = CTL_NET; + name[1] = PF_LINK; + name[2] = NETLINK_GENERIC; + name[3] = IFMIB_SYSTEM; + name[4] = IFMIB_IFCOUNT; + dlen = sizeof(data); + + if (sysctl(name, nitems(name), &data, &dlen, NULL, 0) != 0) + uerror("sysctl", Nothing); + + CAMLreturn(Val_long(data)); +} + +CAMLprim value vmmanage_sysctl_ifdata (value num) { + CAMLparam1(num); + CAMLlocal1(res); + size_t datalen; + int name[6]; + struct ifmibdata data; + + name[0] = CTL_NET; + name[1] = PF_LINK; + name[2] = NETLINK_GENERIC; + name[3] = IFMIB_IFDATA; + name[4] = Int_val(num); + name[5] = IFDATA_GENERAL; + datalen = sizeof(data); + + if (sysctl(name, nitems(name), &data, &datalen, NULL, 0) != 0) + uerror("sysctl", Nothing); + + res = caml_alloc(18, 0); + Store_field(res, 0, caml_copy_string(data.ifmd_name)); + Store_field(res, 1, Val32(data.ifmd_flags)); + Store_field(res, 2, Val32(data.ifmd_snd_len)); + Store_field(res, 3, Val32(data.ifmd_snd_maxlen)); + Store_field(res, 4, Val32(data.ifmd_snd_drops)); + Store_field(res, 5, Val32(data.ifmd_data.ifi_mtu)); + Store_field(res, 6, Val64(data.ifmd_data.ifi_baudrate)); + Store_field(res, 7, Val64(data.ifmd_data.ifi_ipackets)); + Store_field(res, 8, Val64(data.ifmd_data.ifi_ierrors)); + Store_field(res, 9, Val64(data.ifmd_data.ifi_opackets)); + Store_field(res, 10, Val64(data.ifmd_data.ifi_oerrors)); + Store_field(res, 11, Val64(data.ifmd_data.ifi_collisions)); + Store_field(res, 12, Val64(data.ifmd_data.ifi_ibytes)); + Store_field(res, 13, Val64(data.ifmd_data.ifi_obytes)); + Store_field(res, 14, Val64(data.ifmd_data.ifi_imcasts)); + Store_field(res, 15, Val64(data.ifmd_data.ifi_omcasts)); + Store_field(res, 16, Val64(data.ifmd_data.ifi_iqdrops)); + Store_field(res, 17, Val64(data.ifmd_data.ifi_oqdrops)); + + CAMLreturn(res); +} +#else /* FreeBSD */ + +/* stub symbols for OS currently not supported */ + +CAMLprim value vmmanage_sysctl_rusage (value pid_r) { + CAMLparam1(pid_r); + uerror("sysctl", Nothing); +} + +CAMLprim value vmmanage_sysctl_ifcount (value unit) { + CAMLparam1(unit); + uerror("sysctl", Nothing); +} + +CAMLprim value vmmanage_sysctl_ifdata (value num) { + CAMLparam1(num); + uerror("sysctl", Nothing); +} + +#endif