From 9ec69e23ccf51b42f5cf8918b7e0cf5a6ca423bb Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 7 Jul 2018 23:14:42 +0200 Subject: [PATCH 01/73] rename Vmm_commands to Vmm_unix --- src/vmm_engine.ml | 12 ++++++------ src/vmm_lwt.ml | 2 +- src/{vmm_commands.ml => vmm_unix.ml} | 0 src/{vmm_commands.mli => vmm_unix.mli} | 0 4 files changed, 7 insertions(+), 7 deletions(-) rename src/{vmm_commands.ml => vmm_unix.ml} (100%) rename src/{vmm_commands.mli => vmm_unix.mli} (100%) diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 3456b9b..2e7d6f7 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -119,11 +119,11 @@ let handle_create t vm_config policies = Logs.debug (fun m -> m "now checking dynamic policies") ; Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () -> (* prepare VM: save VM image to disk, create fifo, ... *) - Vmm_commands.prepare vm_config >>= fun taps -> + Vmm_unix.prepare vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; Ok (fun t s -> (* actually execute the vm *) - Vmm_commands.exec vm_config taps >>= fun vm -> + Vmm_unix.exec vm_config taps >>= fun vm -> Logs.debug (fun m -> m "exec()ed vm") ; Vmm_resources.insert t.resources full vm >>= fun resources -> let used_bridges = @@ -146,7 +146,7 @@ let setup_stats t vm = Ok (t, stat t stat_out) let handle_shutdown t vm r = - (match Vmm_commands.shutdown vm with + (match Vmm_unix.shutdown vm with | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; let resources = @@ -202,7 +202,7 @@ let handle_command t s prefix perms hdr buf = | Destroy_vm -> begin match Vmm_resources.find_vm t.resources arg with | Some vm -> - Vmm_commands.destroy vm ; + Vmm_unix.destroy vm ; let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in Ok (t, [ `Tls (s, out) ]) | _ -> @@ -269,7 +269,7 @@ 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) ; + | Some e -> Vmm_resources.iter Vmm_unix.destroy e) ; (* also revoke all active sessions!? *) (* TODO: maybe we need a vmm_resources like structure for sessions as well!? *) let log_attached, kill = @@ -391,7 +391,7 @@ let handle_initial t s addr chain ca = pp_id (fullname vm_config) fid) | Some vm -> Logs.debug (fun m -> m "killing %a now" pp_vm vm) ; - Vmm_commands.destroy vm + Vmm_unix.destroy vm in let tasks = String.Map.remove fid t.tasks in ({ t with tasks }, Some (kill, task)) diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml index eda2463..bfaff67 100644 --- a/src/vmm_lwt.ml +++ b/src/vmm_lwt.ml @@ -27,7 +27,7 @@ let rec waitpid pid = let wait_and_clear pid stdout = Logs.debug (fun m -> m "waitpid() for pid %d" pid) ; waitpid pid >|= fun r -> - Vmm_commands.close_no_err stdout ; + Vmm_unix.close_no_err stdout ; match r with | Error () -> Logs.err (fun m -> m "waitpid() for %d returned error" pid) ; diff --git a/src/vmm_commands.ml b/src/vmm_unix.ml similarity index 100% rename from src/vmm_commands.ml rename to src/vmm_unix.ml diff --git a/src/vmm_commands.mli b/src/vmm_unix.mli similarity index 100% rename from src/vmm_commands.mli rename to src/vmm_unix.mli From bd102092978f85b3329ebc16a8c2d7b88b7d4162 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 9 Sep 2018 20:52:04 +0200 Subject: [PATCH 02/73] wip, vmmc and vmmd talk with each other! --- .merlin | 2 +- _tags | 1 - app/vmm_client.ml | 2 +- app/vmm_console.ml | 69 ++-- app/vmm_influxdb_stats.ml | 97 +++--- app/vmm_log.ml | 257 +++++++++----- app/vmm_tls_endpoint.ml | 172 +++++++++ app/vmmc.ml | 264 ++++++++++++++ app/vmmd.ml | 367 +++++++------------ opam | 1 - pkg/pkg.ml | 6 +- src/vmm_asn.ml | 5 +- src/vmm_commands.ml | 223 ++++++++++++ src/vmm_core.ml | 26 +- src/vmm_engine.ml | 584 +++++-------------------------- src/vmm_lwt.ml | 35 +- src/vmm_tls.ml | 8 +- src/vmm_wire.ml | 716 +++++++++++++++++++++----------------- src/vmm_x509.ml | 163 +++++++++ stats/vmm_stats.ml | 11 +- stats/vmm_stats_lwt.ml | 8 +- 21 files changed, 1746 insertions(+), 1271 deletions(-) create mode 100644 app/vmm_tls_endpoint.ml create mode 100644 app/vmmc.ml create mode 100644 src/vmm_commands.ml create mode 100644 src/vmm_x509.ml diff --git a/.merlin b/.merlin index 3014a5d..d00b855 100644 --- a/.merlin +++ b/.merlin @@ -5,6 +5,6 @@ S provision B _build/** -PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex cstruct.ppx duration +PKG topkg logs ipaddr x509 tls rresult bos lwt cmdliner hex duration PKG ptime ptime.clock.os ipaddr.unix decompress PKG lwt.unix \ No newline at end of file diff --git a/_tags b/_tags index 8b1a4c8..fe13147 100644 --- a/_tags +++ b/_tags @@ -4,7 +4,6 @@ true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring "src" : include : package(decompress) -: package(ppx_cstruct) : package(asn1-combinators) : package(lwt lwt.unix) : package(lwt tls.lwt) diff --git a/app/vmm_client.ml b/app/vmm_client.ml index acd7cc7..46b5485 100644 --- a/app/vmm_client.ml +++ b/app/vmm_client.ml @@ -4,7 +4,7 @@ open Lwt.Infix open Vmm_core -let my_version = `WV0 +let my_version = `WV2 let command = ref 1 let process db hdr data = diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 055efa5..65e4563 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -13,21 +13,14 @@ 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 my_version = `WV2 let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e) let active = ref String.Map.empty let read_console name ring channel () = + let id = Vmm_core.id_of_string name in Lwt.catch (fun () -> let rec loop () = Lwt_io.read_line channel >>= fun line -> @@ -37,8 +30,10 @@ let read_console name ring channel () = (match String.Map.find name !active with | None -> Lwt.return_unit | Some fd -> - Vmm_lwt.write_raw fd (data my_version name t line) >>= function - | Error _ -> Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) + Vmm_lwt.write_wire fd (Vmm_wire.Console.data my_version id t line) >>= function + | Error _ -> + Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >|= fun () -> + active := String.Map.remove name !active | Ok () -> Lwt.return_unit) >>= loop in @@ -70,7 +65,8 @@ let open_fifo name = let t = ref String.Map.empty -let add_fifo name = +let add_fifo id = + let name = Vmm_core.string_of_id id in open_fifo name >|= function | Some f -> let ring = Vmm_ring.create () in @@ -82,63 +78,68 @@ let add_fifo name = | None -> Error (`Msg "opening") -let attach s name = - Logs.debug (fun m -> m "attempting to attach %s" name) ; +let attach s id = + let name = Vmm_core.string_of_id id in + Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ; match String.Map.find name !t with | None -> Lwt.return (Error (`Msg "not found")) | Some _ -> active := String.Map.add name s !active ; Lwt.return (Ok "attached") -let detach name = +let detach id = + let name = Vmm_core.string_of_id id in active := String.Map.remove name !active ; Lwt.return (Ok "removed") let history s name since = - match String.Map.find name !t with - | None -> Lwt.return (Rresult.R.error_msgf "ring %s not found (%d): %a" - name (String.Map.cardinal !t) + match String.Map.find (Vmm_core.string_of_id name) !t with + | None -> Lwt.return (Rresult.R.error_msgf "ring %a not found (%d): %a" + Vmm_core.pp_id name (String.Map.cardinal !t) Fmt.(list ~sep:(unit ";") string) (List.map fst (String.Map.bindings !t))) | Some r -> let entries = Vmm_ring.read_history r since in Logs.debug (fun m -> m "found %d history" (List.length entries)) ; Lwt_list.iter_s (fun (i, v) -> - Vmm_lwt.write_raw s (data my_version name i v) >|= fun _ -> ()) + Vmm_lwt.write_wire s (Vmm_wire.Console.data my_version name i v) >|= fun _ -> ()) entries >|= fun () -> Ok "success" let handle s addr () = - Logs.info (fun m -> m "handling connection %a" pp_sockaddr addr) ; + Logs.info (fun m -> m "handling connection %a" Vmm_lwt.pp_sockaddr addr) ; let rec loop () = - Vmm_lwt.read_exactly s >>= function + Vmm_lwt.read_wire s >>= function | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit + | Ok (hdr, _) when Vmm_wire.is_reply hdr -> + Logs.err (fun m -> m "unexpected reply") ; + loop () | Ok (hdr, data) -> - (if not (version_eq hdr.version my_version) then + (if not (Vmm_wire.version_eq hdr.version my_version) then Lwt.return (Error (`Msg "ignoring data with bad version")) else - match decode_str data with + match Vmm_wire.decode_strings data with | Error e -> Lwt.return (Error e) - | Ok (name, off) -> - match Console.int_to_op hdr.tag with - | Some Add_console -> add_fifo name - | Some Attach_console -> attach s name - | Some Detach_console -> detach name - | Some History -> - (match decode_ts ~off data with + | Ok (id, off) -> match Vmm_wire.Console.int_to_op hdr.tag with + | Some Vmm_wire.Console.Add_console -> add_fifo id + | Some Vmm_wire.Console.Attach_console -> attach s id + | Some Vmm_wire.Console.Detach_console -> detach id + | Some Vmm_wire.Console.History -> + (match Vmm_wire.decode_ptime ~off data with | Error e -> Lwt.return (Error e) - | Ok since -> history s name since) - | _ -> + | Ok since -> history s id since) + | Some Vmm_wire.Console.Data -> Lwt.return (Error (`Msg "unexpected Data")) + | None -> Lwt.return (Error (`Msg "unknown command"))) >>= (function - | Ok msg -> Vmm_lwt.write_raw s (success ~msg hdr.id my_version) + | Ok msg -> Vmm_lwt.write_wire s (Vmm_wire.success ~msg my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag) | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; - Vmm_lwt.write_raw s (fail ~msg hdr.id my_version)) >>= function + Vmm_lwt.write_wire s (Vmm_wire.fail ~msg my_version hdr.Vmm_wire.id)) >>= function | Ok () -> loop () | Error _ -> Logs.err (fun m -> m "exception while writing to socket") ; diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index 8a3c89d..a13450c 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -142,9 +142,9 @@ end let my_version = `WV1 -let command = ref 1 +let command = ref 1L -let (req : string IM.t ref) = ref IM.empty +let (req : string IM64.t ref) = ref IM64.empty let str_of_e = function | `Eof -> "end of file" @@ -192,54 +192,53 @@ let rec read_sock_write_tcp closing db c ?fd addr addrtype = else begin let open Vmm_wire in Logs.debug (fun m -> m "reading from unix socket") ; - Vmm_lwt.read_exactly c >>= function + Vmm_lwt.read_wire c >>= function | Error e -> Logs.err (fun m -> m "error %s while reading vmm socket (return)" (str_of_e e)) ; closing := true ; safe_close fd | Ok (hdr, data) -> - if not (version_eq hdr.version my_version) then begin - Logs.err (fun m -> m "unknown wire protocol version") ; - closing := true ; - safe_close fd - end else - let name = - try IM.find hdr.id !req - with Not_found -> "not found" - in - req := IM.remove hdr.id !req ; - begin match Stats.int_to_op hdr.tag with - | Some Stats.Stat_reply -> - begin match Vmm_wire.Stats.decode_stats (Cstruct.of_string data) with - | Error (`Msg msg) -> - Logs.warn (fun m -> m "error %s while decoding stats %s, ignoring" - msg name) ; - Lwt.return (Some fd) - | Ok (ru, vmm, ifs) -> - let ru = P.encode_ru name ru in - let vmm = P.encode_vmm name vmm in - let taps = List.map (P.encode_if name) ifs in - let out = (String.concat ~sep:"\n" (ru :: vmm :: taps)) ^ "\n" in - Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ; - Vmm_lwt.write_raw fd out >>= function - | Ok () -> - Logs.debug (fun m -> m "wrote successfully") ; - Lwt.return (Some fd) - | Error e -> - Logs.err (fun m -> m "error %s while writing to tcp (%s)" - (str_of_e e) name) ; - safe_close fd >|= fun () -> - None - end - | _ when hdr.tag = fail_tag -> - Logs.err (fun m -> m "failed to retrieve statistics for %s" name) ; - Lwt.return (Some fd) - | _ -> - Logs.err (fun m -> m "unhandled tag %d for %s" hdr.tag name) ; - Lwt.return (Some fd) - end >>= fun fd -> - read_sock_write_tcp closing db c ?fd addr addrtype + let name = + try IM64.find hdr.id !req + with Not_found -> "not found" + in + req := IM64.remove hdr.id !req ; + (if not (version_eq hdr.version my_version) then begin + Logs.err (fun m -> m "unknown wire protocol version") ; + closing := true ; + safe_close fd >|= fun () -> + None + end else if Vmm_wire.is_fail hdr then begin + Logs.err (fun m -> m "failed to retrieve statistics for %s" name) ; + Lwt.return (Some fd) + end else if Vmm_wire.is_reply hdr then + begin match Vmm_wire.Stats.decode_stats data with + | Error (`Msg msg) -> + Logs.warn (fun m -> m "error %s while decoding stats %s, ignoring" + msg name) ; + Lwt.return (Some fd) + | Ok (ru, vmm, ifs) -> + let ru = P.encode_ru name ru in + let vmm = P.encode_vmm name vmm in + let taps = List.map (P.encode_if name) ifs in + let out = (String.concat ~sep:"\n" (ru :: vmm :: taps)) ^ "\n" in + Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ; + Vmm_lwt.write_wire fd (Cstruct.of_string out) >>= function + | Ok () -> + Logs.debug (fun m -> m "wrote successfully") ; + Lwt.return (Some fd) + | Error e -> + Logs.err (fun m -> m "error %s while writing to tcp (%s)" + (str_of_e e) name) ; + safe_close fd >|= fun () -> + None + end + else begin + Logs.err (fun m -> m "unhandled tag %lu for %s" hdr.tag name) ; + Lwt.return (Some fd) + end) >>= fun fd -> + read_sock_write_tcp closing db c ?fd addr addrtype end let rec query_sock closing prefix db c interval = @@ -252,12 +251,12 @@ let rec query_sock closing prefix db c interval = | Error e -> Lwt.return (Error e) | Ok () -> let id = identifier id in - let id = match prefix with None -> id | Some p -> p ^ "." ^ id in + let id = match prefix with None -> [ id ] | Some p -> [ p ; id ] in let request = Vmm_wire.Stats.stat !command my_version id in - req := IM.add !command name !req ; - incr command ; - Logs.debug (fun m -> m "%d requesting %s via socket" !command id) ; - Vmm_lwt.write_raw c request) + req := IM64.add !command name !req ; + command := Int64.succ !command ; + Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id id) ; + Vmm_lwt.write_wire c request) (Ok ()) db >>= function | Error e -> Logs.err (fun m -> m "error %s while writing to vmm socket" (str_of_e e)) ; diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 010e4ac..04b1a4e 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -14,14 +14,72 @@ open Lwt.Infix open Astring -open Vmm_wire -open Vmm_wire.Log +let my_version = `WV2 -let my_version = `WV0 +type t = N of Lwt_unix.file_descr list * t String.Map.t -let write_complete s str = - let l = String.length str in - let b = Bytes.unsafe_of_string str in +let empty = N ([], String.Map.empty) + +let insert id fd t = + let rec go (N (fds, m)) = function + | [] -> N ((fd :: fds), m) + | x::xs -> + let n = match String.Map.find_opt x m with + | None -> empty + | Some n -> n + in + let entry = go n xs in + N (fds, String.Map.add x entry m) + in + go t id + +let remove id fd t = + let rec go (N (fds, m)) = function + | [] -> + begin match List.filter (fun fd' -> fd <> fd') fds with + | [] -> None + | fds' -> Some (N (fds', m)) + end + | x::xs -> + let n' = match String.Map.find_opt x m with + | None -> None + | Some n -> go n xs + in + let m' = match n' with + | None -> String.Map.remove x m + | Some entry -> String.Map.add x entry m + in + if String.Map.is_empty m' && fds = [] then None else Some (N (fds, m')) + in + match go t id with + | None -> empty + | Some n -> n + +let collect id t = + let rec go acc prefix (N (fds, m)) = + let acc' = + let here = List.map (fun fd -> (prefix, fd)) fds in + here @ acc + in + function + | [] -> acc' + | x::xs -> + match String.Map.find_opt x m with + | None -> acc' + | Some n -> go acc' (prefix @ [ x ]) n xs + in + go [] [] t id + +let broadcast prefix data t = + Lwt_list.fold_left_s (fun t (id, s) -> + Vmm_lwt.write_wire s data >|= function + | Ok () -> t + | Error `Exception -> remove id s t) + t (collect prefix t) + +let write_complete s cs = + let l = Cstruct.len cs in + let b = Cstruct.to_bytes cs in let rec w off = let len = l - off in Lwt_unix.write s b off len >>= fun n -> @@ -29,110 +87,141 @@ let write_complete s str = in w 0 -let pp_sockaddr ppf = function - | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str - | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d" - (Unix.string_of_inet_addr addr) port +let write_to_file file = + let mvar = Lwt_mvar.create_empty () in + let rec write_loop ?(retry = true) ?data ?fd () = + match fd with + | None when retry -> + Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd -> + write_loop ~retry:false ?data ~fd () + | None -> + Logs.err (fun m -> m "retry is false, exiting") ; + Lwt.return_unit + | Some fd -> + (match data with + | None -> Lwt_mvar.take mvar + | Some d -> Lwt.return d) >>= fun data -> + Lwt.catch + (fun () -> write_complete fd data >|= fun () -> (true, None, Some fd)) + (fun e -> + Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ; + Vmm_lwt.safe_close fd >|= fun () -> + (retry, Some data, None)) >>= fun (retry, data, fd) -> + write_loop ~retry ?data ?fd () + in + mvar, write_loop -let handle fd ring s addr () = - Logs.info (fun m -> m "handling connection from %a" pp_sockaddr addr) ; - let str = Fmt.strf "%a: CONNECT\n" (Ptime.pp_human ~tz_offset_s:0 ()) (Ptime_clock.now ()) in - write_complete fd str >>= fun () -> +(* TODO: + - should there be an unsubscribe command? + - should there be acks for history/datain? + *) + +let tree = ref empty + +let bcast = ref 0L + +let handle mvar ring s addr () = + Logs.info (fun m -> m "handling connection from %a" Vmm_lwt.pp_sockaddr addr) ; + let str = Fmt.strf "%a: CONNECT\n" (Ptime.pp_human ()) (Ptime_clock.now ()) in + Lwt_mvar.put mvar (Cstruct.of_string str) >>= fun () -> let rec loop () = - Vmm_lwt.read_exactly s >>= function + Vmm_lwt.read_wire s >>= function | Error (`Msg e) -> Logs.err (fun m -> m "error while reading %s" e) ; loop () | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (hdr, data) -> - let out = - (if not (version_eq hdr.version my_version) then - Error (`Msg "unknown version") - else match int_to_op hdr.tag with - | Some Data -> - (match decode_ts data with - | Ok ts -> Vmm_ring.write ring (ts, data) - | Error _ -> - Logs.warn (fun m -> m "ignoring error while decoding timestamp %s" data)) ; - Ok (`Data data) - | Some History -> - begin match decode_str data with - | Error e -> Error e - | Ok (str, off) -> match decode_ts ~off data with - | Error e -> Error e - | Ok ts -> - let elements = Vmm_ring.read_history ring ts in - let res = List.fold_left (fun acc (_, x) -> - match Vmm_wire.Log.decode_log_hdr (Cstruct.of_string x) with - | Ok (hdr, _) -> - Logs.debug (fun m -> m "found an entry: %a" (Vmm_core.Log.pp_hdr []) hdr) ; - if String.equal str (Vmm_core.string_of_id hdr.Vmm_core.Log.context) then - x :: acc - else - acc - | _ -> acc) - [] elements - in - (* just need a wrapper in tag = Log.Data, id = reqid *) - let out = - List.fold_left (fun acc x -> - let length = String.length x in - let hdr = Vmm_wire.create_header { length ; id = hdr.id ; tag = op_to_int Data ; version = my_version } in - (Cstruct.to_string hdr ^ x) :: acc) - [] (List.rev res) - in - Ok (`Out out) - end - | _ -> Error (`Msg "unknown command")) - in - match out with - | Error (`Msg msg) -> - begin - Logs.err (fun m -> m "error while processing: %s" msg) ; - Vmm_lwt.write_raw s (fail ~msg hdr.id my_version) >>= function - | Error _ -> Logs.err (fun m -> m "error0 while writing") ; Lwt.return_unit - | Ok () -> loop () + | Ok (hdr, _) when Vmm_wire.is_reply hdr -> + Logs.warn (fun m -> m "ignoring reply") ; + loop () + | Ok (hdr, _) when not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) -> + Logs.warn (fun m -> m "unsupported version") ; + Lwt.return_unit + | Ok (hdr, data) -> match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with + | Some Vmm_wire.Log.Log -> + begin match Vmm_wire.Log.decode_log_hdr data with + | Error (`Msg err) -> + Logs.warn (fun m -> m "ignoring error %s while decoding log" err) ; + loop () + | Ok (hdr, _) -> + Vmm_ring.write ring (hdr.Vmm_core.Log.ts, Cstruct.to_string data) ; + Lwt_mvar.put mvar data >>= fun () -> + let data' = Vmm_wire.encode ~body:data my_version !bcast (Vmm_wire.Log.op_to_int Vmm_wire.Log.Broadcast) in + bcast := Int64.succ !bcast ; + broadcast hdr.Vmm_core.Log.context data' !tree >>= fun tree' -> + tree := tree' ; + loop () end - | Ok (`Data data) -> - begin - write_complete fd data >>= fun () -> - Vmm_lwt.write_raw s (success hdr.id my_version) >>= function - | Error _ -> Logs.err (fun m -> m "error1 while writing") ; Lwt.return_unit - | Ok () -> loop () + | Some Vmm_wire.Log.History -> + begin match Vmm_wire.decode_id_ts data with + | Error (`Msg err) -> + Logs.warn (fun m -> m "ignoring error %s while decoding history" err) ; + loop () + | Ok ((sub, ts), _) -> + let elements = Vmm_ring.read_history ring ts in + let res = + List.fold_left (fun acc (_, x) -> + let cs = Cstruct.of_string x in + match Vmm_wire.Log.decode_log_hdr cs with + | Ok (hdr, _) when Vmm_core.is_sub_id ~super:hdr.Vmm_core.Log.context ~sub -> + cs :: acc + | _ -> acc) + [] elements + in + (* just need a wrapper in tag = Log.Data, id = reqid *) + Lwt_list.fold_left_s (fun r body -> + match r with + | Ok () -> + let data = Vmm_wire.encode ~body my_version hdr.Vmm_wire.id (Vmm_wire.Log.op_to_int Vmm_wire.Log.Log) in + Vmm_lwt.write_wire s data + | Error e -> Lwt.return (Error e)) + (Ok ()) res >>= function + | Ok () -> loop () + | Error _ -> + Logs.err (fun m -> m "error while sending data in history") ; + Lwt.return_unit end - | Ok (`Out datas) -> - Lwt_list.fold_left_s (fun r x -> match r with - | Error e -> Lwt.return (Error e) - | Ok () -> Vmm_lwt.write_raw s x) - (Ok ()) datas >>= function - | Error _ -> Logs.err (fun m -> m "error2 while writing") ; Lwt.return_unit - | Ok () -> - Vmm_lwt.write_raw s (success hdr.id my_version) >>= function - | Error _ -> Logs.err (fun m -> m "error3 while writing") ; Lwt.return_unit - | Ok () -> loop () + | Some Vmm_wire.Log.Subscribe -> + begin match Vmm_wire.decode_strings data with + | Error (`Msg err) -> + Logs.warn (fun m -> m "ignoring error %s while decoding subscribe" err) ; + loop () + | Ok (id, _) -> + tree := insert id s !tree ; + let out = Vmm_wire.success my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in + Vmm_lwt.write_wire s out >>= function + | Ok () -> loop () + | Error _ -> + Logs.err (fun m -> m "error while sending reply for subscribe") ; + Lwt.return_unit + end + | _ -> + Logs.err (fun m -> m "unknown command") ; + loop () in loop () >>= fun () -> - Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) + Vmm_lwt.safe_close s + (* should remove all the s from the tree above *) let jump _ file sock = Sys.(set_signal sigpipe Signal_ignore) ; Lwt_main.run - (Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd -> - (Lwt_unix.file_exists sock >>= function + ((Lwt_unix.file_exists sock >>= function | true -> Lwt_unix.unlink sock | false -> Lwt.return_unit) >>= fun () -> let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in Lwt_unix.(bind s (ADDR_UNIX sock)) >>= fun () -> Lwt_unix.listen s 1 ; let ring = Vmm_ring.create () in + let mvar, writer = write_to_file file in let rec loop () = Lwt_unix.accept s >>= fun (cs, addr) -> - Lwt.async (handle fd ring cs addr) ; + Lwt.async (handle mvar ring cs addr) ; loop () in - loop ()) + Lwt.pick [ loop () ; writer () ]) ; + `Ok () let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml new file mode 100644 index 0000000..85c100a --- /dev/null +++ b/app/vmm_tls_endpoint.ml @@ -0,0 +1,172 @@ +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix + +let write_tls state t data = + Vmm_tls.write_tls (fst t) data >>= function + | Ok () -> Lwt.return_unit + | Error `Exception -> + let state', out = Vmm_engine.handle_disconnect !state t in + state := state' ; + Lwt_list.iter_s (fun (s, data) -> write_raw s data) out >>= fun () -> + Tls_lwt.Unix.close (fst t) + +let 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 server_socket port = + let open Lwt_unix in + let s = socket PF_INET SOCK_STREAM 0 in + set_close_on_exec s ; + setsockopt s SO_REUSEADDR true ; + bind s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () -> + listen s 10 ; + Lwt.return s + +let rec read_log state s = + Vmm_lwt.read_exactly s >>= function + | Error (`Msg msg) -> + Logs.err (fun m -> m "reading log error %s" msg) ; + read_log state s + | Error _ -> + Logs.err (fun m -> m "exception while reading log") ; + invalid_arg "log socket communication issue" + | Ok (hdr, data) -> + let state', outs = Vmm_engine.handle_log !state hdr data in + state := state' ; + process state outs >>= fun () -> + read_log state s + +let rec read_cons state s = + Vmm_lwt.read_exactly s >>= function + | Error (`Msg msg) -> + Logs.err (fun m -> m "reading console error %s" msg) ; + read_cons state s + | Error _ -> + Logs.err (fun m -> m "exception while reading console socket") ; + invalid_arg "console socket communication issue" + | Ok (hdr, data) -> + let state', outs = Vmm_engine.handle_cons !state hdr data in + state := state' ; + process state outs >>= fun () -> + read_cons state s + +let rec read_stats state s = + Vmm_lwt.read_exactly s >>= function + | Error (`Msg msg) -> + Logs.err (fun m -> m "reading stats error %s" msg) ; + read_stats state s + | Error _ -> + Logs.err (fun m -> m "exception while reading stats") ; + Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () -> + invalid_arg "stat socket communication issue" + | Ok (hdr, data) -> + let state', outs = Vmm_engine.handle_stat !state hdr data in + state := state' ; + process state outs >>= fun () -> + read_stats state s + +let cmp_s (_, a) (_, b) = + let open Lwt_unix in + match a, b with + | ADDR_UNIX str, ADDR_UNIX str' -> String.compare str str' = 0 + | ADDR_INET (addr, port), ADDR_INET (addr', port') -> + port = port' && + String.compare (Unix.string_of_inet_addr addr) (Unix.string_of_inet_addr addr') = 0 + | _ -> false + +let jump _ cacert cert priv_key port = + Sys.(set_signal sigpipe Signal_ignore) ; + Lwt_main.run + (Nocrypto_entropy_lwt.initialize () >>= fun () -> + (init_sock Vmm_core.tmpdir "cons" >|= function + | None -> invalid_arg "cannot connect to console socket" + | Some c -> c) >>= fun c -> + init_sock Vmm_core.tmpdir "stat" >>= fun s -> + (init_sock Vmm_core.tmpdir "log" >|= function + | None -> invalid_arg "cannot connect to log socket" + | Some l -> l) >>= fun l -> + server_socket port >>= fun socket -> + X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert -> + X509_lwt.certs_of_pem cacert >>= (function + | [ ca ] -> Lwt.return ca + | _ -> Lwt.fail_with "expect single ca as cacert") >>= fun ca -> + let config = + Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2) + ~reneg:true ~certificates:(`Single cert) ()) + in + (match Vmm_engine.init cmp_s c s l with + | Ok s -> Lwt.return s + | Error (`Msg m) -> Lwt.fail_with m) >>= fun t -> + let state = ref t in + Lwt.async (fun () -> read_cons state c) ; + (match s with + | None -> () + | Some s -> Lwt.async (fun () -> read_stats state s)) ; + Lwt.async (fun () -> read_log state l) ; + Lwt.async stats_loop ; + let rec loop () = + Lwt.catch (fun () -> + Lwt_unix.accept socket >>= fun (fd, addr) -> + Lwt_unix.set_close_on_exec fd ; + Lwt.catch + (fun () -> Tls_lwt.Unix.server_of_fd config fd >|= fun t -> (t, addr)) + (fun exn -> + Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () -> + Lwt.fail exn) >>= fun t -> + Lwt.async (fun () -> + Lwt.catch + (fun () -> handle ca state t) + (fun e -> + Logs.err (fun m -> m "error while handle() %s" + (Printexc.to_string e)) ; + Lwt.return_unit)) ; + loop ()) + (function + | Unix.Unix_error (e, f, _) -> + Logs.err (fun m -> m "Unix error %s in %s" (Unix.error_message e) f) ; + loop () + | Tls_lwt.Tls_failure a -> + Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ; + loop () + | exn -> + Logs.err (fun m -> m "exception %s" (Printexc.to_string exn)) ; + loop ()) + in + loop ()) + +let setup_log style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) + +open Cmdliner + +let setup_log = + Term.(const setup_log + $ Fmt_cli.style_renderer () + $ Logs_cli.level ()) + +let cacert = + let doc = "CA certificate" in + Arg.(required & pos 0 (some file) None & info [] ~doc) + +let cert = + let doc = "Certificate" in + Arg.(required & pos 1 (some file) None & info [] ~doc) + +let key = + let doc = "Private key" in + Arg.(required & pos 2 (some file) None & info [] ~doc) + +let port = + let doc = "TCP listen port" in + Arg.(value & opt int 1025 & info [ "port" ] ~doc) + diff --git a/app/vmmc.ml b/app/vmmc.ml new file mode 100644 index 0000000..df61962 --- /dev/null +++ b/app/vmmc.ml @@ -0,0 +1,264 @@ +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix + +open Vmm_core + +let my_version = `WV2 +let my_command = 1L + +(* +let process db hdr data = + let open Vmm_wire in + let open Rresult.R.Infix in + if not (version_eq hdr.version my_version) then + Logs.err (fun m -> m "unknown wire protocol version") + else + let r = + match hdr.tag with + | x when x = Client.stat_msg_tag -> + Client.decode_stat data >>= fun (ru, vmm, ifd) -> + Logs.app (fun m -> m "statistics: %a %a %a" + pp_rusage ru + Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string uint64)) vmm + Fmt.(list ~sep:(unit ", ") pp_ifdata) ifd) ; + Ok () + | x when x = Client.log_msg_tag -> + Client.decode_log data >>= fun log -> + Logs.app (fun m -> m "log: %a" (Vmm_core.Log.pp db) log) ; + Ok () + | x when x = Client.console_msg_tag -> + Client.decode_console data >>= fun (name, ts, msg) -> + Logs.app (fun m -> m "console %s: %a %s" (translate_serial db name) (Ptime.pp_human ~tz_offset_s:0 ()) ts msg) ; + Ok () + | x when x = Client.info_msg_tag -> + Client.decode_info data >>= fun vms -> + List.iter (fun (name, cmd, pid, taps) -> + Logs.app (fun m -> m "info %s: %s %d taps %a" (translate_serial db name) + cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) + vms ; + Ok () + | x when x = fail_tag -> + decode_str data >>= fun (msg, _) -> + Logs.err (fun m -> m "failed %s" msg) ; + Ok () + | x when x = success_tag -> + decode_str data >>= fun (msg, _) -> + Logs.app (fun m -> m "success %s" msg) ; + Ok () + | x -> Rresult.R.error_msgf "unknown header tag %02X" x + in + match r with + | Ok () -> () + | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg) +*) + +let process fd = + Vmm_lwt.read_wire fd >|= function + | Error _ -> Error () + | Ok (hdr, data) -> + if not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) then begin + Logs.err (fun m -> m "unknown wire protocol version") ; + Error () + end else begin + if Vmm_wire.is_fail hdr then begin + let msg = match Vmm_wire.decode_string data with + | Ok (msg, _) -> Some msg + | Error _ -> None + in + Logs.err (fun m -> m "command failed %a" Fmt.(option ~none:(unit "") string) msg) ; + Error () + end else if Vmm_wire.is_reply hdr && hdr.Vmm_wire.id = my_command then + Ok data + else begin + Logs.err (fun m -> m "received unexpected data") ; + Error () + end + end + +let connect socket = + let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.set_close_on_exec c ; + Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket) >|= fun () -> + c + +let info_ _ socket name = + Lwt_main.run ( + connect socket >>= fun fd -> + let name' = Astring.String.cuts ~empty:false ~sep:"." name in + let info = Vmm_wire.Vm.info my_command my_version name' in + (Vmm_lwt.write_wire fd info >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok data -> + match Vmm_wire.Vm.decode_vms data with + | Ok (vms, _) -> + List.iter (fun (id, memory, cmd, pid, taps) -> + Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a" + pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) + vms + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while decoding vms" msg)) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd + ) ; + `Ok () + +let really_destroy socket name = + connect socket >>= fun fd -> + let cmd = Vmm_wire.Vm.destroy my_command my_version (Astring.String.cuts ~empty:false ~sep:"." name) in + (Vmm_lwt.write_wire fd cmd >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok _ -> Logs.app (fun m -> m "destroyed VM")) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd + +let destroy _ socket name = + Lwt_main.run (really_destroy socket name) ; + `Ok () + +let create _ socket force name image cpuid requested_memory boot_params block_device network = + let image' = match Bos.OS.File.read (Fpath.v image) with + | Ok data -> data + | Error (`Msg s) -> invalid_arg s + in + let prefix, vname = match List.rev (Astring.String.cuts ~empty:false ~sep:"." name) with + | [ name ] -> [], name + | name::tl -> List.rev tl, name + | [] -> assert false + and argv = match boot_params with + | [] -> None + | xs -> Some xs + and vmimage = `Ukvm_amd64, Cstruct.of_string image' + in + let vm_config = { + prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; + vmimage ; argv + } in + Lwt_main.run ( + (if force then + really_destroy socket name + else + Lwt.return_unit) >>= fun () -> + connect socket >>= fun fd -> + let vm = Vmm_wire.Vm.create my_command my_version vm_config in + (Vmm_lwt.write_wire fd vm >>= function + | Error `Exception -> Lwt.return_unit + | Ok () -> process fd >|= function + | Ok _ -> Logs.app (fun m -> m "successfully started VM") + | Error () -> ()) >>= fun () -> + Vmm_lwt.safe_close fd + ) ; + `Ok () + +let help _ _ man_format cmds = function + | None -> `Help (`Pager, None) + | Some t when List.mem t cmds -> `Help (man_format, Some t) + | Some _ -> List.iter print_endline cmds; `Ok () + +let 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 connect to" in + let sock = Fpath.(to_string (Vmm_core.tmpdir / "vmmd" + "sock")) in + Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) + +let force = + let doc = "force VM creation." in + Arg.(value & flag & info [ "f" ; "force" ] ~doc) + +let image = + let doc = "File of virtual machine image." in + Arg.(required & pos 1 (some file) None & info [] ~doc) + +let vm_name = + let doc = "Name virtual machine config." in + Arg.(required & pos 0 (some string) None & info [] ~doc) + +let destroy_cmd = + let doc = "destroys a virtual machine" in + let man = + [`S "DESCRIPTION"; + `P "Destroy a virtual machine."] + in + Term.(ret (const destroy $ setup_log $ socket $ vm_name)), + Term.info "destroy" ~doc ~man + +let info_cmd = + let doc = "information about VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows information about VMs."] + in + Term.(ret (const info_ $ setup_log $ socket $ vm_name)), + Term.info "info" ~doc ~man + +let cpu = + let doc = "CPUid" in + Arg.(value & opt int 0 & info [ "cpu" ] ~doc) + +let mem = + let doc = "Memory to provision" in + Arg.(value & opt int 512 & info [ "mem" ] ~doc) + +let args = + let doc = "Boot arguments" in + Arg.(value & opt_all string [] & info [ "arg" ] ~doc) + +let block = + let doc = "Block device name" in + Arg.(value & opt (some string) None & info [ "block" ] ~doc) + +let net = + let doc = "Network device" in + Arg.(value & opt_all string [] & info [ "net" ] ~doc) + +let create_cmd = + let doc = "creates a virtual machine" in + let man = + [`S "DESCRIPTION"; + `P "Creates a virtual machine."] + in + Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), + Term.info "create" ~doc ~man + +let help_cmd = + let topic = + let doc = "The topic to get help on. `topics' lists the topics." in + Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) + in + let doc = "display help about vmmc" in + let man = + [`S "DESCRIPTION"; + `P "Prints help about conex commands and subcommands"] + in + Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ topic)), + Term.info "help" ~doc ~man + +let default_cmd = + let doc = "VMM client" in + let man = [ + `S "DESCRIPTION" ; + `P "$(tname) connects to vmmd via a local socket" ] + in + Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), + Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man + +let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ] + +let () = + match Term.eval_choice default_cmd cmds + with `Ok () -> exit 0 | _ -> exit 1 diff --git a/app/vmmd.ml b/app/vmmd.ml index 2967d8b..8202458 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -16,136 +16,86 @@ let pp_stats ppf s = open Lwt.Infix -let write_raw s data = - Vmm_lwt.write_raw s data >|= fun _ -> () +type out = [ + | `Cons of Cstruct.t + | `Stat of Cstruct.t + | `Log of Cstruct.t +] -let write_tls state t data = - Vmm_tls.write_tls (fst t) data >>= function - | Ok () -> Lwt.return_unit - | Error `Exception -> - let state', out = Vmm_engine.handle_disconnect !state t in - state := state' ; - Lwt_list.iter_s (fun (s, data) -> write_raw s data) out >>= fun () -> - Tls_lwt.Unix.close (fst t) - -let to_ipaddr (_, sa) = match sa with - | Lwt_unix.ADDR_UNIX _ -> invalid_arg "cannot convert unix address" - | Lwt_unix.ADDR_INET (addr, port) -> Ipaddr_unix.V4.of_inet_addr_exn addr, port - -let pp_sockaddr ppf (_, sa) = match sa with - | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str - | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d" - (Unix.string_of_inet_addr addr) port - -let process state xs = - Lwt_list.iter_s (function - | `Raw (s, str) -> write_raw s str - | `Tls (s, str) -> write_tls state s str) - xs - -let handle ca state t = - Logs.debug (fun m -> m "connection from %a" pp_sockaddr t) ; - let authenticator = - let time = Ptime_clock.now () in - X509.Authenticator.chain_of_trust ~time ~crls:!state.Vmm_engine.crls [ca] +let handle state out c_fd fd addr = + (* out is for `Log | `Stat | `Cons (including reconnect semantics) *) + (* need to handle data out (+ die on write failure) *) + Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ; + (* now we need to read a packet and handle it + (1) + (a) easy for info (look up name/prefix in resources) + (b) destroy looks up vm in resources, executes kill (wait for pid will do the cleanup) + logs "destroy issued" + (c) create initiates the vm startup procedure: + write image file, create fifo, create tap(s), send fifo to console + -- Lwt effects happen (console) -- + executes ukvm-bin + waiter, send stats pid and taps, inserts await into state, logs "created vm" + -- Lwt effects happen (stats, logs, wait_and_clear) -- + (2) goto (1) + *) + let process xs = + Lwt_list.iter_p (function + | #out as o -> out o + | `Data cs -> + (* rather: terminate connection *) + Vmm_lwt.write_wire fd cs >|= fun _ -> ()) xs in - Lwt.catch - (fun () -> Tls_lwt.Unix.reneg ~authenticator (fst t)) - (fun e -> - (match e with - | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a)) - | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f)) - | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ; - Tls_lwt.Unix.close (fst t) >>= fun () -> - Lwt.fail e) >>= fun () -> - (match Tls_lwt.Unix.epoch (fst t) with - | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain - | `Error -> - Tls_lwt.Unix.close (fst t) >>= fun () -> - Lwt.fail_with "error while getting epoch") >>= fun chain -> - match Vmm_engine.handle_initial !state t (to_ipaddr t) chain ca with - | Ok (state', outs, next) -> - state := state' ; - process state outs >>= fun () -> - begin match next with - | `Create (task, next) -> - (match task with - | None -> Lwt.return_unit - | Some (kill, wait) -> kill () ; wait) >>= fun () -> - let await, wakeme = Lwt.wait () in - begin match next !state await with - | Ok (state', outs, cont) -> - state := state' ; - process state outs >>= fun () -> - begin match cont !state t with - | Ok (state', outs, vm) -> - state := state' ; - s := { !s with vm_created = succ !s.vm_created } ; - Lwt.async (fun () -> - Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> - let state', outs = Vmm_engine.handle_shutdown !state vm r in - s := { !s with vm_destroyed = succ !s.vm_destroyed } ; - state := state' ; - process state outs >|= fun () -> - Lwt.wakeup wakeme ()) ; - process state outs >>= fun () -> - begin match Vmm_engine.setup_stats !state vm with - | Ok (state', outs) -> - state := state' ; - process state outs - | Error (`Msg e) -> - Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; - Lwt.return_unit - end - | Error (`Msg e) -> - Logs.err (fun m -> m "error while create %s" e) ; - let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in - process state [ `Tls (t, err) ] - end - | Error (`Msg e) -> - Logs.err (fun m -> m "error while cont %s" e) ; - let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in - process state [ `Tls (t, err) ] - end >>= fun () -> - Tls_lwt.Unix.close (fst t) - | `Loop (prefix, perms) -> - let rec loop () = - Vmm_tls.read_tls (fst t) >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "reading client %a error: %s" pp_sockaddr t msg) ; - loop () - | Error _ -> - Logs.err (fun m -> m "disconnect from %a" pp_sockaddr t) ; - let state', cons = Vmm_engine.handle_disconnect !state t in - state := state' ; - Lwt_list.iter_s (fun (s, data) -> write_raw s data) cons >>= fun () -> - Tls_lwt.Unix.close (fst t) - | Ok (hdr, buf) -> - let state', out = Vmm_engine.handle_command !state t prefix perms hdr buf in - state := state' ; - process state out >>= fun () -> - loop () - in - loop () - | `Close socks -> - Logs.debug (fun m -> m "closing session with %d active ones" (List.length socks)) ; - Lwt_list.iter_s (fun (t, _) -> Tls_lwt.Unix.close t) socks >>= fun () -> - Tls_lwt.Unix.close (fst t) - end - | Error (`Msg e) -> - Logs.err (fun m -> m "VMM %a %s" pp_sockaddr t e) ; - let err = Vmm_wire.fail ~msg:e 0 !state.Vmm_engine.client_version in - process state [`Tls (t, err)] >>= fun () -> - Tls_lwt.Unix.close (fst t) - -let server_socket port = - let open Lwt_unix in - let s = socket PF_INET SOCK_STREAM 0 in - set_close_on_exec s ; - setsockopt s SO_REUSEADDR true ; - bind s (ADDR_INET (Unix.inet_addr_any, port)) >>= fun () -> - listen s 10 ; - Lwt.return s + Logs.debug (fun m -> m "now reading") ; + (Vmm_lwt.read_wire fd >>= function + | Error _ -> + Logs.err (fun m -> m "error while reading") ; + Lwt.return_unit + | Ok (hdr, buf) -> + Logs.debug (fun m -> m "read sth") ; + let state', data, next = Vmm_engine.handle_command !state hdr buf in + state := state' ; + process data >>= fun () -> + match next with + | `End -> Lwt.return_unit + | `Wait (task, out) -> task >>= fun () -> process out + | `Create cont -> + (* data contained a write to console, we need to wait for its reply first *) + Vmm_lwt.read_wire c_fd >>= function + | Ok (_, data) when Vmm_wire.is_fail hdr -> + Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; + Lwt.return_unit + | Ok (_, _) when Vmm_wire.is_reply hdr -> + (* assert hdr.id = id! *) + (* TODO slightly more tricky, since we need to "Vmm_lwt.wait_and_clear" in here *) + let await, wakeme = Lwt.wait () in + begin match cont !state await with + | Error (`Msg msg) -> + Logs.err (fun m -> m "create continuation failed %s" msg) ; + Lwt.return_unit + | Ok (state'', out, vm) -> + state := state'' ; + s := { !s with vm_created = succ !s.vm_created } ; + Lwt.async (fun () -> + Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> + let state', out' = Vmm_engine.handle_shutdown !state vm r in + s := { !s with vm_destroyed = succ !s.vm_destroyed } ; + state := state' ; + process out' >|= fun () -> + Lwt.wakeup wakeme ()) ; + process out >>= fun () -> + begin match Vmm_engine.setup_stats !state vm with + | Ok (state', out) -> + state := state' ; + process out (* TODO: need to read from stats socket! *) + | Error (`Msg e) -> + Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; + Lwt.return_unit + end + end + | _ -> + Logs.err (fun m -> m "error while reading from console") ; + Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd let init_sock dir name = let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in @@ -159,120 +109,63 @@ let init_sock dir name = (Lwt.catch (fun () -> Lwt_unix.close c) (fun _ -> Lwt.return_unit)) >|= fun () -> None) -let rec read_log state s = - Vmm_lwt.read_exactly s >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "reading log error %s" msg) ; - read_log state s - | Error _ -> - Logs.err (fun m -> m "exception while reading log") ; - invalid_arg "log socket communication issue" - | Ok (hdr, data) -> - let state', outs = Vmm_engine.handle_log !state hdr data in - state := state' ; - process state outs >>= fun () -> - read_log state s +let create_mbox name = + init_sock Vmm_core.tmpdir name >|= function + | None -> None + | Some fd -> + let mvar = Lwt_mvar.create_empty () in + (* could be more elaborate: + if fails, we can reconnect and spit our more log messages to the new socket + if fails, all running VMs terminate, so we can terminate as well ;) + if fails, we'd need to retransmit all VM info to stat (or stat has to ask at connect) *) + let rec loop () = + Lwt_mvar.take mvar >>= fun data -> + Vmm_lwt.write_wire fd data >>= function + | Ok () -> loop () + | Error `Exception -> invalid_arg ("exception while writing to " ^ name) ; + in + Lwt.async loop ; + Some (mvar, fd) -let rec read_cons state s = - Vmm_lwt.read_exactly s >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "reading console error %s" msg) ; - read_cons state s - | Error _ -> - Logs.err (fun m -> m "exception while reading console socket") ; - invalid_arg "console socket communication issue" - | Ok (hdr, data) -> - let state', outs = Vmm_engine.handle_cons !state hdr data in - state := state' ; - process state outs >>= fun () -> - read_cons state s - -let rec read_stats state s = - Vmm_lwt.read_exactly s >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "reading stats error %s" msg) ; - read_stats state s - | Error _ -> - Logs.err (fun m -> m "exception while reading stats") ; - Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () -> - invalid_arg "stat socket communication issue" - | Ok (hdr, data) -> - let state', outs = Vmm_engine.handle_stat !state hdr data in - state := state' ; - process state outs >>= fun () -> - read_stats state s - -let cmp_s (_, a) (_, b) = - let open Lwt_unix in - match a, b with - | ADDR_UNIX str, ADDR_UNIX str' -> String.compare str str' = 0 - | ADDR_INET (addr, port), ADDR_INET (addr', port') -> - port = port' && - String.compare (Unix.string_of_inet_addr addr) (Unix.string_of_inet_addr addr') = 0 - | _ -> false +let server_socket dir name = + let file = Fpath.(dir / name + "sock") in + let sock = Fpath.to_string file in + (Lwt_unix.file_exists sock >>= function + | true -> Lwt_unix.unlink sock + | false -> Lwt.return_unit) >>= fun () -> + let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.(bind s (ADDR_UNIX sock)) >|= fun () -> + Lwt_unix.listen s 1 ; + s let rec stats_loop () = Logs.info (fun m -> m "%a" pp_stats !s) ; Lwt_unix.sleep 600. >>= fun () -> stats_loop () -let jump _ cacert cert priv_key port = +let jump _ = Sys.(set_signal sigpipe Signal_ignore) ; Lwt_main.run - (Nocrypto_entropy_lwt.initialize () >>= fun () -> - (init_sock Vmm_core.tmpdir "cons" >|= function + (server_socket Vmm_core.tmpdir "vmmd" >>= fun ss -> + (create_mbox "cons" >|= function | None -> invalid_arg "cannot connect to console socket" - | Some c -> c) >>= fun c -> - init_sock Vmm_core.tmpdir "stat" >>= fun s -> - (init_sock Vmm_core.tmpdir "log" >|= function + | Some c -> c) >>= fun (c, c_fd) -> + create_mbox "stat" >>= fun s -> + (create_mbox "log" >|= function | None -> invalid_arg "cannot connect to log socket" - | Some l -> l) >>= fun l -> - server_socket port >>= fun socket -> - X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert -> - X509_lwt.certs_of_pem cacert >>= (function - | [ ca ] -> Lwt.return ca - | _ -> Lwt.fail_with "expect single ca as cacert") >>= fun ca -> - let config = - Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2) - ~reneg:true ~certificates:(`Single cert) ()) + | Some l -> l) >>= fun (l, _l_fd) -> + let state = ref (Vmm_engine.init ()) in + let out = function + | `Stat data -> (match s with None -> Lwt.return_unit | Some (s, _s_fd) -> Lwt_mvar.put s data) + | `Log data -> Lwt_mvar.put l data + | `Cons data -> Lwt_mvar.put c data in - (match Vmm_engine.init cmp_s c s l with - | Ok s -> Lwt.return s - | Error (`Msg m) -> Lwt.fail_with m) >>= fun t -> - let state = ref t in - Lwt.async (fun () -> read_cons state c) ; - (match s with - | None -> () - | Some s -> Lwt.async (fun () -> read_stats state s)) ; - Lwt.async (fun () -> read_log state l) ; Lwt.async stats_loop ; let rec loop () = - Lwt.catch (fun () -> - Lwt_unix.accept socket >>= fun (fd, addr) -> - Lwt_unix.set_close_on_exec fd ; - Lwt.catch - (fun () -> Tls_lwt.Unix.server_of_fd config fd >|= fun t -> (t, addr)) - (fun exn -> - Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >>= fun () -> - Lwt.fail exn) >>= fun t -> - Lwt.async (fun () -> - Lwt.catch - (fun () -> handle ca state t) - (fun e -> - Logs.err (fun m -> m "error while handle() %s" - (Printexc.to_string e)) ; - Lwt.return_unit)) ; - loop ()) - (function - | Unix.Unix_error (e, f, _) -> - Logs.err (fun m -> m "Unix error %s in %s" (Unix.error_message e) f) ; - loop () - | Tls_lwt.Tls_failure a -> - Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ; - loop () - | exn -> - Logs.err (fun m -> m "exception %s" (Printexc.to_string exn)) ; - loop ()) + Lwt_unix.accept ss >>= fun (fd, addr) -> + Lwt_unix.set_close_on_exec fd ; + Lwt.async (fun () -> handle state out c_fd fd addr) ; + loop () in loop ()) @@ -288,24 +181,8 @@ let setup_log = $ Fmt_cli.style_renderer () $ Logs_cli.level ()) -let cacert = - let doc = "CA certificate" in - Arg.(required & pos 0 (some file) None & info [] ~doc) - -let cert = - let doc = "Certificate" in - Arg.(required & pos 1 (some file) None & info [] ~doc) - -let key = - let doc = "Private key" in - Arg.(required & pos 2 (some file) None & info [] ~doc) - -let port = - let doc = "TCP listen port" in - Arg.(value & opt int 1025 & info [ "port" ] ~doc) - let cmd = - Term.(ret (const jump $ setup_log $ cacert $ cert $ key $ port)), + Term.(ret (const jump $ setup_log)), Term.info "vmmd" ~version:"%%VERSION_NUM%%" let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/opam b/opam index 1a9aa72..0b5376b 100644 --- a/opam +++ b/opam @@ -14,7 +14,6 @@ depends: [ "ipaddr" {>= "2.2.0"} "hex" "cstruct" - "ppx_cstruct" {build & >= "3.0.0"} "logs" "rresult" "bos" diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 14dd74e..54bbcbd 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -9,7 +9,9 @@ let () = Pkg.bin "app/vmmd" ; Pkg.bin "app/vmm_console" ; Pkg.bin "app/vmm_log" ; - Pkg.bin "app/vmm_client" ; + (* Pkg.bin "app/vmm_client" ; *) + (* Pkg.bin "app/vmm_tls_endpoint" ; *) + Pkg.bin "app/vmmc" ; Pkg.bin "provision/vmm_req_permissions" ; Pkg.bin "provision/vmm_req_delegation" ; Pkg.bin "provision/vmm_req_vm" ; @@ -18,6 +20,6 @@ let () = Pkg.bin "provision/vmm_gen_ca" ; Pkg.clib "stats/libvmm_stats_stubs.clib" ; Pkg.bin "stats/vmm_stats_lwt" ; - Pkg.bin "app/vmm_prometheus_stats" ; + (* Pkg.bin "app/vmm_prometheus_stats" ; *) Pkg.bin "app/vmm_influxdb_stats" ; ] diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 8f38f34..099c1c0 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -38,15 +38,16 @@ end let perms : permission list Asn.t = Asn.S.bit_string_flags [ - 0, `All ; + 0, `All ; (* no *) 1, `Info ; 2, `Create ; - 3, `Block ; + 3, `Block ; (* create [name] [size] ; destroy [name] *) 4, `Statistics ; 5, `Console ; 6, `Log ; 7, `Crl ; 9, `Force_create ; + (* 10, `Destroy ; (* [name] *) *) ] open Rresult.R.Infix diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml new file mode 100644 index 0000000..e4bf64b --- /dev/null +++ b/src/vmm_commands.ml @@ -0,0 +1,223 @@ +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) + +open Astring + +open Vmm_core + +open Rresult +open R.Infix + +let handle_command t s prefix perms hdr buf = + let res = + if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then + Error (`Msg "unknown client version") + else match Vmm_wire.Client.cmd_of_int hdr.Vmm_wire.tag with + | None -> Error (`Msg "unknown command") + | Some x when cmd_allowed perms x -> + begin + Vmm_wire.decode_str buf >>= fun (buf, _l) -> + let arg = if String.length buf = 0 then prefix else prefix @ [buf] in + let vmid = string_of_id arg in + match x with + | Info -> + begin match Vmm_resources.find t.resources arg with + | None -> + Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ; + R.error_msgf "info: %s not found" buf + | Some x -> + let data = + Vmm_resources.fold (fun acc vm -> + acc ^ Vmm_wire.Client.encode_vm vm.config.vname vm) + "" x + in + let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in + Ok (t, [ `Tls (s, out) ]) + end + | Destroy_vm -> + begin match Vmm_resources.find_vm t.resources arg with + | Some vm -> + Vmm_unix.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 on_success t = + let cons = Vmm_wire.Console.history t.console_counter t.console_version vmid Ptime.epoch in + let old = match String.Map.find vmid t.console_attached with + | None -> [] + | Some s -> + let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in + [ `Tls (s, out) ] + in + let console_attached = String.Map.add vmid s t.console_attached in + { t with console_counter = succ t.console_counter ; console_attached }, + `Raw (t.console_socket, cons) :: old + in + let cons = Vmm_wire.Console.attach t.console_counter t.console_version vmid in + let console_requests = IM.add t.console_counter on_success t.console_requests in + Ok ({ t with console_counter = succ t.console_counter ; console_requests }, + [ `Raw (t.console_socket, cons) ]) + | Detach -> + let cons = Vmm_wire.Console.detach t.console_counter t.console_version vmid in + (match String.Map.find vmid t.console_attached with + | None -> Error (`Msg "not attached") + | Some x when t.cmp x s -> Ok (String.Map.remove vmid t.console_attached) + | Some _ -> Error (`Msg "this socket is not attached")) >>= fun console_attached -> + let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in + Ok ({ t with console_counter = succ t.console_counter ; console_attached }, + [ `Raw (t.console_socket, cons) ; `Tls (s, out) ]) + | Statistics -> + begin match t.stats_socket with + | None -> Error (`Msg "no statistics available") + | Some _ -> match Vmm_resources.find_vm t.resources arg with + | Some vm -> + let stat_out = Vmm_wire.Stats.stat t.stats_counter t.stats_version vmid in + let d = (s, hdr.Vmm_wire.id, translate_tap vm) in + let stats_requests = IM.add t.stats_counter d t.stats_requests in + Ok ({ t with stats_counter = succ t.stats_counter ; stats_requests }, + stat t stat_out) + | _ -> Error (`Msg ("statistics: not found " ^ buf)) + end + | Log -> + begin + let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in + let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in + let log_counter = succ t.log_counter in + Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ]) + end + | Create_block | Destroy_block -> Error (`Msg "NYI") + end + | Some _ -> Error (`Msg "unauthorised command") + in + match res with + | Ok r -> r + | Error (`Msg msg) -> + Logs.debug (fun m -> m "error while processing command: %s" msg) ; + let out = Vmm_wire.fail ~msg hdr.Vmm_wire.id t.client_version in + (t, [ `Tls (s, out) ]) + +let handle_stat state hdr data = + let open Vmm_wire in + if not (version_eq hdr.version state.stats_version) then begin + Logs.warn (fun m -> m "ignoring message with unknown stats version") ; + state, [] + end else if hdr.tag = success_tag then + state, [] + else + match IM.find hdr.id state.stats_requests with + | exception Not_found -> + Logs.err (fun m -> m "couldn't find stat request") ; + state, [] + | (s, req_id, f) -> + let stats_requests = IM.remove hdr.id state.stats_requests in + let state = { state with stats_requests } in + let out = + match Stats.int_to_op hdr.tag with + | Some Stats.Stat_reply -> + begin match Stats.decode_stats (Cstruct.of_string data) with + | Ok (ru, vmm, ifs) -> + let ifs = + List.map + (fun x -> + match f x.name with + | Some name -> { x with name } + | None -> x) + ifs + in + let data = Cstruct.to_string (Stats.encode_stats (ru, vmm, ifs)) in + let out = Client.stat data req_id state.client_version in + [ `Tls (s, out) ] + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while decode statistics" msg) ; + let out = fail req_id state.client_version in + [ `Tls (s, out) ] + end + | None when hdr.tag = fail_tag -> + let out = fail ~msg:data req_id state.client_version in + [ `Tls (s, out) ] + | _ -> + Logs.err (fun m -> m "unexpected reply from stat") ; + [] + in + (state, out) + +let handle_cons state hdr data = + let open Vmm_wire in + if not (version_eq hdr.version state.console_version) then begin + Logs.warn (fun m -> m "ignoring message with unknown console version") ; + state, [] + end else match Console.int_to_op hdr.tag with + | Some Console.Data -> + begin match decode_str data with + | Error (`Msg msg) -> + Logs.err (fun m -> m "error while decoding console message %s" msg) ; + (state, []) + | Ok (file, off) -> + (match String.Map.find file state.console_attached with + | Some s -> + let out = Client.console off file data state.client_version in + (state, [ `Tls (s, out) ]) + | None -> + (* TODO: should detach? *) + Logs.err (fun m -> m "couldn't find attached console for %s" file) ; + (state, [])) + end + | None when hdr.tag = success_tag -> + (match IM.find hdr.id state.console_requests with + | exception Not_found -> + (state, []) + | cont -> + let state', outs = cont state in + let console_requests = IM.remove hdr.id state.console_requests in + ({ state' with console_requests }, outs)) + | None when hdr.tag = fail_tag -> + (match IM.find hdr.id state.console_requests with + | exception Not_found -> + Logs.err (fun m -> m "fail couldn't find request id") ; + (state, []) + | _ -> + Logs.err (fun m -> m "failed while trying to do something on console") ; + let console_requests = IM.remove hdr.id state.console_requests in + ({ state with console_requests }, [])) + | _ -> + Logs.err (fun m -> m "unexpected message received from console socket") ; + (state, []) + +let handle_log state hdr buf = + let open Vmm_wire in + let open Vmm_wire.Log in + if not (version_eq hdr.version state.log_version) then begin + Logs.warn (fun m -> m "ignoring message with unknown stats version") ; + state, [] + end else match IM.find hdr.id state.log_requests with + | exception Not_found -> + Logs.warn (fun m -> m "(ignored) coudn't find log request") ; + (state, []) + | (s, rid) -> + let r = match int_to_op hdr.tag with + | Some Data -> + decode_log_hdr (Cstruct.of_string buf) >>= fun (hdr, rest) -> + decode_event rest >>= fun event -> + let tls = Vmm_wire.Client.log hdr event state.client_version in + Ok (state, [ `Tls (s, tls) ]) + | None when hdr.tag = success_tag -> + let log_requests = IM.remove hdr.id state.log_requests in + let tls = Vmm_wire.success rid state.client_version in + Ok ({ state with log_requests }, [ `Tls (s, tls) ]) + | None when hdr.tag = fail_tag -> + let log_requests = IM.remove hdr.id state.log_requests in + let tls = Vmm_wire.fail rid state.client_version in + Ok ({ state with log_requests }, [ `Tls (s, tls) ]) + | _ -> + Logs.err (fun m -> m "couldn't parse log reply") ; + let log_requests = IM.remove hdr.id state.log_requests in + Ok ({ state with log_requests }, []) + in + match r with + | Ok (s, out) -> s, out + | Error (`Msg msg) -> + Logs.err (fun m -> m "error while processing log %s" msg) ; + state, [] diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 558d59b..74d2fcf 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -14,6 +14,7 @@ end module IS = Set.Make(I) module IM = Map.Make(I) +module IM64 = Map.Make(Int64) type permission = [ `All | `Info | `Create | `Block | `Statistics | `Console | `Log | `Crl | `Force_create] @@ -88,6 +89,17 @@ let cmd_allowed permissions cmd = type vmtype = [ `Ukvm_amd64 | `Ukvm_arm64 | `Ukvm_amd64_compressed ] +let vmtype_to_int = function + | `Ukvm_amd64 -> 0 + | `Ukvm_arm64 -> 1 + | `Ukvm_amd64_compressed -> 2 + +let int_to_vmtype = function + | 0 -> Some `Ukvm_amd64 + | 1 -> Some `Ukvm_arm64 + | 2 -> Some `Ukvm_amd64_compressed + | _ -> None + let pp_vmtype ppf = function | `Ukvm_amd64 -> Fmt.pf ppf "ukvm-amd64" | `Ukvm_amd64_compressed -> Fmt.pf ppf "ukvm-amd64-compressed" @@ -340,7 +352,7 @@ module Log = struct let pp_hdr db ppf (hdr : hdr) = let name = translate_serial db hdr.name in - Fmt.pf ppf "%a: %s" (Ptime.pp_human ~tz_offset_s:0 ()) hdr.ts name + Fmt.pf ppf "%a: %s" (Ptime.pp_human ()) hdr.ts name let hdr context name = { ts = Ptime_clock.now () ; context ; name } @@ -350,10 +362,6 @@ module Log = struct | `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 @@ -371,14 +379,6 @@ module Log = struct | `Stop n -> "stop", n in Fmt.pf ppf "STOPPED %d with %s %a" pid s Fmt.Dump.signal c - | `Block_create (name, size) -> - Fmt.pf ppf "BLOCK_CREATE %s %d" name size - | `Block_destroy name -> Fmt.pf ppf "BLOCK_DESTROY %s" name - | `Delegate (bridges, block) -> - Fmt.pf ppf "DELEGATE %a, block %a" - Fmt.(list ~sep:(unit "; ") string) bridges - Fmt.(option ~none:(unit "no") string) block - (* | `CRL of string *) type msg = hdr * event diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 2e7d6f7..c1f9bba 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -1,4 +1,4 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) open Astring @@ -7,21 +7,12 @@ open Vmm_core open Rresult open R.Infix -type ('a, 'b, 'c) t = { - cmp : 'b -> 'b -> bool ; - console_socket : 'a ; - console_counter : int ; - console_requests : (('a, 'b, 'c) t -> ('a, 'b, 'c) t * [ `Raw of 'a * string | `Tls of 'b * string ] list) IM.t ; - console_attached : 'b String.Map.t ; (* vm_name -> socket *) +type 'a t = { + console_counter : int64 ; console_version : Vmm_wire.version ; - stats_socket : 'a option ; - stats_counter : int ; - stats_requests : ('b * int * (string -> string option)) IM.t ; + stats_counter : int64 ; 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_counter : int64 ; log_version : Vmm_wire.version ; client_version : Vmm_wire.version ; (* TODO: refine, maybe: @@ -29,121 +20,63 @@ type ('a, 'b, 'c) t = { used_bridges : String.Set.t String.Map.t ; (* TODO: used block devices (since each may only be active once) *) resources : Vmm_resources.t ; - tasks : 'c String.Map.t ; - crls : X509.CRL.c list ; + tasks : 'a String.Map.t ; } -let init cmp console_socket stats_socket log_socket = - (* error hard on permission denied etc. *) - let crls = Fpath.(dbdir / "crls") in - (Bos.OS.Dir.exists crls >>= function - | true -> Ok true - | false -> Bos.OS.Dir.create crls) >>= fun _ -> - let err _ x = x in - Bos.OS.Dir.fold_contents ~elements:`Files ~traverse:`None ~err - (fun f acc -> - acc >>= fun acc -> - Bos.OS.File.read f >>= fun data -> - match X509.Encoding.crl_of_cstruct (Cstruct.of_string data) with - | None -> R.error_msgf "couldn't parse CRL %a" Fpath.pp f - | Some crl -> Ok (crl :: acc)) - (Ok []) - crls >>= fun crls -> - crls >>= fun crls -> - Ok { - cmp ; - console_socket ; console_counter = 1 ; console_requests = IM.empty ; - console_attached = String.Map.empty ; console_version = `WV0 ; - stats_socket ; stats_counter = 1 ; stats_requests = IM.empty ; - stats_version = `WV1 ; - log_socket ; log_counter = 1 ; log_attached = String.Map.empty ; - log_version = `WV0 ; log_requests = IM.empty ; - client_version = `WV0 ; - used_bridges = String.Map.empty ; - resources = Vmm_resources.empty ; - tasks = String.Map.empty ; - crls - } - -let asn_version = `AV0 +let init () = { + console_counter = 1L ; console_version = `WV2 ; + stats_counter = 1L ; stats_version = `WV2 ; + log_counter = 1L ; log_version = `WV2 ; + client_version = `WV2 ; + used_bridges = String.Map.empty ; + resources = Vmm_resources.empty ; + tasks = String.Map.empty ; +} 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 + let data = Vmm_wire.Log.log state.log_counter state.log_version hdr event in + let log_counter = Int64.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) + ({ state with log_counter }, `Log data) -let stat state str = - match state.stats_socket with - | None -> [] - | Some s -> [ `Raw (s, str) ] - -let handle_disconnect state t = - Logs.err (fun m -> m "disconnect!!") ; - let rem, console_attached = - String.Map.partition (fun _ s -> state.cmp s t) state.console_attached - in - let out, console_counter = - List.fold_left (fun (acc, ctr) name -> - (acc ^ Vmm_wire.Console.detach ctr state.console_version name, succ ctr)) - ("", state.console_counter) - (fst (List.split (String.Map.bindings rem))) - in - let log_attached = String.Map.fold (fun k v n -> - match List.filter (fun (e, _) -> not (state.cmp t e)) v with - | [] -> n - | xs -> String.Map.add k xs n) - state.log_attached String.Map.empty - in - let out = - if String.length out = 0 then - [] - else - [ (state.console_socket, out) ] - in - { state with console_attached ; console_counter ; log_attached }, out - -let handle_create t vm_config policies = +let handle_create t hdr vm_config (* policies *) = let full = fullname vm_config in (if Vmm_resources.exists t.resources full then Error (`Msg "VM with same name is already running") else Ok ()) >>= fun () -> - Logs.debug (fun m -> m "now checking dynamic policies") ; - Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () -> + (* Logs.debug (fun m -> m "now checking dynamic policies") ; + Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () -> *) (* prepare VM: save VM image to disk, create fifo, ... *) Vmm_unix.prepare vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; - Ok (fun t s -> - (* actually execute the vm *) - Vmm_unix.exec vm_config taps >>= fun vm -> - Logs.debug (fun m -> m "exec()ed vm") ; - Vmm_resources.insert t.resources full vm >>= fun resources -> - let used_bridges = - List.fold_left2 (fun b br ta -> - let old = match String.Map.find br b with - | None -> String.Set.empty - | Some x -> x - in - String.Map.add br (String.Set.add ta old) b) - t.used_bridges vm_config.network taps - in - let t = { t with resources ; used_bridges } in - let t, out = log t (Log.hdr vm_config.prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in - let tls_out = Vmm_wire.success ~msg:"VM started" 0 t.client_version in - Ok (t, `Tls (s, tls_out) :: out, vm)) + (* TODO should we pre-reserve sth in t? *) + let cons = Vmm_wire.Console.add t.console_counter t.console_version full in + Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons ], + `Create (fun t task -> + (* actually execute the vm *) + Vmm_unix.exec vm_config taps >>= fun vm -> + Logs.debug (fun m -> m "exec()ed vm") ; + Vmm_resources.insert t.resources full vm >>= fun resources -> + let tasks = String.Map.add (string_of_id full) task t.tasks in + let used_bridges = + List.fold_left2 (fun b br ta -> + let old = match String.Map.find br b with + | None -> String.Set.empty + | Some x -> x + in + String.Map.add br (String.Set.add ta old) b) + t.used_bridges vm_config.network taps + in + let t = { t with resources ; tasks ; used_bridges } in + let t, out = log t (Log.hdr vm_config.prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in + let data = Vmm_wire.success t.client_version hdr.Vmm_wire.id Vmm_wire.Vm.(op_to_int Create) in + Ok (t, [ `Data data ; out ], vm))) let setup_stats t vm = - let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version (vm_id vm.config) vm.pid vm.taps in - let t = { t with stats_counter = succ t.stats_counter } in - Ok (t, stat t stat_out) + let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version (fullname vm.config) vm.pid vm.taps in + let t = { t with stats_counter = Int64.succ t.stats_counter } in + Ok (t, [ `Stat stat_out ]) let handle_shutdown t vm r = (match Vmm_unix.shutdown vm with @@ -165,386 +98,59 @@ let handle_shutdown t vm r = String.Map.add br (String.Set.remove ta old) b) t.used_bridges vm.config.network vm.taps in - let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version (vm_id vm.config) in + let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version (fullname vm.config) in let tasks = String.Map.remove (vm_id vm.config) t.tasks in - let t = { t with stats_counter = succ t.stats_counter ; resources ; used_bridges ; tasks } in - let t, outs = log t (Log.hdr vm.config.prefix vm.config.vname, - `VM_stop (vm.pid, r)) + let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in + let t, logout = log t (Log.hdr vm.config.prefix vm.config.vname, + `VM_stop (vm.pid, r)) in - (t, stat t stat_out @ outs) + (t, [ `Stat stat_out ; logout ]) -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 +let handle_command t hdr buf = + let msg_to_err = function + | Ok x -> x + | Error (`Msg msg) -> + Logs.debug (fun m -> m "error while processing command: %s" msg) ; + let out = Vmm_wire.fail ~msg t.client_version hdr.Vmm_wire.id in + (t, [ `Data out ], `End) + in + msg_to_err ( + if Vmm_wire.is_reply hdr then begin + Logs.warn (fun m -> m "ignoring reply") ; + Ok (t, [], `End) + end else 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 + else Vmm_wire.decode_strings buf >>= fun (id, _off) -> + match Vmm_wire.Vm.int_to_op hdr.Vmm_wire.tag with | None -> Error (`Msg "unknown command") - | Some x when cmd_allowed perms x -> - begin - Vmm_wire.decode_str buf >>= fun (buf, _l) -> - let arg = if String.length buf = 0 then prefix else prefix @ [buf] in - let vmid = string_of_id arg in - match x with - | Info -> - begin match Vmm_resources.find t.resources arg with - | None -> - Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ; - R.error_msgf "info: %s not found" buf - | Some x -> - let data = - Vmm_resources.fold (fun acc vm -> - acc ^ Vmm_wire.Client.encode_vm vm.config.vname vm) - "" x - in - let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in - Ok (t, [ `Tls (s, out) ]) - end - | Destroy_vm -> - begin match Vmm_resources.find_vm t.resources arg with - | Some vm -> - Vmm_unix.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 on_success t = - let cons = Vmm_wire.Console.history t.console_counter t.console_version vmid Ptime.epoch in - let old = match String.Map.find vmid t.console_attached with - | None -> [] - | Some s -> - let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in - [ `Tls (s, out) ] - in - let console_attached = String.Map.add vmid s t.console_attached in - { t with console_counter = succ t.console_counter ; console_attached }, - `Raw (t.console_socket, cons) :: old + | Some Info -> + Logs.debug (fun m -> m "info %a" pp_id id) ; + begin match Vmm_resources.find t.resources id with + | None -> + Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ; + Error (`Msg "info: not found") + | Some x -> + let data = + Vmm_resources.fold (fun acc vm -> vm :: acc) [] x in - let cons = Vmm_wire.Console.attach t.console_counter t.console_version vmid in - let console_requests = IM.add t.console_counter on_success t.console_requests in - Ok ({ t with console_counter = succ t.console_counter ; console_requests }, - [ `Raw (t.console_socket, cons) ]) - | Detach -> - let cons = Vmm_wire.Console.detach t.console_counter t.console_version vmid in - (match String.Map.find vmid t.console_attached with - | None -> Error (`Msg "not attached") - | Some x when t.cmp x s -> Ok (String.Map.remove vmid t.console_attached) - | Some _ -> Error (`Msg "this socket is not attached")) >>= fun console_attached -> - let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in - Ok ({ t with console_counter = succ t.console_counter ; console_attached }, - [ `Raw (t.console_socket, cons) ; `Tls (s, out) ]) - | Statistics -> - begin match t.stats_socket with - | None -> Error (`Msg "no statistics available") - | Some _ -> match Vmm_resources.find_vm t.resources arg with - | Some vm -> - let stat_out = Vmm_wire.Stats.stat t.stats_counter t.stats_version vmid in - let d = (s, hdr.Vmm_wire.id, translate_tap vm) in - let stats_requests = IM.add t.stats_counter d t.stats_requests in - Ok ({ t with stats_counter = succ t.stats_counter ; stats_requests }, - stat t stat_out) - | _ -> Error (`Msg ("statistics: not found " ^ buf)) - end - | Log -> - begin - let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in - let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in - let log_counter = succ t.log_counter in - Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ]) - end - | Create_block | Destroy_block -> Error (`Msg "NYI") + let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version data in + Ok (t, [ `Data out ], `End) 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_unix.destroy e) ; - (* also revoke all active sessions!? *) - (* TODO: maybe we need a vmm_resources like structure for sessions as well!? *) - let log_attached, kill = - let pid = string_of_id prefix in - match String.Map.find pid t.log_attached with - | None -> t.log_attached, [] - | Some xs -> - (* those where snd v = serial: drop *) - let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in - String.Map.add pid keep t.log_attached, drop - in - (* two things: - 1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above] - 2 revoked CA certs need to wipe subtree (all entries where k starts with prefix @ serial) *) - let log_attached, kill = - String.Map.fold (fun k' v (l, k) -> - if is_sub_id ~super:(prefix@[id]) ~sub:(id_of_string k') then - (l, v @ k) - else - (String.Map.add k' v l, k)) - log_attached - (String.Map.empty, kill) - in - let state, out = - List.fold_left (fun (s, out) (t, _) -> - let s', out' = handle_disconnect s t in - s', out @ out') - ({ t with log_attached }, []) - kill - in - (state, - List.map (fun x -> `Raw x) out, - List.map fst kill) - -let handle_revocation t s leaf chain ca prefix = - Vmm_asn.crl_of_cert leaf >>= fun crl -> - (* verify data (must be signed by the last cert of the chain (or cacert if chain is empty))! *) - let issuer = match chain with - | subca::_ -> subca - | [] -> ca - in - let time = Ptime_clock.now () in - (if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () -> - (* the this_update must be > now, next_update < now, this_update > .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 _, 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.(dbdir / "crls" / string_of_id prefix) in - Bos.OS.File.delete filename >>= fun () -> - Bos.OS.File.write filename (Cstruct.to_string (X509.Encoding.crl_to_cstruct crl)) >>= fun () -> - (* remove crl with same issuer from crls, and inject this one into state *) - let crls = - match local with - | None -> crl :: t.crls - | Some _ -> crl :: List.filter (fun c -> c <> crl) t.crls - in - (* iterate over revoked serials, find active resources, and kill them *) - let newly_revoked = - let old = match local with - | Some x -> List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates x) - | None -> [] - in - let new_rev = List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates crl) in - List.filter (fun n -> not (List.mem n old)) new_rev - in - let t, out, close = - List.fold_left (fun (t, out, close) serial -> - let t', out', close' = handle_single_revocation t prefix serial in - (t', out @ out', close @ close')) - (t, [], []) newly_revoked - in - let tls_out = Vmm_wire.success ~msg:"updated revocation list" 0 t.client_version in - Ok ({ t with crls }, `Tls (s, tls_out) :: out, `Close close) - -let handle_initial t s addr chain ca = - separate_chain chain >>= fun (leaf, chain) -> - Logs.debug (fun m -> m "leaf is %s, chain %a" - (X509.common_name_to_string leaf) - Fmt.(list ~sep:(unit "->") string) - (List.map X509.common_name_to_string chain)) ; - (* TODO here: inspect top-level-cert of chain. - may need to create bridges and/or block device subdirectory (zfs create) *) - let prefix = List.map id chain in - let login_hdr, login_ev = Log.hdr prefix (id leaf), `Login addr in - let t, out = log t (login_hdr, login_ev) in - let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in - Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms -> - (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then - (* convert certificate to vm_config *) - Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config -> - Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ; - (* get names and static resources *) - List.fold_left (fun acc ca -> - acc >>= fun acc -> - Vmm_asn.delegation_of_cert asn_version ca >>= fun res -> - let name = id ca in - Ok ((name, res) :: acc)) - (Ok []) chain >>= fun policies -> - (* check static policies *) - Logs.debug (fun m -> m "now checking static policies") ; - check_policies vm_config (List.map snd policies) >>= fun () -> - let t, task = - let force = List.mem `Force_create perms in - if force then - let fid = vm_id vm_config in - match String.Map.find fid t.tasks with - | None -> t, None - | Some task -> - let kill () = - match Vmm_resources.find_vm t.resources (fullname vm_config) with - | None -> - Logs.err (fun m -> m "found a task, but no vm for %a (%s)" - pp_id (fullname vm_config) fid) - | Some vm -> - Logs.debug (fun m -> m "killing %a now" pp_vm vm) ; - Vmm_unix.destroy vm - in - let tasks = String.Map.remove fid t.tasks in - ({ t with tasks }, Some (kill, task)) - else - t, None - in - let next t sleeper = - handle_create t vm_config policies >>= fun cont -> - let id = vm_id vm_config in - let cons = Vmm_wire.Console.add t.console_counter t.console_version id in - let tasks = String.Map.add id sleeper t.tasks in - Ok ({ t with console_counter = succ t.console_counter ; tasks }, - [ `Raw (t.console_socket, cons) ], - cont) - in - Ok (t, [], `Create (task, next)) - else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then - handle_revocation t s leaf chain ca prefix - else - let log_attached = - if cmd_allowed perms Log then - let pre = string_of_id prefix in - let v = match String.Map.find pre t.log_attached with - | None -> [] - | Some xs -> xs - in - String.Map.add pre ((s, id leaf) :: v) t.log_attached - else - t.log_attached - in - Ok ({ t with log_attached }, [], `Loop (prefix, perms)) - ) >>= fun (t, outs, res) -> - Ok (t, initial_out :: out @ outs, res) - -let handle_stat state hdr data = - let open Vmm_wire in - if not (version_eq hdr.version state.stats_version) then begin - Logs.warn (fun m -> m "ignoring message with unknown stats version") ; - state, [] - end else if hdr.tag = success_tag then - state, [] - else - match IM.find hdr.id state.stats_requests with - | exception Not_found -> - Logs.err (fun m -> m "couldn't find stat request") ; - state, [] - | (s, req_id, f) -> - let stats_requests = IM.remove hdr.id state.stats_requests in - let state = { state with stats_requests } in - let out = - match Stats.int_to_op hdr.tag with - | Some Stats.Stat_reply -> - begin match Stats.decode_stats (Cstruct.of_string data) with - | Ok (ru, vmm, ifs) -> - let ifs = - List.map - (fun x -> - match f x.name with - | Some name -> { x with name } - | None -> x) - ifs - in - let data = Cstruct.to_string (Stats.encode_stats (ru, vmm, ifs)) in - let out = Client.stat data req_id state.client_version in - [ `Tls (s, out) ] - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while decode statistics" msg) ; - let out = fail req_id state.client_version in - [ `Tls (s, out) ] - end - | None when hdr.tag = fail_tag -> - let out = fail ~msg:data req_id state.client_version in - [ `Tls (s, out) ] - | _ -> - Logs.err (fun m -> m "unexpected reply from stat") ; - [] - in - (state, out) - -let handle_cons state hdr data = - let open Vmm_wire in - if not (version_eq hdr.version state.console_version) then begin - Logs.warn (fun m -> m "ignoring message with unknown console version") ; - state, [] - end else match Console.int_to_op hdr.tag with - | Some Console.Data -> - begin match decode_str data with - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while decoding console message %s" msg) ; - (state, []) - | Ok (file, off) -> - (match String.Map.find file state.console_attached with - | Some s -> - let out = Client.console off file data state.client_version in - (state, [ `Tls (s, out) ]) - | None -> - (* TODO: should detach? *) - Logs.err (fun m -> m "couldn't find attached console for %s" file) ; - (state, [])) - end - | None when hdr.tag = success_tag -> - (match IM.find hdr.id state.console_requests with - | exception Not_found -> - (state, []) - | cont -> - let state', outs = cont state in - let console_requests = IM.remove hdr.id state.console_requests in - ({ state' with console_requests }, outs)) - | None when hdr.tag = fail_tag -> - (match IM.find hdr.id state.console_requests with - | exception Not_found -> - Logs.err (fun m -> m "fail couldn't find request id") ; - (state, []) - | _ -> - Logs.err (fun m -> m "failed while trying to do something on console") ; - let console_requests = IM.remove hdr.id state.console_requests in - ({ state with console_requests }, [])) - | _ -> - Logs.err (fun m -> m "unexpected message received from console socket") ; - (state, []) - -let handle_log state hdr buf = - let open Vmm_wire in - let open Vmm_wire.Log in - if not (version_eq hdr.version state.log_version) then begin - Logs.warn (fun m -> m "ignoring message with unknown stats version") ; - state, [] - end else match IM.find hdr.id state.log_requests with - | exception Not_found -> - Logs.warn (fun m -> m "(ignored) coudn't find log request") ; - (state, []) - | (s, rid) -> - let r = match int_to_op hdr.tag with - | Some Data -> - decode_log_hdr (Cstruct.of_string buf) >>= fun (hdr, rest) -> - decode_event rest >>= fun event -> - let tls = Vmm_wire.Client.log hdr event state.client_version in - Ok (state, [ `Tls (s, tls) ]) - | None when hdr.tag = success_tag -> - let log_requests = IM.remove hdr.id state.log_requests in - let tls = Vmm_wire.success rid state.client_version in - Ok ({ state with log_requests }, [ `Tls (s, tls) ]) - | None when hdr.tag = fail_tag -> - let log_requests = IM.remove hdr.id state.log_requests in - let tls = Vmm_wire.fail rid state.client_version in - Ok ({ state with log_requests }, [ `Tls (s, tls) ]) - | _ -> - Logs.err (fun m -> m "couldn't parse log reply") ; - let log_requests = IM.remove hdr.id state.log_requests in - Ok ({ state with log_requests }, []) - in - match r with - | Ok (s, out) -> s, out - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while processing log %s" msg) ; - state, [] + | Some Create -> + Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config -> + handle_create t hdr vm_config + | Some Destroy -> + match Vmm_resources.find_vm t.resources id with + | Some vm -> + Vmm_unix.destroy vm ; + let id_str = string_of_id id in + let out, next = + let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in + let s = [ `Data success ] in + match String.Map.find_opt id_str t.tasks with + | None -> s, `End + | Some t -> [], `Wait (t, s) + in + let tasks = String.Map.remove id_str t.tasks in + Ok ({ t with tasks }, out, next) + | None -> Error (`Msg "destroy: not found")) diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml index bfaff67..80dfb34 100644 --- a/src/vmm_lwt.ml +++ b/src/vmm_lwt.ml @@ -2,6 +2,11 @@ open Lwt.Infix +let pp_sockaddr ppf = function + | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str + | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d" + (Unix.string_of_inet_addr addr) port + let pp_process_status ppf = function | Unix.WEXITED c -> Fmt.pf ppf "exited with %d" c | Unix.WSIGNALED s -> Fmt.pf ppf "killed by signal %a" Fmt.Dump.signal s @@ -36,8 +41,8 @@ let wait_and_clear pid stdout = Logs.debug (fun m -> m "pid %d exited: %a" pid pp_process_status s) ; ret s -let read_exactly s = - let buf = Bytes.create 8 in +let read_wire s = + let buf = Bytes.create (Int32.to_int Vmm_wire.header_size) in let rec r b i l = Lwt.catch (fun () -> Lwt_unix.read s b i l >>= function @@ -53,29 +58,28 @@ let read_exactly s = let err = Printexc.to_string e in Logs.err (fun m -> m "exception %s while reading" err) ; Lwt.return (Error `Exception)) - in - r buf 0 8 >>= function + r buf 0 (Int32.to_int Vmm_wire.header_size) >>= function | Error e -> Lwt.return (Error e) | Ok () -> - match Vmm_wire.parse_header (Bytes.to_string buf) with + match Vmm_wire.decode_header (Cstruct.of_bytes buf) with | Error (`Msg m) -> Lwt.return (Error (`Msg m)) | Ok hdr -> - let l = hdr.Vmm_wire.length in + let l = Int32.to_int hdr.Vmm_wire.length in if l > 0 then let b = Bytes.create l in r b 0 l >|= function | Error e -> Error e | Ok () -> - (* Logs.debug (fun m -> m "read hdr %a, body %a" + 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) + Cstruct.hexdump_pp (Cstruct.of_bytes b)) ; + Ok (hdr, Cstruct.of_bytes b) else - Lwt.return (Ok (hdr, "")) + Lwt.return (Ok (hdr, Cstruct.empty)) -let write_raw s buf = - let buf = Bytes.unsafe_of_string buf in +let write_wire s buf = + let buf = Cstruct.to_bytes buf in let rec w off l = Lwt.catch (fun () -> Lwt_unix.send s buf off l [] >>= fun n -> @@ -87,5 +91,10 @@ let write_raw s buf = Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ; Lwt.return (Error `Exception)) in - (* Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *) + Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; w 0 (Bytes.length buf) + +let safe_close fd = + Lwt.catch + (fun () -> Lwt_unix.close fd) + (fun _ -> Lwt.return_unit) diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 671fea3..b41d40a 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -26,14 +26,14 @@ let read_tls t = Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ; Lwt.return (Error `Exception)) in - let buf = Cstruct.create 8 in - r_n buf 0 8 >>= function + let buf = Cstruct.create (Int32.to_int Vmm_wire.header_size) in + r_n buf 0 (Int32.to_int Vmm_wire.header_size) >>= function | Error e -> Lwt.return (Error e) | Ok () -> - match Vmm_wire.parse_header (Cstruct.to_string buf) with + match Vmm_wire.decode_header buf with | Error (`Msg m) -> Lwt.return (Error (`Msg m)) | Ok hdr -> - let l = hdr.Vmm_wire.length in + let l = Int32.to_int hdr.Vmm_wire.length in if l > 0 then let b = Cstruct.create l in r_n b 0 l >|= function diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 0fc77d0..26330bf 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -3,124 +3,148 @@ (* 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 + - tag (32 bit) the type of message + it is only 31 bit, the highest (leftmost) bit indicates query (0) or reply (1) + a failure is reported with the special tag 0xFFFFFFFF (all bits set) - data is a string + every request leads to a reply + WV0 and WV1 used 16 bit only + - version (16 bit) the version used on this channel (used to be byte 4-6) + - padding (16 bit) + - id (64 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) + - length (32 bit) spanning the message (excluding the 20 bytes header) + - full VM name (i.e. foo.bar.baz) encoded as size of list followed by list of strings + - replies do not contain the VM name 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. *) + client. + + every command issued is replied to with success or failure. broadcast + communication (console data, log events) are not acknowledged by the + recipient. + *) + + +(* TODO unlikely that this is 32bit clean *) open Astring open Vmm_core -type version = [ `WV0 | `WV1 ] +type version = [ `WV0 | `WV1 | `WV2 ] let version_to_int = function | `WV0 -> 0 | `WV1 -> 1 + | `WV2 -> 2 let version_of_int = function | 0 -> Ok `WV0 | 1 -> Ok `WV1 + | 2 -> Ok `WV2 | _ -> Error (`Msg "unknown wire version") let version_eq a b = match a, b with | `WV0, `WV0 -> true | `WV1, `WV1 -> true + | `WV2, `WV2 -> true | _ -> false let pp_version ppf v = Fmt.string ppf (match v with | `WV0 -> "wire version 0" - | `WV1 -> "wire version 1") + | `WV1 -> "wire version 1" + | `WV2 -> "wire version 2") type header = { - length : int ; - id : int ; version : version ; - tag : int ; + tag : int32 ; + length : int32 ; + id : int64 ; } +let header_size = 20l + +let max_size = 0x7FFFFFFFl + +(* Throughout this module, we don't expect any cstruct bigger than the above + max_size (encode checks this!) *) + open Rresult open R.Infix + +let cs_create len = Cstruct.create (Int32.to_int len) + +let cs_len cs = + let l = Cstruct.len cs in + assert (l lsr 31 = 0) ; + Int32.of_int l + let check_len cs l = - if Cstruct.len cs < l then + if Int32.compare (cs_len cs) l = -1 then Error (`Msg "underflow") else Ok () +let cs_shift cs num = + check_len cs (Int32.of_int num) >>= fun () -> + Ok (Cstruct.shift cs num) + let check_exact cs l = - if Cstruct.len cs = l then + if cs_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 decode_header cs = + check_len cs 8l >>= fun () -> + let version = Cstruct.BE.get_uint16 cs 4 in + version_of_int version >>= function + | `WV0 | `WV1 -> Error (`Msg "unsupported version") + | `WV2 as version -> + check_len cs header_size >>= fun () -> + let tag = Cstruct.BE.get_uint32 cs 0 + and id = Cstruct.BE.get_uint64 cs 8 + and length = Cstruct.BE.get_uint32 cs 16 + in + 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 encode_header { length ; id ; version ; tag } = + match version with + | `WV0 | `WV1 -> invalid_arg "version no longer supported" + | `WV2 -> + let hdr = cs_create header_size in + Cstruct.BE.set_uint32 hdr 0 tag ; + Cstruct.BE.set_uint16 hdr 4 (version_to_int version) ; + Cstruct.BE.set_uint64 hdr 8 id ; + Cstruct.BE.set_uint32 hdr 16 length ; + hdr + +let max_str_len = 0xFFFF let decode_string cs = - check_len cs 2 >>= fun () -> + check_len cs 2l >>= fun () -> let l = Cstruct.BE.get_uint16 cs 0 in - check_len cs (2 + l) >>= fun () -> + check_len cs (Int32.add 2l (Int32.of_int 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 + assert (l < max_str_len) ; 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) + cs let max = Int64.of_int max_int let min = Int64.of_int min_int let decode_int ?(off = 0) cs = + check_len cs Int32.(add (of_int off) 8l) >>= fun () -> let i = Cstruct.BE.get_uint64 cs off in if i > max then Error (`Msg "int too big") @@ -134,35 +158,64 @@ let encode_int i = 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) +let decode_list inner buf = + decode_int buf >>= fun len -> + let rec go acc idx = function + | 0 -> Ok (List.rev acc, idx) + | n -> + cs_shift buf idx >>= fun cs' -> + inner cs' >>= fun (data, len) -> + go (data :: acc) (idx + len) (pred n) + in + go [] 8 len -(* 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 encode_list inner data = + let cs = encode_int (List.length data) in + Cstruct.concat (cs :: (List.map inner data)) -let decode_ptime cs = - check_len cs 16 >>= fun () -> - decode_int cs >>= fun d -> - let ps = Cstruct.BE.get_uint64 cs 8 in +let decode_strings = decode_list decode_string + +let encode_strings = encode_list encode_string + +let encode ?name ?body version id tag = + let vm = match name with None -> Cstruct.empty | Some id -> encode_strings id in + let payload = match body with None -> Cstruct.empty | Some x -> x in + let header = + let length = Int32.(add (cs_len payload) (cs_len vm)) in + { length ; id ; version ; tag } + in + Cstruct.concat [ encode_header header ; vm ; payload ] + +let maybe_str = function + | None -> Cstruct.empty + | Some c -> encode_string c + +let fail_tag = 0xFFFFFFFFl + +let reply_tag = 0x80000000l + +let is_tag v tag = Int32.logand v tag = v + +let is_reply { tag ; _ } = is_tag reply_tag tag + +let is_fail { tag ; _ } = is_tag fail_tag tag + +let reply ?body version id tag = + encode ?body version id (Int32.logor reply_tag tag) + +let fail ?msg version id = + encode ~body:(maybe_str msg) version id fail_tag + +let success ?msg version id tag = + reply ~body:(maybe_str msg) version id tag + +let decode_ptime ?(off = 0) cs = + cs_shift cs off >>= fun cs' -> + check_len cs' 16l >>= 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 @@ -170,99 +223,70 @@ let encode_ptime ts = Cstruct.BE.set_uint64 cs 8 ps ; cs -let fail_tag = 0xFFFE -let success_tag = 0xFFFF - -let may_enc_str = function - | None -> empty, 0 - | Some msg -> encode_string msg - -let success ?msg id version = - let data, length = may_enc_str msg in - let r = - Cstruct.append - (create_header { length ; id ; version ; tag = success_tag }) data - in - Cstruct.to_string r - -let fail ?msg id version = - let data, length = may_enc_str msg in - let r = - Cstruct.append - (create_header { length ; id ; version ; tag = fail_tag }) data - in - Cstruct.to_string r - module Console = struct - [%%cenum - type op = - | Add_console - | Attach_console - | Detach_console - | History - | Data - [@@uint16_t] - ] + type op = + | Add_console + | Attach_console + | Detach_console + | History + | Data (* is a reply, never acked *) - 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 op_to_int = function + | Add_console -> 0x0100l + | Attach_console -> 0x0101l + | Detach_console -> 0x0102l + | History -> 0x0103l + | Data -> 0x0104l - let data ?(id = 0) v file ts msg = - let payload = + let int_to_op = function + | 0x0100l -> Some Add_console + | 0x0101l -> Some Attach_console + | 0x0102l -> Some Detach_console + | 0x0103l -> Some History + | 0x0104l -> Some Data + | _ -> None + + let data version name ts msg = + let body = let ts = encode_ptime ts - and data, _ = encode_string msg + and data = encode_string msg in Cstruct.append ts data in - encode id v Data ~payload file + encode version ~name ~body 0L (op_to_int Data) - let add id v name = encode id v Add_console name + let add id version name = encode ~name version id (op_to_int Add_console) - let attach id v name = encode id v Attach_console name + let attach id version name = encode ~name version id (op_to_int Attach_console) - let detach id v name = encode id v Detach_console name + let detach id version name = encode ~name version id (op_to_int Detach_console) - let history id v name since = - let payload = encode_ptime since in - encode id v History ~payload name + let history id version name since = + let body = encode_ptime since in + encode ~name ~body version id (op_to_int History) end module Stats = struct - [%%cenum - type op = - | Add - | Remove - | Stat_request - | Stat_reply - [@@uint16_t] - ] + type op = + | Add + | Remove + | Stats - let encode id version op ?payload nam = - let data, l = encode_string nam in - let length, p = - match payload with - | None -> l, empty - | Some x -> l + Cstruct.len x, x - and tag = op_to_int op - in - let r = - Cstruct.concat [ create_header { length ; version ; id ; tag } ; data ; p ] - in - Cstruct.to_string r + let op_to_int = function + | Add -> 0x0200l + | Remove -> 0x0201l + | Stats -> 0x0202l + + let int_to_op = function + | 0x0200l -> Some Add + | 0x0201l -> Some Remove + | 0x0202l -> Some Stats + | _ -> None + + let rusage_len = 144l let encode_rusage ru = - let cs = Cstruct.create (18 * 8) in + let cs = cs_create rusage_len 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) ; @@ -284,7 +308,7 @@ module Stats = struct cs let decode_rusage cs = - check_exact cs 144 >>= fun () -> + check_exact cs rusage_len >>= 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 -> @@ -307,9 +331,11 @@ module Stats = struct Ok { utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ; nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw } + let ifdata_len = 116l + let encode_ifdata i = - let name, _ = encode_string i.name in - let cs = Cstruct.create (12 * 8 + 5 * 4) in + let name = encode_string i.name in + let cs = cs_create ifdata_len 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 ; @@ -331,8 +357,8 @@ module Stats = struct let decode_ifdata buf = decode_string buf >>= fun (name, l) -> - check_len buf (l + 116) >>= fun () -> - let cs = Cstruct.shift buf l in + cs_shift buf l >>= fun cs -> + check_len cs ifdata_len >>= fun () -> 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 @@ -355,24 +381,18 @@ module Stats = struct baudrate ; input_packets ; input_errors ; output_packets ; output_errors ; collisions ; input_bytes ; output_bytes ; input_mcast ; output_mcast ; input_dropped ; output_dropped }, - l + 116) + Int32.(to_int ifdata_len) + l) - let add id v nam pid taps = - let payload = Cstruct.append (encode_pid pid) (encode_strings taps) in - encode id v Add ~payload nam + let add id version name pid taps = + let body = Cstruct.append (encode_int pid) (encode_strings taps) in + encode ~name ~body version id (op_to_int Add) - let remove id v nam = encode id v Remove nam + let remove id version name = encode ~name version id (op_to_int Remove) - let stat id v nam = encode id v Stat_request nam + let stat id version name = encode ~name version id (op_to_int Stats) - let stat_reply id version payload = - let length = Cstruct.len payload - and tag = op_to_int Stat_reply - in - let r = - Cstruct.append (create_header { length ; id ; version ; tag }) payload - in - Cstruct.to_string r + let stat_reply id version body = + reply ~body version id (op_to_int Stats) let encode_int64 i = let cs = Cstruct.create 8 in @@ -380,87 +400,76 @@ module Stats = struct cs let decode_int64 ?(off = 0) cs = - check_len cs (8 + off) >>= fun () -> + check_len cs (Int32.add 8l (Int32.of_int off)) >>= fun () -> Ok (Cstruct.BE.get_uint64 cs off) - let encode_vmm_stats xs = - encode_int (List.length xs) :: - List.flatten - (List.map (fun (k, v) -> [ fst (encode_string k) ; encode_int64 v ]) xs) + let encode_vmm_stats = + encode_list + (fun (k, v) -> Cstruct.append (encode_string k) (encode_int64 v)) - let decode_vmm_stats cs = - let rec go acc ctr buf = - if ctr = 0 then - Ok (List.rev acc, buf) - else + let decode_vmm_stats = + decode_list (fun buf -> decode_string buf >>= fun (str, off) -> decode_int64 ~off buf >>= fun v -> - go ((str, v) :: acc) (pred ctr) (Cstruct.shift buf (off + 8)) - in - decode_int cs >>= fun stat_num -> - go [] stat_num (Cstruct.shift cs 8) + Ok ((str, v), off + 8)) let encode_stats (ru, vmm, ifd) = Cstruct.concat - (encode_rusage ru :: - encode_vmm_stats vmm @ - encode_int (List.length ifd) :: List.map encode_ifdata ifd) + [ encode_rusage ru ; + encode_vmm_stats vmm ; + encode_list encode_ifdata ifd ] let decode_stats cs = - check_len cs 144 >>= fun () -> - let ru, rest = Cstruct.split cs 144 in + check_len cs rusage_len >>= fun () -> + let ru, rest = Cstruct.split cs (Int32.to_int rusage_len) in decode_rusage ru >>= fun ru -> - decode_vmm_stats rest >>= fun (vmm, rest) -> - let rec go acc ctr buf = - if ctr = 0 then - Ok (List.rev acc, buf) - else - decode_ifdata buf >>= fun (this, used) -> - go (this :: acc) (pred ctr) (Cstruct.shift buf used) - in - decode_int rest >>= fun num_if -> - go [] num_if (Cstruct.shift rest 8) >>= fun (ifs, _rest) -> + decode_vmm_stats rest >>= fun (vmm, off) -> + cs_shift rest off >>= fun rest' -> + decode_list decode_ifdata rest' >>= fun (ifs, _) -> Ok (ru, vmm, ifs) let decode_pid_taps data = - decode_pid data >>= fun pid -> - decode_strings (Cstruct.shift data 4) >>= fun taps -> + decode_int data >>= fun pid -> + decode_strings (Cstruct.shift data 8) >>= fun (taps, _off) -> Ok (pid, taps) end +let decode_id_ts cs = + decode_strings cs >>= fun (id, off) -> + decode_ptime ~off cs >>= fun ts -> + Ok ((id, ts), off + 16) + +let split_id id = match List.rev id with + | [] -> Error (`Msg "bad header") + | name::rest -> Ok (name, List.rev rest) + module Log = struct - [%%cenum - type op = - | Data - | History - [@@uint16_t] - ] + type op = + | Log + | History + | Broadcast + | Subscribe - 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 op_to_int = function + | Log -> 0x0300l + | History -> 0x0301l + | Broadcast -> 0x0302l + | Subscribe -> 0x0303l - 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 int_to_op = function + | 0x0300l -> Some Log + | 0x0301l -> Some History + | 0x0302l -> Some Broadcast + | 0x0303l -> Some Subscribe + | _ -> None + + let history id version name ts = + encode ~name ~body:(encode_ptime ts) version id (op_to_int History) 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) + decode_id_ts cs >>= fun ((id, ts), off) -> + split_id id >>= fun (name, context) -> + Ok ({ Log.ts ; context ; name }, Cstruct.shift cs (16 + off)) let encode_addr ip port = let cs = Cstruct.create 6 in @@ -469,24 +478,25 @@ module Log = struct cs let decode_addr cs = - check_len cs 6 >>= fun () -> + check_len cs 6l >>= 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 cs = encode_int 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_int cs >>= fun pid -> + let r = Cstruct.shift cs 8 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 -> + cs_shift r l >>= fun r' -> + decode_strings r' >>= fun taps -> Ok (pid, taps, block) let encode_pid_exit pid c = @@ -495,19 +505,17 @@ module Log = struct | `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 + let r_cs = encode_int r + and pid_cs = encode_int pid + and c_cs = encode_int c in - Cstruct.concat [ pid ; cs ; code ] + Cstruct.concat [ pid_cs ; r_cs ; c_cs ] 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 -> + check_len cs 24l >>= fun () -> + decode_int cs >>= fun pid -> + decode_int ~off:8 cs >>= fun r -> + decode_int ~off:16 cs >>= fun c -> (match r with | 0 -> Ok (`Exit c) | 1 -> Ok (`Signal c) @@ -515,43 +523,20 @@ module Log = struct | _ -> 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 + | `Startup -> 0, Cstruct.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 () -> + check_len cs 2l >>= fun () -> let data = Cstruct.(shift cs 2) in match Cstruct.BE.get_uint16 cs 0 with | 0 -> Ok `Startup @@ -559,55 +544,139 @@ module Log = struct | 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 + let log id version hdr event = + let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) + and name = hdr.Log.context @ [ hdr.Log.name ] 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 + encode ~name ~body version id (op_to_int Log) end -module Client = struct - let cmd_to_int = function - | Info -> 0 - | Destroy_vm -> 1 - | Create_block -> 2 - | Destroy_block -> 3 - | Statistics -> 4 - | Attach -> 5 - | Detach -> 6 - | Log -> 7 - and cmd_of_int = function - | 0 -> Some Info - | 1 -> Some Destroy_vm - | 2 -> Some Create_block - | 3 -> Some Destroy_block - | 4 -> Some Statistics - | 5 -> Some Attach - | 6 -> Some Detach - | 7 -> Some Log +module Vm = struct + type op = + | Create + | Destroy + | Info + (* | Add_policy *) + + let op_to_int = function + | Create -> 0x0400l + | Destroy -> 0x0401l + | Info -> 0x0402l + + let int_to_op = function + | 0x0400l -> Some Create + | 0x0401l -> Some Destroy + | 0x0402l -> Some Info | _ -> None - let console_msg_tag = 0xFFF0 - let log_msg_tag = 0xFFF1 - let stat_msg_tag = 0xFFF2 - let info_msg_tag = 0xFFF3 + let info id version name = + encode ~name version id (op_to_int Info) + + let encode_vm vm = + let name = encode_strings (vm.config.prefix @ [ vm.config.vname ]) + and memory = encode_int vm.config.requested_memory + and cs = encode_string (Bos.Cmd.to_string vm.cmd) + and pid = encode_int vm.pid + and taps = encode_strings vm.taps + in + Cstruct.concat [ name ; memory ; cs ; pid ; taps ] + + let info_reply id version vms = + let body = encode_list encode_vm vms in + reply ~body version id (op_to_int Info) + + let decode_vm cs = + decode_strings cs >>= fun (id, l) -> + cs_shift cs l >>= fun cs' -> + decode_int cs' >>= fun memory -> + cs_shift cs' 8 >>= fun cs'' -> + decode_string cs'' >>= fun (cmd, l') -> + cs_shift cs'' l' >>= fun cs''' -> + decode_int cs''' >>= fun pid -> + cs_shift cs''' 8 >>= fun cs'''' -> + decode_strings cs'''' >>= fun (taps, l'') -> + Ok ((id, memory, cmd, pid, taps), l + 8 + l' + l'') + + let decode_vms buf = decode_list decode_vm buf + + let encode_vm_config vm = + let cpu = encode_int vm.cpuid + and mem = encode_int vm.requested_memory + and block = encode_string (match vm.block_device with None -> "" | Some x -> x) + and network = encode_strings vm.network + and vmimage = Cstruct.concat [ encode_int (vmtype_to_int (fst vm.vmimage)) ; + encode_int (Cstruct.len (snd vm.vmimage)) ; + snd vm.vmimage ] + and args = encode_strings (match vm.argv with None -> [] | Some args -> args) + in + Cstruct.concat [ cpu ; mem ; block ; network ; vmimage ; args ] + + let decode_vm_config buf = + decode_strings buf >>= fun (id, off) -> + Logs.debug (fun m -> m "vm_config id %a" pp_id id) ; + split_id id >>= fun (vname, prefix) -> + cs_shift buf off >>= fun buf' -> + decode_int buf' >>= fun cpuid -> + Logs.debug (fun m -> m "cpuid %d" cpuid) ; + decode_int ~off:8 buf' >>= fun requested_memory -> + Logs.debug (fun m -> m "mem %d" requested_memory) ; + cs_shift buf' 16 >>= fun buf'' -> + decode_string buf'' >>= fun (block, off) -> + Logs.debug (fun m -> m "block %s" block) ; + cs_shift buf'' off >>= fun buf''' -> + let block_device = if block = "" then None else Some block in + decode_strings buf''' >>= fun (network, off') -> + cs_shift buf''' off' >>= fun buf'''' -> + decode_int buf'''' >>= fun vmtype -> + (match int_to_vmtype vmtype with + | Some x -> Ok x + | None -> Error (`Msg "unknown vmtype")) >>= fun vmtype -> + decode_int ~off:8 buf'''' >>= fun size -> + check_len buf'''' (Int32.of_int size) >>= fun () -> + let vmimage = (vmtype, Cstruct.sub buf'''' 16 size) in + cs_shift buf'''' (16 + size) >>= fun buf''''' -> + decode_strings buf''''' >>= fun (argv, _) -> + let argv = match argv with [] -> None | xs -> Some xs in + Ok { vname ; prefix ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } + + let create id version vm = + let body = encode_vm_config vm in + let name = vm.prefix @ [ vm.vname ] in + encode ~name ~body version id (op_to_int Create) + + let destroy id version name = + encode ~name version id (op_to_int Destroy) +end + +(* +module Client = struct + let cmd_to_int = function + | Info -> 0x0500l + | Destroy_vm -> 0x0501l + | Create_block -> 0x0502l + | Destroy_block -> 0x0503l + | Statistics -> 0x0504l + | Attach -> 0x0505l + | Detach -> 0x0506l + | Log -> 0x0507l + and cmd_of_int = function + | 0x0500l -> Some Info + | 0x0501l -> Some Destroy_vm + | 0x0502l -> Some Create_block + | 0x0503l -> Some Destroy_block + | 0x0504l -> Some Statistics + | 0x0505l -> Some Attach + | 0x0506l -> Some Detach + | 0x0507l -> Some Log + | _ -> None let cmd ?arg it id version = let pay, length = may_enc_str arg and tag = cmd_to_int it in + let length = Int32.of_int length in let hdr = create_header { length ; id ; version ; tag } in Cstruct.(to_string (append hdr pay)) @@ -617,17 +686,17 @@ module Client = struct (Log.encode_log_hdr ~drop_context:true hdr) (Log.encode_event event) in - let length = Cstruct.len payload in + let length = cs_len payload in let r = Cstruct.append - (create_header { length ; id = 0 ; version ; tag = log_msg_tag }) + (create_header { length ; id = 0L ; version ; tag = Log.(op_to_int Data) }) 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 + let length = Int32.of_int (String.length data) in + let hdr = create_header { length ; id ; version ; tag = Stats.(op_to_int Stat_reply) } in Cstruct.to_string hdr ^ data let console off name payload version = @@ -640,15 +709,16 @@ module Client = struct let p' = Astring.String.drop ~max:off payload in p', l + String.length p' in + let length = Int32.of_int length in let hdr = - create_header { length ; id = 0 ; version ; tag = console_msg_tag } + create_header { length ; id = 0L ; version ; tag = Console.(op_to_int Data) } 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 + let name = encode_string name + and cs = encode_string (Bos.Cmd.to_string vm.cmd) + and pid = encode_int vm.pid and taps = encode_strings vm.taps in let tapc = encode_int (Cstruct.len taps) in @@ -657,13 +727,14 @@ module Client = struct let info data id version = let length = String.length data in - let hdr = create_header { length ; id ; version ; tag = info_msg_tag } in + let length = Int32.of_int length in + let hdr = create_header { length ; id ; version ; tag = success_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 (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 -> @@ -695,3 +766,4 @@ module Client = struct decode_string (Cstruct.shift cs (l + 16)) >>= fun (line, _) -> Ok (name, ts, line) end + *) diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml new file mode 100644 index 0000000..37657b1 --- /dev/null +++ b/src/vmm_x509.ml @@ -0,0 +1,163 @@ + +let asn_version = `AV0 + +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_unix.destroy e) ; + (* also revoke all active sessions!? *) + (* TODO: maybe we need a vmm_resources like structure for sessions as well!? *) + let log_attached, kill = + let pid = string_of_id prefix in + match String.Map.find pid t.log_attached with + | None -> t.log_attached, [] + | Some xs -> + (* those where snd v = serial: drop *) + let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in + String.Map.add pid keep t.log_attached, drop + in + (* two things: + 1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above] + 2 revoked CA certs need to wipe subtree (all entries where k starts with prefix @ serial) *) + let log_attached, kill = + String.Map.fold (fun k' v (l, k) -> + if is_sub_id ~super:(prefix@[id]) ~sub:(id_of_string k') then + (l, v @ k) + else + (String.Map.add k' v l, k)) + log_attached + (String.Map.empty, kill) + in + let state, out = + List.fold_left (fun (s, out) (t, _) -> + let s', out' = handle_disconnect s t in + s', out @ out') + ({ t with log_attached }, []) + kill + in + (state, + List.map (fun x -> `Raw x) out, + List.map fst kill) + +let handle_revocation t s leaf chain ca prefix = + Vmm_asn.crl_of_cert leaf >>= fun crl -> + (* verify data (must be signed by the last cert of the chain (or cacert if chain is empty))! *) + let issuer = match chain with + | subca::_ -> subca + | [] -> ca + in + let time = Ptime_clock.now () in + (if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () -> + (* the this_update must be > now, next_update < now, this_update > .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 _, 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.(dbdir / "crls" / string_of_id prefix) in + Bos.OS.File.delete filename >>= fun () -> + Bos.OS.File.write filename (Cstruct.to_string (X509.Encoding.crl_to_cstruct crl)) >>= fun () -> + (* remove crl with same issuer from crls, and inject this one into state *) + let crls = + match local with + | None -> crl :: t.crls + | Some _ -> crl :: List.filter (fun c -> c <> crl) t.crls + in + (* iterate over revoked serials, find active resources, and kill them *) + let newly_revoked = + let old = match local with + | Some x -> List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates x) + | None -> [] + in + let new_rev = List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates crl) in + List.filter (fun n -> not (List.mem n old)) new_rev + in + let t, out, close = + List.fold_left (fun (t, out, close) serial -> + let t', out', close' = handle_single_revocation t prefix serial in + (t', out @ out', close @ close')) + (t, [], []) newly_revoked + in + let tls_out = Vmm_wire.success ~msg:"updated revocation list" 0 t.client_version in + Ok ({ t with crls }, `Tls (s, tls_out) :: out, `Close close) + +let handle_initial t s addr chain ca = + separate_chain chain >>= fun (leaf, chain) -> + Logs.debug (fun m -> m "leaf is %s, chain %a" + (X509.common_name_to_string leaf) + Fmt.(list ~sep:(unit "->") string) + (List.map X509.common_name_to_string chain)) ; + (* TODO here: inspect top-level-cert of chain. + may need to create bridges and/or block device subdirectory (zfs create) *) + let prefix = List.map id chain in + let login_hdr, login_ev = Log.hdr prefix (id leaf), `Login addr in + let t, out = log t (login_hdr, login_ev) in + let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in + Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms -> + (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then + (* convert certificate to vm_config *) + Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config -> + Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ; + (* get names and static resources *) + List.fold_left (fun acc ca -> + acc >>= fun acc -> + Vmm_asn.delegation_of_cert asn_version ca >>= fun res -> + let name = id ca in + Ok ((name, res) :: acc)) + (Ok []) chain >>= fun policies -> + (* check static policies *) + Logs.debug (fun m -> m "now checking static policies") ; + check_policies vm_config (List.map snd policies) >>= fun () -> + let t, task = + let force = List.mem `Force_create perms in + if force then + let fid = vm_id vm_config in + match String.Map.find fid t.tasks with + | None -> t, None + | Some task -> + let kill () = + match Vmm_resources.find_vm t.resources (fullname vm_config) with + | None -> + Logs.err (fun m -> m "found a task, but no vm for %a (%s)" + pp_id (fullname vm_config) fid) + | Some vm -> + Logs.debug (fun m -> m "killing %a now" pp_vm vm) ; + Vmm_unix.destroy vm + in + let tasks = String.Map.remove fid t.tasks in + ({ t with tasks }, Some (kill, task)) + else + t, None + in + let next t sleeper = + handle_create t vm_config policies >>= fun cont -> + let id = vm_id vm_config in + let cons = Vmm_wire.Console.add t.console_counter t.console_version id in + let tasks = String.Map.add id sleeper t.tasks in + Ok ({ t with console_counter = succ t.console_counter ; tasks }, + [ `Raw (t.console_socket, cons) ], + cont) + in + Ok (t, [], `Create (task, next)) + else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then + handle_revocation t s leaf chain ca prefix + else + let log_attached = + if cmd_allowed perms Log then + let pre = string_of_id prefix in + let v = match String.Map.find pre t.log_attached with + | None -> [] + | Some xs -> xs + in + String.Map.add pre ((s, id leaf) :: v) t.log_attached + else + t.log_attached + in + Ok ({ t with log_attached }, [], `Loop (prefix, perms)) + ) >>= fun (t, outs, res) -> + Ok (t, initial_out :: out @ outs, res) diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index b7cf686..e8268d7 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -192,10 +192,9 @@ let remove_vmid t vmid = let remove_vmids t vmids = List.fold_left remove_vmid t vmids -let handle t hdr buf = +let handle t hdr cs = 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") @@ -205,11 +204,11 @@ let handle t hdr buf = | Some Add -> decode_pid_taps (Cstruct.shift cs off) >>= fun (pid, taps) -> add_pid t name pid taps >>= fun t -> - Ok (t, `Add name, success ~msg:"added" hdr.id my_version) + Ok (t, `Add name, success ~msg:"added" my_version hdr.id (op_to_int Add)) | Some Remove -> let t = remove_vmid t name in - Ok (t, `Remove name, success ~msg:"removed" hdr.id my_version) - | Some Stat_request -> + Ok (t, `Remove name, success ~msg:"removed" my_version hdr.id (op_to_int Remove)) + | Some Stats -> stats t name >>= fun s -> Ok (t, `None, stat_reply hdr.id my_version (encode_stats s)) | _ -> Error (`Msg "unknown command") @@ -218,4 +217,4 @@ let handle t hdr buf = | Ok (t, action, out) -> t, action, out | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing %s" msg) ; - t, `None, fail ~msg hdr.id my_version + t, `None, fail ~msg my_version hdr.id diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml index c8a7731..644cc62 100644 --- a/stats/vmm_stats_lwt.ml +++ b/stats/vmm_stats_lwt.ml @@ -24,11 +24,11 @@ let pp_sockaddr ppf = function let handle s addr () = Logs.info (fun m -> m "handling stats connection %a" pp_sockaddr addr) ; let rec loop acc = - Vmm_lwt.read_exactly s >>= function + Vmm_lwt.read_wire s >>= function | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop acc | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return acc | Ok (hdr, data) -> - Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp (Cstruct.of_string data)) ; + Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ; let t', action, out = Vmm_stats.handle !t hdr data in let acc = match action with | `Add pid -> pid :: acc @@ -36,8 +36,8 @@ let handle s addr () = | `None -> acc in t := t' ; - Logs.debug (fun m -> m "sent %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ; - Vmm_lwt.write_raw s out >>= function + Logs.debug (fun m -> m "sent %a" Cstruct.hexdump_pp out) ; + Vmm_lwt.write_wire s out >>= function | Ok () -> loop acc | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc in From e7b4742964db41c02b0cd3141f905b8f8167ab26 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 19 Sep 2018 21:16:44 +0200 Subject: [PATCH 03/73] less is more, also unify default socket paths and vmmc console command --- app/vmm_console.ml | 55 +++++------- app/vmm_influxdb_stats.ml | 2 +- app/vmm_log.ml | 2 +- app/vmm_tls_endpoint.ml | 2 + app/vmmc.ml | 141 ++++++++++++++++++------------- app/vmmd.ml | 108 ++++++++++++----------- pkg/pkg.ml | 2 +- provision/vmm_provision.ml | 2 +- provision/vmm_req_command.ml | 62 ++++++++++++++ provision/vmm_req_permissions.ml | 46 ---------- provision/vmm_req_vm.ml | 4 +- provision/vmm_revoke.ml | 2 +- provision/vmm_sign.ml | 41 ++++----- src/vmm_asn.ml | 48 +++++++---- src/vmm_asn.mli | 28 +++--- src/vmm_core.ml | 97 ++++++++------------- src/vmm_ring.ml | 18 ++++ src/vmm_wire.ml | 22 ++--- src/vmm_x509.ml | 2 +- stats/vmm_stats_lwt.ml | 2 +- 20 files changed, 359 insertions(+), 327 deletions(-) create mode 100644 provision/vmm_req_command.ml delete mode 100644 provision/vmm_req_permissions.ml diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 65e4563..ae2d781 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -2,12 +2,13 @@ (* 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 *) +(* communication channel is a single unix domain socket. The following commands + can be issued: + - Add name (by vmmd) --> creates a new console slurper for name, + and starts a read_console task + - Attach name --> attaches console of name: send existing stuff to client, + and record the requesting socket to receive further messages. A potential + earlier subscriber to the same console is closed. *) open Lwt.Infix @@ -83,28 +84,18 @@ let attach s id = Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ; match String.Map.find name !t with | None -> Lwt.return (Error (`Msg "not found")) - | Some _ -> - active := String.Map.add name s !active ; - Lwt.return (Ok "attached") - -let detach id = - let name = Vmm_core.string_of_id id in - active := String.Map.remove name !active ; - Lwt.return (Ok "removed") - -let history s name since = - match String.Map.find (Vmm_core.string_of_id name) !t with - | None -> Lwt.return (Rresult.R.error_msgf "ring %a not found (%d): %a" - Vmm_core.pp_id 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 + let entries = Vmm_ring.read r in Logs.debug (fun m -> m "found %d history" (List.length entries)) ; Lwt_list.iter_s (fun (i, v) -> - Vmm_lwt.write_wire s (Vmm_wire.Console.data my_version name i v) >|= fun _ -> ()) - entries >|= fun () -> - Ok "success" + let msg = Vmm_wire.Console.data my_version id i v in + Vmm_lwt.write_wire s msg >|= fun _ -> ()) + entries >>= fun () -> + (match String.Map.find name !active with + | None -> Lwt.return_unit + | Some s -> Vmm_lwt.safe_close s) >|= fun () -> + active := String.Map.add name s !active ; + Ok "attached" let handle s addr () = Logs.info (fun m -> m "handling connection %a" Vmm_lwt.pp_sockaddr addr) ; @@ -120,22 +111,16 @@ let handle s addr () = Logs.err (fun m -> m "unexpected reply") ; loop () | Ok (hdr, data) -> - (if not (Vmm_wire.version_eq hdr.version my_version) then + (if not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) then Lwt.return (Error (`Msg "ignoring data with bad version")) else match Vmm_wire.decode_strings data with | Error e -> Lwt.return (Error e) - | Ok (id, off) -> match Vmm_wire.Console.int_to_op hdr.tag with + | Ok (id, _) -> match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with | Some Vmm_wire.Console.Add_console -> add_fifo id | Some Vmm_wire.Console.Attach_console -> attach s id - | Some Vmm_wire.Console.Detach_console -> detach id - | Some Vmm_wire.Console.History -> - (match Vmm_wire.decode_ptime ~off data with - | Error e -> Lwt.return (Error e) - | Ok since -> history s id since) | Some Vmm_wire.Console.Data -> Lwt.return (Error (`Msg "unexpected Data")) - | None -> - Lwt.return (Error (`Msg "unknown command"))) >>= (function + | None -> Lwt.return (Error (`Msg "unknown command"))) >>= (function | Ok msg -> Vmm_lwt.write_wire s (Vmm_wire.success ~msg my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag) | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; @@ -179,7 +164,7 @@ let setup_log = let socket = let doc = "Socket to listen on" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "cons" + "sock")) in + let sock = Vmm_core.socket_path `Console in Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) let cmd = diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index a13450c..62d389d 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -354,7 +354,7 @@ let host_port : (string * int) Arg.converter = let socket = let doc = "Stat socket to connect onto" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "stat" + "sock")) in + let sock = Vmm_core.socket_path `Stats in Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) let influx = diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 04b1a4e..ba5824e 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -237,7 +237,7 @@ let setup_log = let socket = let doc = "Socket to listen on" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "log" + "sock")) in + let sock = Vmm_core.socket_path `Log in Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) let file = diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 85c100a..af82442 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -154,6 +154,8 @@ let setup_log = $ Fmt_cli.style_renderer () $ Logs_cli.level ()) +(* TODO needs CRL as well, plus socket(s) *) + let cacert = let doc = "CA certificate" in Arg.(required & pos 0 (some file) None & info [] ~doc) diff --git a/app/vmmc.ml b/app/vmmc.ml index df61962..e300dde 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -7,52 +7,6 @@ open Vmm_core let my_version = `WV2 let my_command = 1L -(* -let process db hdr data = - let open Vmm_wire in - let open Rresult.R.Infix in - if not (version_eq hdr.version my_version) then - Logs.err (fun m -> m "unknown wire protocol version") - else - let r = - match hdr.tag with - | x when x = Client.stat_msg_tag -> - Client.decode_stat data >>= fun (ru, vmm, ifd) -> - Logs.app (fun m -> m "statistics: %a %a %a" - pp_rusage ru - Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string uint64)) vmm - Fmt.(list ~sep:(unit ", ") pp_ifdata) ifd) ; - Ok () - | x when x = Client.log_msg_tag -> - Client.decode_log data >>= fun log -> - Logs.app (fun m -> m "log: %a" (Vmm_core.Log.pp db) log) ; - Ok () - | x when x = Client.console_msg_tag -> - Client.decode_console data >>= fun (name, ts, msg) -> - Logs.app (fun m -> m "console %s: %a %s" (translate_serial db name) (Ptime.pp_human ~tz_offset_s:0 ()) ts msg) ; - Ok () - | x when x = Client.info_msg_tag -> - Client.decode_info data >>= fun vms -> - List.iter (fun (name, cmd, pid, taps) -> - Logs.app (fun m -> m "info %s: %s %d taps %a" (translate_serial db name) - cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) - vms ; - Ok () - | x when x = fail_tag -> - decode_str data >>= fun (msg, _) -> - Logs.err (fun m -> m "failed %s" msg) ; - Ok () - | x when x = success_tag -> - decode_str data >>= fun (msg, _) -> - Logs.app (fun m -> m "success %s" msg) ; - Ok () - | x -> Rresult.R.error_msgf "unknown header tag %02X" x - in - match r with - | Ok () -> () - | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg) -*) - let process fd = Vmm_lwt.read_wire fd >|= function | Error _ -> Error () @@ -76,15 +30,19 @@ let process fd = end end -let connect socket = +let socket t = function + | Some x -> x + | None -> Vmm_core.socket_path t + +let connect socket_path = let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in Lwt_unix.set_close_on_exec c ; - Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket) >|= fun () -> + Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> c -let info_ _ socket name = +let info_ _ opt_socket name = Lwt_main.run ( - connect socket >>= fun fd -> + connect (socket `Vmmd opt_socket) >>= fun fd -> let name' = Astring.String.cuts ~empty:false ~sep:"." name in let info = Vmm_wire.Vm.info my_command my_version name' in (Vmm_lwt.write_wire fd info >>= function @@ -105,8 +63,8 @@ let info_ _ socket name = ) ; `Ok () -let really_destroy socket name = - connect socket >>= fun fd -> +let really_destroy opt_socket name = + connect (socket `Vmmd opt_socket) >>= fun fd -> let cmd = Vmm_wire.Vm.destroy my_command my_version (Astring.String.cuts ~empty:false ~sep:"." name) in (Vmm_lwt.write_wire fd cmd >>= function | Ok () -> @@ -116,11 +74,11 @@ let really_destroy socket name = | Error `Exception -> Lwt.return_unit) >>= fun () -> Vmm_lwt.safe_close fd -let destroy _ socket name = - Lwt_main.run (really_destroy socket name) ; +let destroy _ opt_socket name = + Lwt_main.run (really_destroy opt_socket name) ; `Ok () -let create _ socket force name image cpuid requested_memory boot_params block_device network = +let create _ opt_socket force name image cpuid requested_memory boot_params block_device network = let image' = match Bos.OS.File.read (Fpath.v image) with | Ok data -> data | Error (`Msg s) -> invalid_arg s @@ -132,6 +90,7 @@ let create _ socket force name image cpuid requested_memory boot_params block_de and argv = match boot_params with | [] -> None | xs -> Some xs + (* TODO we could do the compression btw *) and vmimage = `Ukvm_amd64, Cstruct.of_string image' in let vm_config = { @@ -140,10 +99,10 @@ let create _ socket force name image cpuid requested_memory boot_params block_de } in Lwt_main.run ( (if force then - really_destroy socket name + really_destroy opt_socket name else Lwt.return_unit) >>= fun () -> - connect socket >>= fun fd -> + connect (socket `Vmmd opt_socket) >>= fun fd -> let vm = Vmm_wire.Vm.create my_command my_version vm_config in (Vmm_lwt.write_wire fd vm >>= function | Error `Exception -> Lwt.return_unit @@ -154,6 +113,58 @@ let create _ socket force name image cpuid requested_memory boot_params block_de ) ; `Ok () +let console _ opt_socket name = + Lwt_main.run ( + connect (socket `Console opt_socket) >>= fun fd -> + let cmd = Vmm_wire.Console.attach my_command my_version (Astring.String.cuts ~empty:false ~sep:"." name) in + (Vmm_lwt.write_wire fd cmd >>= function + | Error `Exception -> + Logs.err (fun m -> m "couldn't write to socket") ; + Lwt.return_unit + | Ok () -> + (* now we busy read and process console output *) + let rec loop () = + Vmm_lwt.read_wire fd >>= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () + | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit + | Ok (hdr, data) -> + Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ; + if Vmm_wire.is_fail hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ; + Lwt.return_unit + else if Vmm_wire.is_reply hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; + loop () + else + let r = + let open Rresult.R.Infix in + match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with + | Some Data -> + Vmm_wire.decode_id_ts data >>= fun ((name, ts), off) -> + Vmm_wire.decode_string (Cstruct.shift data off) >>= fun (msg, _) -> + Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts Vmm_core.pp_id name msg) ; + Ok () + | _ -> + Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)) + in + match r with + | Ok () -> loop () + | Error (`Msg msg) -> + Logs.err (fun m -> m "%s" msg) ; + Lwt.return_unit + in + loop ()) >>= fun () -> + Vmm_lwt.safe_close fd) ; + `Ok () + let help _ _ man_format cmds = function | None -> `Help (`Pager, None) | Some t when List.mem t cmds -> `Help (man_format, Some t) @@ -173,8 +184,7 @@ let setup_log = let socket = let doc = "Socket to connect to" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "vmmd" + "sock")) in - Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) + Arg.(value & opt (some string) None & info [ "s" ; "socket" ] ~doc) let force = let doc = "force VM creation." in @@ -185,7 +195,7 @@ let image = Arg.(required & pos 1 (some file) None & info [] ~doc) let vm_name = - let doc = "Name virtual machine config." in + let doc = "Name virtual machine." in Arg.(required & pos 0 (some string) None & info [] ~doc) let destroy_cmd = @@ -235,6 +245,15 @@ let create_cmd = Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), Term.info "create" ~doc ~man +let console_cmd = + let doc = "console of a VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows console output of a VMs."] + in + Term.(ret (const console $ setup_log $ socket $ vm_name)), + Term.info "console" ~doc ~man + let help_cmd = let topic = let doc = "The topic to get help on. `topics' lists the topics." in @@ -257,7 +276,7 @@ let default_cmd = Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man -let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ] +let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ; console_cmd ] let () = match Term.eval_choice default_cmd cmds diff --git a/app/vmmd.ml b/app/vmmd.ml index 8202458..9b54b4b 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -61,56 +61,63 @@ let handle state out c_fd fd addr = | `Create cont -> (* data contained a write to console, we need to wait for its reply first *) Vmm_lwt.read_wire c_fd >>= function - | Ok (_, data) when Vmm_wire.is_fail hdr -> - Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; - Lwt.return_unit - | Ok (_, _) when Vmm_wire.is_reply hdr -> - (* assert hdr.id = id! *) - (* TODO slightly more tricky, since we need to "Vmm_lwt.wait_and_clear" in here *) - let await, wakeme = Lwt.wait () in - begin match cont !state await with - | Error (`Msg msg) -> - Logs.err (fun m -> m "create continuation failed %s" msg) ; - Lwt.return_unit - | Ok (state'', out, vm) -> - state := state'' ; - s := { !s with vm_created = succ !s.vm_created } ; - Lwt.async (fun () -> - Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> - let state', out' = Vmm_engine.handle_shutdown !state vm r in - s := { !s with vm_destroyed = succ !s.vm_destroyed } ; - state := state' ; - process out' >|= fun () -> - Lwt.wakeup wakeme ()) ; - process out >>= fun () -> - begin match Vmm_engine.setup_stats !state vm with - | Ok (state', out) -> - state := state' ; - process out (* TODO: need to read from stats socket! *) - | Error (`Msg e) -> - Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; - Lwt.return_unit - end + | Ok (hdr, data) -> + if Vmm_wire.is_fail hdr then begin + Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; + Lwt.return_unit + end else if Vmm_wire.is_reply hdr then begin + (* assert hdr.id = id! *) + let await, wakeme = Lwt.wait () in + begin match cont !state await with + | Error (`Msg msg) -> + Logs.err (fun m -> m "create continuation failed %s" msg) ; + Lwt.return_unit + | Ok (state'', out, vm) -> + state := state'' ; + s := { !s with vm_created = succ !s.vm_created } ; + Lwt.async (fun () -> + Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> + let state', out' = Vmm_engine.handle_shutdown !state vm r in + s := { !s with vm_destroyed = succ !s.vm_destroyed } ; + state := state' ; + process out' >|= fun () -> + Lwt.wakeup wakeme ()) ; + process out >>= fun () -> + begin match Vmm_engine.setup_stats !state vm with + | Ok (state', out) -> + state := state' ; + process out (* TODO: need to read from stats socket! *) + | Error (`Msg e) -> + Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; + Lwt.return_unit + end + end + end else begin + Logs.err (fun m -> m "reading from console %lx, %a" hdr.Vmm_wire.tag Cstruct.hexdump_pp data) ; + Lwt.return_unit end - | _ -> + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while reading from console" msg) ; + Lwt.return_unit + | Error _ -> Logs.err (fun m -> m "error while reading from console") ; - Lwt.return_unit) >>= fun () -> + Lwt.return_unit ) >>= fun () -> Vmm_lwt.safe_close fd -let init_sock dir name = +let init_sock sock = + let name = Vmm_core.socket_path sock in let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in Lwt_unix.set_close_on_exec c ; - let addr = Fpath.(dir / name + "sock") in Lwt.catch (fun () -> - Lwt_unix.(connect c (ADDR_UNIX (Fpath.to_string addr))) >|= fun () -> Some c) + Lwt_unix.(connect c (ADDR_UNIX name)) >|= fun () -> Some c) (fun e -> - Logs.warn (fun m -> m "error %s connecting to socket %a" - (Printexc.to_string e) Fpath.pp addr) ; + Logs.warn (fun m -> m "error %s connecting to socket %s" + (Printexc.to_string e) name) ; (Lwt.catch (fun () -> Lwt_unix.close c) (fun _ -> Lwt.return_unit)) >|= fun () -> None) -let create_mbox name = - init_sock Vmm_core.tmpdir name >|= function +let create_mbox sock = + init_sock sock >|= function | None -> None | Some fd -> let mvar = Lwt_mvar.create_empty () in @@ -122,19 +129,18 @@ let create_mbox name = Lwt_mvar.take mvar >>= fun data -> Vmm_lwt.write_wire fd data >>= function | Ok () -> loop () - | Error `Exception -> invalid_arg ("exception while writing to " ^ name) ; + | Error `Exception -> invalid_arg ("exception while writing to " ^ Fmt.to_to_string Vmm_core.pp_socket sock) ; in Lwt.async loop ; Some (mvar, fd) -let server_socket dir name = - let file = Fpath.(dir / name + "sock") in - let sock = Fpath.to_string file in - (Lwt_unix.file_exists sock >>= function - | true -> Lwt_unix.unlink sock +let server_socket sock = + let name = Vmm_core.socket_path sock in + (Lwt_unix.file_exists name >>= function + | true -> Lwt_unix.unlink name | false -> Lwt.return_unit) >>= fun () -> let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in - Lwt_unix.(bind s (ADDR_UNIX sock)) >|= fun () -> + Lwt_unix.(bind s (ADDR_UNIX name)) >|= fun () -> Lwt_unix.listen s 1 ; s @@ -143,15 +149,17 @@ let rec stats_loop () = Lwt_unix.sleep 600. >>= fun () -> stats_loop () +(* TODO nobody reads stat and log file descriptors - that's likely a bad idea! + - create_mbox could after take & write do a read and check for failures! *) let jump _ = Sys.(set_signal sigpipe Signal_ignore) ; Lwt_main.run - (server_socket Vmm_core.tmpdir "vmmd" >>= fun ss -> - (create_mbox "cons" >|= function + (server_socket `Vmmd >>= fun ss -> + (create_mbox `Console >|= function | None -> invalid_arg "cannot connect to console socket" | Some c -> c) >>= fun (c, c_fd) -> - create_mbox "stat" >>= fun s -> - (create_mbox "log" >|= function + create_mbox `Stats >>= fun s -> + (create_mbox `Log >|= function | None -> invalid_arg "cannot connect to log socket" | Some l -> l) >>= fun (l, _l_fd) -> let state = ref (Vmm_engine.init ()) in diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 54bbcbd..259b560 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -12,7 +12,7 @@ let () = (* Pkg.bin "app/vmm_client" ; *) (* Pkg.bin "app/vmm_tls_endpoint" ; *) Pkg.bin "app/vmmc" ; - Pkg.bin "provision/vmm_req_permissions" ; + Pkg.bin "provision/vmm_req_command" ; Pkg.bin "provision/vmm_req_delegation" ; Pkg.bin "provision/vmm_req_vm" ; Pkg.bin "provision/vmm_sign" ; diff --git a/provision/vmm_provision.ml b/provision/vmm_provision.ml index 9579047..0103eda 100644 --- a/provision/vmm_provision.ml +++ b/provision/vmm_provision.ml @@ -1,6 +1,6 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) -let asn_version = `AV0 +let asn_version = `AV1 let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); diff --git a/provision/vmm_req_command.ml b/provision/vmm_req_command.ml new file mode 100644 index 0000000..a57d3ea --- /dev/null +++ b/provision/vmm_req_command.ml @@ -0,0 +1,62 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Vmm_provision + +open Rresult.R.Infix + +open Vmm_asn + +let cmd_csr name key command block_device block_size = + let bd = match block_device with + | None -> [] + | Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ] + in + let bs = match block_size with + | None -> [] + | Some x -> [ (false, `Unsupported (Oid.memory, int_to_cstruct x)) ] + in + let exts = + [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ; + (false, `Unsupported (Oid.command, command_to_cstruct command)) ] @ bd @ bs + and name = [ `CN name ] + in + X509.CA.request name ~extensions:[`Extensions exts] key + +let jump _ name key command block_device block_size = + Nocrypto_entropy_unix.initialize () ; + match + priv_key key name >>= fun key -> + let csr = cmd_csr name key command block_device block_size 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.command_of_string s with + | Some x -> `Ok x + | None -> `Error "invalid command" + in + (parse, Vmm_core.pp_command) + +let command = + let doc = "command" in + Arg.(required & pos 1 (some cmd) None & info [] ~doc) + +let block_device = + let doc = "block device" in + Arg.(value & opt (some string) None & info [ "block-device" ] ~doc) + +let block_size = + let doc = "block size in MB" in + Arg.(value & opt (some int) None & info [ "block-size" ] ~doc) + +let cmd = + Term.(ret (const jump $ setup_log $ nam $ key $ command $ block_device $ block_size)), + Term.info "vmm_req_command" ~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 deleted file mode 100644 index 72abcc2..0000000 --- a/provision/vmm_req_permissions.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -open Vmm_provision - -open Rresult.R.Infix - -open Vmm_asn - -let cmd_csr name key permissions = - let exts = - [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ; - (false, `Unsupported (Oid.permissions, permissions_to_cstruct permissions)) ] - and name = [ `CN name ] - in - X509.CA.request name ~extensions:[`Extensions exts] key - -let jump _ name key permissions = - Nocrypto_entropy_unix.initialize () ; - match - priv_key key name >>= fun key -> - let csr = cmd_csr name key permissions in - let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in - Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc) - with - | Ok () -> `Ok () - | Error (`Msg m) -> `Error (false, m) - -open Cmdliner - -let cmd = - let parse s = - match Vmm_core.permission_of_string s with - | Some x -> `Ok x - | None -> `Error "invalid permission" - in - (parse, Vmm_core.pp_permission) - -let permissions = - let doc = "permissions" in - Arg.(value & opt_all cmd [] & info [ "p" ; "permission" ] ~doc) - -let cmd = - Term.(ret (const jump $ setup_log $ nam $ key $ permissions)), - Term.info "vmm_req_permissions" ~version:"%%VERSION_NUM%%" - -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/provision/vmm_req_vm.ml b/provision/vmm_req_vm.ml index 512abd4..60e1273 100644 --- a/provision/vmm_req_vm.ml +++ b/provision/vmm_req_vm.ml @@ -16,7 +16,7 @@ let vm_csr key name image cpu mem args block net force compression = and net = match net with | [] -> [] | xs -> [ (false, `Unsupported (Oid.network, strings_to_cstruct xs)) ] - and cmd = if force then `Force_create else `Create + and cmd = if force then `Force_create_vm else `Create_vm in let image = match compression with | 0 -> image_to_cstruct (`Ukvm_amd64, image) @@ -29,7 +29,7 @@ let vm_csr key name image cpu mem args block net force compression = (false, `Unsupported (Oid.cpuid, int_to_cstruct cpu)) ; (false, `Unsupported (Oid.memory, int_to_cstruct mem)) ; (false, `Unsupported (Oid.vmimage, image)) ; - (false, `Unsupported (Oid.permissions, permissions_to_cstruct [ cmd ])) ; + (false, `Unsupported (Oid.command, command_to_cstruct cmd)) ; ] @ block @ arg @ net and name = [ `CN name ] in diff --git a/provision/vmm_revoke.ml b/provision/vmm_revoke.ml index 5a04e44..66239b6 100644 --- a/provision/vmm_revoke.ml +++ b/provision/vmm_revoke.ml @@ -45,7 +45,7 @@ let jump _ db cacert cakey crl cn serial = 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.command, Vmm_asn.command_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) diff --git a/provision/vmm_sign.ml b/provision/vmm_sign.ml index 8803ace..b425818 100644 --- a/provision/vmm_sign.ml +++ b/provision/vmm_sign.ml @@ -59,7 +59,7 @@ let sign dbname cacert key csr days = (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 + | false, false -> Ok `Command | _ -> Error (`Msg "cannot categorise signing request")) >>= (function | `Vm -> Logs.app (fun m -> m "categorised as a virtual machine request") ; @@ -160,20 +160,9 @@ let sign dbname cacert key csr days = | None -> s_exts | Some a -> (Vmm_asn.Oid.argv, Vmm_asn.strings_to_cstruct a) :: s_exts in - opt Vmm_asn.Oid.permissions req_exts Vmm_asn.permissions_of_cstruct >>= fun perms -> - Logs.app (fun m -> m "using permission %a" - Fmt.(option ~none:(unit "none") - (list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ; - let perm = match perms with - | Some [ `Force_create ] -> [ `Force_create ] - | Some [ `Create ] -> [ `Create ] - | _ -> - Logs.warn (fun m -> m "weird permissions (%a), replaced with create" - Fmt.(option ~none:(unit "none") - (list ~sep:(unit ", ") Vmm_core.pp_permission)) perms) ; - [ `Create ] - in - let s_exts = (Vmm_asn.Oid.permissions, Vmm_asn.permissions_to_cstruct perm) :: s_exts in + req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command -> + Logs.app (fun m -> m "using command %a" Vmm_core.pp_command command) ; + let s_exts = (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct command) :: s_exts in let exts = List.map (fun x -> (false, `Unsupported x)) s_exts in Ok (exts @ l_exts) | `Delegation -> @@ -254,11 +243,23 @@ let sign dbname cacert key csr days = | 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 + | `Command -> + req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command -> + Logs.app (fun m -> m "a leaf certificate with command %a" + Vmm_core.pp_command command) ; + let s_exts = (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct command) :: s_exts in + (match command with + | `Create_block | `Destroy_block -> + req Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>| fun block_device -> + Logs.app (fun m -> m "block device %s" block_device) ; + (Vmm_asn.Oid.block_device, Vmm_asn.string_to_cstruct block_device) :: s_exts + | _ -> Ok s_exts) >>= fun s_exts -> + (match command with + | `Create_block -> + req Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>| fun block_size -> + Logs.app (fun m -> m "block size %dMB" block_size) ; + (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct block_size) :: s_exts + | _ -> Ok s_exts) >>= fun s_exts -> 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) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 099c1c0..88af92d 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -19,7 +19,7 @@ module Oid = struct 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 *) + (* used in both CA and VM certs, also for block_create *) let memory = m <| 5 (* used only in VM certs *) @@ -29,26 +29,29 @@ module Oid = struct let vmimage = m <| 9 let argv = m <| 10 - (* used in VM certs and other leaf certs *) - let permissions = m <| 42 + (* used in leaf certs *) + let command = m <| 42 (* used in CRL certs *) let crl = m <| 43 end -let perms : permission list Asn.t = - Asn.S.bit_string_flags [ - 0, `All ; (* no *) - 1, `Info ; - 2, `Create ; - 3, `Block ; (* create [name] [size] ; destroy [name] *) +let command : command Asn.t = + let alist = [ + 0, `Info ; + 1, `Create_vm ; + 2, `Force_create_vm ; + 3, `Destroy_vm ; 4, `Statistics ; 5, `Console ; 6, `Log ; 7, `Crl ; - 9, `Force_create ; - (* 10, `Destroy ; (* [name] *) *) + 8, `Create_block ; + 9, `Destroy_block ; ] + in + let rev = List.map (fun (k, v) -> (v, k)) alist in + Asn.S.enumerated (fun i -> List.assoc i alist) (fun k -> List.assoc k rev) open Rresult.R.Infix @@ -118,7 +121,7 @@ let image = let image_of_cstruct, image_to_cstruct = projections_of image -let permissions_of_cstruct, permissions_to_cstruct = projections_of perms +let command_of_cstruct, command_to_cstruct = projections_of command let req label cert oid f = match X509.Extension.unsupported cert oid with @@ -130,23 +133,28 @@ let opt cert oid f = | None -> Ok None | Some (_, data) -> f data >>| fun s -> Some s -type version = [ `AV0 ] +type version = [ `AV0 | `AV1 ] let version_of_int = function | 0 -> Ok `AV0 + | 1 -> Ok `AV1 | _ -> Error (`Msg "couldn't parse version") let version_to_int = function | `AV0 -> 0 + | `AV1 -> 1 let pp_version ppf v = Fmt.int ppf (match v with - | `AV0 -> 0) + | `AV0 -> 0 + | `AV1 -> 1) let version_eq a b = match a, b with | `AV0, `AV0 -> true + | `AV1, `AV1 -> true + | _ -> false let version_to_cstruct v = int_to_cstruct (version_to_int v) @@ -209,6 +217,14 @@ let vm_of_cert prefix cert = let network = match network with None -> [] | Some x -> x in Ok { prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } -let permissions_of_cert version cert = +let command_of_cert version cert = version_of_cert version cert >>= fun () -> - req "permissions" cert Oid.permissions permissions_of_cstruct + req "command" cert Oid.command command_of_cstruct + +let block_device_of_cert version cert = + version_of_cert version cert >>= fun () -> + req "block-device" cert Oid.block_device string_of_cstruct + +let block_size_of_cert version cert = + version_of_cert version cert >>= fun () -> + req "block-size" cert Oid.memory int_of_cstruct diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 6c290f3..30143c9 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -62,10 +62,8 @@ module Oid : sig (** {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 + (** [command] is a [BIT_STRING] denoting the command this certificate. *) + val command : Asn.OID.t (** [crl] is a [OCTET_STRING] denoting the revocation list of the intermediate @@ -76,7 +74,7 @@ end (** {1 Encoding and decoding functions} *) (** The type of versions of the ASN.1 grammar defined above. *) -type version = [ `AV0 ] +type version = [ `AV0 | `AV1 ] (** [version_eq a b] is true if [a] and [b] are equal. *) val version_eq : version -> version -> bool @@ -91,12 +89,12 @@ val version_to_cstruct : version -> Cstruct.t 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 +(** [command_to_cstruct perms] is the DER encoded command. *) +val command_to_cstruct : Vmm_core.command -> 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 +(** [command_of_cstruct buffer] is either a decoded command of the DER encoded + [buffer] or an error. *) +val command_of_cstruct : Cstruct.t -> (Vmm_core.command, [> `Msg of string ]) result (** [bridges_to_cstruct bridges] is the DER encoded bridges. *) val bridges_to_cstruct : Vmm_core.bridge list -> Cstruct.t @@ -157,5 +155,11 @@ 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 +(** [command_of_cert version cert] is either the decoded command, or an error. *) +val command_of_cert : version -> X509.t -> (Vmm_core.command, [> `Msg of string ]) result + +(** [block_device_of_cert version cert] is either the decoded block device, or an error. *) +val block_device_of_cert : version -> X509.t -> (string, [> `Msg of string ]) result + +(** [block_size_of_cert version cert] is either the decoded block size, or an error. *) +val block_size_of_cert : version -> X509.t -> (int, [> `Msg of string ]) result diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 74d2fcf..235c0e3 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -7,6 +7,19 @@ open Rresult.R.Infix let tmpdir = Fpath.(v "/var" / "run" / "albatross") let dbdir = Fpath.(v "/var" / "db" / "albatross") +let socket_path = + let path name = Fpath.(to_string (tmpdir / name + "sock")) in + function + | `Console -> path "console" + | `Vmmd -> path "vmmd" + | `Stats -> path "stat" + | `Log -> path "log" + +let pp_socket ppf t = + let name = socket_path t in + Fmt.pf ppf "socket: %s" name + + module I = struct type t = int let compare : int -> int -> int = compare @@ -16,77 +29,37 @@ module IS = Set.Make(I) module IM = Map.Make(I) module IM64 = Map.Make(Int64) -type permission = - [ `All | `Info | `Create | `Block | `Statistics | `Console | `Log | `Crl | `Force_create] +type command = + [ `Info | `Create_vm | `Force_create_vm | `Destroy_vm + | `Statistics | `Console | `Log | `Crl + | `Create_block | `Destroy_block ] -let pp_permission ppf = function - | `All -> Fmt.pf ppf "all" - | `Info -> Fmt.pf ppf "info" - | `Create -> Fmt.pf ppf "create" - | `Block -> Fmt.pf ppf "block" - | `Statistics -> Fmt.pf ppf "statistics" - | `Console -> Fmt.pf ppf "console" - | `Log -> Fmt.pf ppf "log" - | `Crl -> Fmt.pf ppf "crl" - | `Force_create -> Fmt.pf ppf "force-create" +let pp_command ppf cmd = + Fmt.string ppf @@ match cmd with + | `Info -> "info" + | `Create_vm -> "create-vm" + | `Force_create_vm -> "force-create-vm" + | `Destroy_vm -> "destroy-vm" + | `Statistics -> "statistics" + | `Console -> "console" + | `Log -> "log" + | `Crl -> "crl" + | `Create_block -> "create-block" + | `Destroy_block -> "destroy-block" -let permission_of_string = function - | x when x = "all" -> Some `All +let command_of_string = function | x when x = "info" -> Some `Info - | x when x = "create" -> Some `Create - | x when x = "block" -> Some `Block + | x when x = "create-vm" -> Some `Create_vm + | x when x = "force-create-vm" -> Some `Force_create_vm + | x when x = "destroy-vm" -> Some `Destroy_vm | x when x = "statistics" -> Some `Statistics | x when x = "console" -> Some `Console | x when x = "log" -> Some `Log | x when x = "crl" -> Some `Crl - | x when x = "force-create" -> Some `Force_create + | x when x = "create-block" -> Some `Create_block + | x when x = "destroy-block" -> Some `Destroy_block | _ -> None -type cmd = - | Info - | Destroy_vm - | Create_block - | Destroy_block - | Statistics - | Attach - | Detach - | Log - -let pp_cmd ppf = function - | Info -> Fmt.pf ppf "info" - | Destroy_vm -> Fmt.pf ppf "destroy" - | Create_block -> Fmt.pf ppf "create-block" - | Destroy_block -> Fmt.pf ppf "destroy-block" - | Statistics -> Fmt.pf ppf "statistics" - | Attach -> Fmt.pf ppf "attach" - | Detach -> Fmt.pf ppf "detach" - | Log -> Fmt.pf ppf "log" - -let cmd_of_string = function - | x when x = "info" -> Some Info - | x when x = "destroy" -> Some Destroy_vm - | x when x = "create-block" -> Some Create_block - | x when x = "destroy-block" -> Some Destroy_block - | x when x = "statistics" -> Some Statistics - | x when x = "attach" -> Some Attach - | x when x = "detach" -> Some Detach - | x when x = "log" -> Some Log - | _ -> None - -let cmd_allowed permissions cmd = - List.mem `All permissions || - let perm = match cmd with - | Info -> `Info - | Destroy_vm -> `Create - | Create_block -> `Block - | Destroy_block -> `Block - | Statistics -> `Statistics - | Attach -> `Console - | Detach -> `Console - | Log -> `Log - in - List.mem perm permissions - type vmtype = [ `Ukvm_amd64 | `Ukvm_arm64 | `Ukvm_amd64_compressed ] let vmtype_to_int = function diff --git a/src/vmm_ring.ml b/src/vmm_ring.ml index 55ef7e3..f49d6e7 100644 --- a/src/vmm_ring.ml +++ b/src/vmm_ring.ml @@ -19,6 +19,24 @@ let write t v = let dec t n = (pred n + t.size) mod t.size +let written (ts, _) = not (Ptime.equal ts Ptime.min) + +let read t = + let rec go s acc idx = + if idx = s then (* don't read it twice *) + acc + else + let entry = Array.get t.data idx in + if written entry then go s (entry :: acc) (dec t idx) + else acc + in + let idx = dec t t.write in + let s = + let entry = Array.get t.data idx in + if written entry then [entry] else [] + in + go idx s (dec t idx) + let earlier ts than = if ts = Ptime.min then true else Ptime.is_earlier ts ~than diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 26330bf..2c138bb 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -227,23 +227,17 @@ module Console = struct type op = | Add_console | Attach_console - | Detach_console - | History | Data (* is a reply, never acked *) let op_to_int = function | Add_console -> 0x0100l | Attach_console -> 0x0101l - | Detach_console -> 0x0102l - | History -> 0x0103l - | Data -> 0x0104l + | Data -> 0x0102l let int_to_op = function | 0x0100l -> Some Add_console | 0x0101l -> Some Attach_console - | 0x0102l -> Some Detach_console - | 0x0103l -> Some History - | 0x0104l -> Some Data + | 0x0102l -> Some Data | _ -> None let data version name ts msg = @@ -255,15 +249,11 @@ module Console = struct in encode version ~name ~body 0L (op_to_int Data) - let add id version name = encode ~name version id (op_to_int Add_console) + let add id version name = + encode ~name version id (op_to_int Add_console) - let attach id version name = encode ~name version id (op_to_int Attach_console) - - let detach id version name = encode ~name version id (op_to_int Detach_console) - - let history id version name since = - let body = encode_ptime since in - encode ~name ~body version id (op_to_int History) + let attach id version name = + encode ~name version id (op_to_int Attach_console) end module Stats = struct diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index 37657b1..b1f5445 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -1,5 +1,5 @@ -let asn_version = `AV0 +let asn_version = `AV1 let handle_single_revocation t prefix serial = let id = identifier serial in diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml index 644cc62..ce12b0f 100644 --- a/stats/vmm_stats_lwt.ml +++ b/stats/vmm_stats_lwt.ml @@ -84,7 +84,7 @@ let setup_log = let socket = let doc = "Socket to listen on" in - let sock = Fpath.(to_string (Vmm_core.tmpdir / "stat" + "sock")) in + let sock = Vmm_core.socket_path `Stats in Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) let interval = From 99ba1c5e4b9c352b4948fb5b3cf197ce4ae2945b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 20 Sep 2018 22:53:42 +0200 Subject: [PATCH 04/73] stats are back now! no longer two pullers, but now with one pusher :) --- app/vmm_influxdb_stats.ml | 216 ++++++++++++++++---------------------- app/vmmc.ml | 93 ++++++++++++++-- src/vmm_commands.ml | 3 + src/vmm_wire.ml | 8 +- stats/vmm_stats.ml | 98 +++++++---------- stats/vmm_stats_lwt.ml | 12 ++- 6 files changed, 231 insertions(+), 199 deletions(-) diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index 62d389d..1ccb359 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -140,12 +140,10 @@ module P = struct vm ifd.name (String.concat ~sep:"," fields) end -let my_version = `WV1 +let my_version = `WV2 let command = ref 1L -let (req : string IM64.t ref) = ref IM64.empty - let str_of_e = function | `Eof -> "end of file" | `Exception -> "exception" @@ -160,65 +158,67 @@ let safe_close s = Logs.err (fun m -> m "exception %s while closing" (Printexc.to_string e)) ; Lwt.return_unit) -let rec read_sock_write_tcp closing db c ?fd addr addrtype = +let rec read_sock_write_tcp c ?fd addr addrtype = match fd with | None -> - if !closing then - Lwt.return_unit - else begin - Logs.debug (fun m -> m "new connection to TCP") ; - let fd = Lwt_unix.socket addrtype Lwt_unix.SOCK_STREAM 0 in - Lwt_unix.setsockopt fd Lwt_unix.SO_KEEPALIVE true ; - Lwt.catch - (fun () -> - Lwt_unix.connect fd addr >|= fun () -> - Logs.debug (fun m -> m "connected to TCP") ; - Some fd) - (fun e -> - let addr', port = match addr with - | Lwt_unix.ADDR_INET (ip, port) -> Unix.string_of_inet_addr ip, port - | Lwt_unix.ADDR_UNIX addr -> addr, 0 - in - Logs.warn (fun m -> m "error %s connecting to influxd %s:%d, retrying in 5s" - (Printexc.to_string e) addr' port) ; - safe_close fd >>= fun () -> - Lwt_unix.sleep 5.0 >|= fun () -> - None) >>= fun fd -> - read_sock_write_tcp closing db c ?fd addr addrtype - end + Logs.debug (fun m -> m "new connection to TCP") ; + let fd = Lwt_unix.socket addrtype Lwt_unix.SOCK_STREAM 0 in + Lwt_unix.setsockopt fd Lwt_unix.SO_KEEPALIVE true ; + Lwt.catch + (fun () -> + Lwt_unix.connect fd addr >|= fun () -> + Logs.debug (fun m -> m "connected to TCP") ; + Some fd) + (fun e -> + let addr', port = match addr with + | Lwt_unix.ADDR_INET (ip, port) -> Unix.string_of_inet_addr ip, port + | Lwt_unix.ADDR_UNIX addr -> addr, 0 + in + Logs.warn (fun m -> m "error %s connecting to influxd %s:%d, retrying in 5s" + (Printexc.to_string e) addr' port) ; + safe_close fd >>= fun () -> + Lwt_unix.sleep 5.0 >|= fun () -> + None) >>= fun fd -> + read_sock_write_tcp c ?fd addr addrtype | Some fd -> - if !closing then - safe_close fd - else begin - let open Vmm_wire in - Logs.debug (fun m -> m "reading from unix socket") ; - Vmm_lwt.read_wire c >>= function - | Error e -> - Logs.err (fun m -> m "error %s while reading vmm socket (return)" - (str_of_e e)) ; - closing := true ; - safe_close fd - | Ok (hdr, data) -> - let name = - try IM64.find hdr.id !req - with Not_found -> "not found" - in - req := IM64.remove hdr.id !req ; - (if not (version_eq hdr.version my_version) then begin - Logs.err (fun m -> m "unknown wire protocol version") ; - closing := true ; - safe_close fd >|= fun () -> - None - end else if Vmm_wire.is_fail hdr then begin - Logs.err (fun m -> m "failed to retrieve statistics for %s" name) ; - Lwt.return (Some fd) - end else if Vmm_wire.is_reply hdr then - begin match Vmm_wire.Stats.decode_stats data with + let open Vmm_wire in + Logs.debug (fun m -> m "reading from unix socket") ; + Vmm_lwt.read_wire c >>= function + | Error e -> + Logs.err (fun m -> m "error %s while reading vmm socket (return)" + (str_of_e e)) ; + safe_close fd >>= fun () -> + safe_close c >|= fun () -> + true + | Ok (hdr, data) -> + if not (version_eq hdr.version my_version) then begin + Logs.err (fun m -> m "unknown wire protocol version") ; + safe_close fd >>= fun () -> + safe_close c >|= fun () -> + false + end else if Vmm_wire.is_fail hdr then begin + Logs.err (fun m -> m "failed to retrieve statistics") ; + safe_close fd >>= fun () -> + safe_close c >|= fun () -> + false + end else if Vmm_wire.is_reply hdr then begin + Logs.info (fun m -> m "received reply, continuing") ; + read_sock_write_tcp c ~fd addr addrtype + end else + (match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with + | Some Vmm_wire.Stats.Data -> + begin + let r = + let open Rresult.R.Infix in + Vmm_wire.decode_strings data >>= fun (id, off) -> + Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun stats -> + (Vmm_core.string_of_id id, stats) + in + match r with | Error (`Msg msg) -> - Logs.warn (fun m -> m "error %s while decoding stats %s, ignoring" - msg name) ; + Logs.warn (fun m -> m "error %s while decoding stats, ignoring" msg) ; Lwt.return (Some fd) - | Ok (ru, vmm, ifs) -> + | Ok (name, (ru, vmm, ifs)) -> let ru = P.encode_ru name ru in let vmm = P.encode_vmm name vmm in let taps = List.map (P.encode_if name) ifs in @@ -234,37 +234,23 @@ let rec read_sock_write_tcp closing db c ?fd addr addrtype = safe_close fd >|= fun () -> None end - else begin - Logs.err (fun m -> m "unhandled tag %lu for %s" hdr.tag name) ; - Lwt.return (Some fd) - end) >>= fun fd -> - read_sock_write_tcp closing db c ?fd addr addrtype - end + | _ -> + Logs.err (fun m -> m "unhandled tag %lu" hdr.tag) ; + Lwt.return (Some fd)) >>= fun fd -> + read_sock_write_tcp c ?fd addr addrtype -let rec query_sock closing prefix db c interval = +let query_sock vms c = (* query c for everyone in db *) - if !closing then - Lwt.return_unit - else - Lwt_list.fold_left_s (fun r (id, name) -> - match r with - | Error e -> Lwt.return (Error e) - | Ok () -> - let id = identifier id in - let id = match prefix with None -> [ id ] | Some p -> [ p ; id ] in - let request = Vmm_wire.Stats.stat !command my_version id in - req := IM64.add !command name !req ; - command := Int64.succ !command ; - Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id id) ; - Vmm_lwt.write_wire c request) - (Ok ()) db >>= function - | Error e -> - Logs.err (fun m -> m "error %s while writing to vmm socket" (str_of_e e)) ; - closing := true ; - Lwt.return_unit - | Ok () -> - Lwt_unix.sleep (float_of_int interval) >>= fun () -> - query_sock closing prefix db c interval + Lwt_list.fold_left_s (fun r name -> + match r with + | Error e -> Lwt.return (Error e) + | Ok () -> + let id = Astring.String.cuts ~sep:"." name in + let request = Vmm_wire.Stats.stat !command my_version id in + command := Int64.succ !command ; + Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id id) ; + Vmm_lwt.write_wire c request) + (Ok ()) vms let rec maybe_connect stat_socket = let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in @@ -281,10 +267,7 @@ let rec maybe_connect stat_socket = Lwt_unix.sleep (float_of_int 5) >>= fun () -> maybe_connect stat_socket) -let client stat_socket influxhost influxport db prefix interval = - (* start a socket connection to vmm_stats *) - maybe_connect stat_socket >>= fun c -> - +let client stat_socket influxhost influxport vms = (* figure out address of influx *) Lwt_unix.gethostbyname influxhost >>= fun host_entry -> let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in @@ -293,7 +276,7 @@ let client stat_socket influxhost influxport db prefix interval = in (* loop *) - (* the query task queries the stat_socket at each interval + (* the query task queries the stat_socket at each - if this fails, closing is set to true (and unit is returned) the read_sock reads the stat_socket, and forwards to a TCP socket @@ -305,28 +288,23 @@ let client stat_socket influxhost influxport db prefix interval = - query_sock/read_sock_write_tcp write an read from it - on failure in read or write, the TCP connection is closed, and loop takes control: safe_close, maybe_connect, rinse, repeat *) - let rec loop c = - let closing = ref false in - Lwt.join [ - query_sock closing prefix db c interval ; - read_sock_write_tcp closing db c addr addrtype - ] >>= fun () -> - safe_close c >>= fun () -> - maybe_connect stat_socket >>= fun c -> - loop c - in - loop c -let run_client _ socket (influxhost, influxport) db prefix interval = - Sys.(set_signal sigpipe Signal_ignore) ; - let db = - let open Rresult.R.Infix in - match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with - | Ok [] -> invalid_arg "empty database" - | Ok db -> db - | Error (`Msg m) -> invalid_arg ("couldn't parse database " ^ m) + let rec loop () = + (* start a socket connection to vmm_stats *) + maybe_connect stat_socket >>= fun c -> + query_sock vms c >>= function + | Error e -> + Logs.err (fun m -> m "error %s while writing to stat socket" (str_of_e e)) ; + Lwt.return_unit + | Ok () -> + read_sock_write_tcp c addr addrtype >>= fun restart -> + if restart then loop () else Lwt.return_unit in - Lwt_main.run (client socket influxhost influxport db prefix interval) + loop () + +let run_client _ socket (influxhost, influxport) vms = + Sys.(set_signal sigpipe Signal_ignore) ; + Lwt_main.run (client socket influxhost influxport vms) let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); @@ -361,17 +339,9 @@ let influx = Arg.(required & pos 0 (some host_port) None & info [] ~docv:"influx" ~doc:"the influx hostname:port to connect to") -let db = - let doc = "VMID database" in - Arg.(required & pos 1 (some file) None & info [] ~doc) - -let prefix = - let doc = "prefix" in - Arg.(value & opt (some string) None & info [ "prefix" ] ~doc) - -let interval = - let doc = "Poll interval in seconds" in - Arg.(value & opt int 10 & info [ "interval" ] ~doc) +let vms = + let doc = "virtual machine names" in + Arg.(value & opt_all string [] & info [ "n" ; "name" ] ~doc) let cmd = let doc = "VMM InfluxDB connector" in @@ -379,7 +349,7 @@ let cmd = `S "DESCRIPTION" ; `P "$(tname) connects to a vmm stats socket, pulls statistics and pushes them via TCP to influxdb" ] in - Term.(pure run_client $ setup_log $ socket $ influx $ db $ prefix $ interval), + Term.(pure run_client $ setup_log $ socket $ influx $ vms), Term.info "vmm_influxdb_stats" ~version:"%%VERSION_NUM%%" ~doc ~man let () = diff --git a/app/vmmc.ml b/app/vmmc.ml index e300dde..b5c2950 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -43,8 +43,7 @@ let connect socket_path = let info_ _ opt_socket name = Lwt_main.run ( connect (socket `Vmmd opt_socket) >>= fun fd -> - let name' = Astring.String.cuts ~empty:false ~sep:"." name in - let info = Vmm_wire.Vm.info my_command my_version name' in + let info = Vmm_wire.Vm.info my_command my_version name in (Vmm_lwt.write_wire fd info >>= function | Ok () -> (process fd >|= function @@ -65,7 +64,7 @@ let info_ _ opt_socket name = let really_destroy opt_socket name = connect (socket `Vmmd opt_socket) >>= fun fd -> - let cmd = Vmm_wire.Vm.destroy my_command my_version (Astring.String.cuts ~empty:false ~sep:"." name) in + let cmd = Vmm_wire.Vm.destroy my_command my_version name in (Vmm_lwt.write_wire fd cmd >>= function | Ok () -> (process fd >|= function @@ -83,7 +82,7 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc | Ok data -> data | Error (`Msg s) -> invalid_arg s in - let prefix, vname = match List.rev (Astring.String.cuts ~empty:false ~sep:"." name) with + let prefix, vname = match List.rev name with | [ name ] -> [], name | name::tl -> List.rev tl, name | [] -> assert false @@ -116,7 +115,7 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc let console _ opt_socket name = Lwt_main.run ( connect (socket `Console opt_socket) >>= fun fd -> - let cmd = Vmm_wire.Console.attach my_command my_version (Astring.String.cuts ~empty:false ~sep:"." name) in + let cmd = Vmm_wire.Console.attach my_command my_version name in (Vmm_lwt.write_wire fd cmd >>= function | Error `Exception -> Logs.err (fun m -> m "couldn't write to socket") ; @@ -147,7 +146,7 @@ let console _ opt_socket name = let r = let open Rresult.R.Infix in match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with - | Some Data -> + | Some Vmm_wire.Console.Data -> Vmm_wire.decode_id_ts data >>= fun ((name, ts), off) -> Vmm_wire.decode_string (Cstruct.shift data off) >>= fun (msg, _) -> Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts Vmm_core.pp_id name msg) ; @@ -165,6 +164,62 @@ let console _ opt_socket name = Vmm_lwt.safe_close fd) ; `Ok () +let stats _ opt_socket vms = + Lwt_main.run ( + connect (socket `Stats opt_socket) >>= fun fd -> + let count = ref 0L in + Lwt_list.iter_s (fun name -> + let cmd = Vmm_wire.Stats.stat !count my_version name in + count := Int64.succ !count ; + Vmm_lwt.write_wire fd cmd >>= function + | Error `Exception -> Lwt.fail_with "write error" + | Ok () -> Lwt.return_unit) vms >>= fun () -> + (* now we busy read and process stat output *) + let rec loop () = + Vmm_lwt.read_wire fd >>= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () + | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit + | Ok (hdr, data) -> + if Vmm_wire.is_fail hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ; + Lwt.return_unit + else if Vmm_wire.is_reply hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; + loop () + else + let r = + let open Rresult.R.Infix in + match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with + | Some Vmm_wire.Stats.Data -> + Vmm_wire.decode_strings data >>= fun (id, off) -> + Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun stats -> + (Astring.String.concat ~sep:"." id, stats) + | _ -> + Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)) + in + match r with + | Ok (name, (ru, vmm, ifs)) -> + Logs.app (fun m -> m "stats %s: %a %a %a" + name Vmm_core.pp_rusage ru + Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm + Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ; + loop () + | Error (`Msg msg) -> + Logs.err (fun m -> m "%s" msg) ; + Lwt.return_unit + in + loop () >>= fun () -> + Vmm_lwt.safe_close fd) ; + `Ok () + let help _ _ man_format cmds = function | None -> `Help (`Pager, None) | Some t when List.mem t cmds -> `Help (man_format, Some t) @@ -194,9 +249,14 @@ let image = let doc = "File of virtual machine image." in Arg.(required & pos 1 (some file) None & info [] ~doc) +let vm_c = + let parse s = `Ok (Vmm_core.id_of_string s) + in + (parse, Vmm_core.pp_id) + let vm_name = let doc = "Name virtual machine." in - Arg.(required & pos 0 (some string) None & info [] ~doc) + Arg.(required & pos 0 (some vm_c) None & info [] ~doc) let destroy_cmd = let doc = "destroys a virtual machine" in @@ -246,14 +306,27 @@ let create_cmd = Term.info "create" ~doc ~man let console_cmd = - let doc = "console of a VMs" in + let doc = "console of a VM" in let man = [`S "DESCRIPTION"; - `P "Shows console output of a VMs."] + `P "Shows console output of a VM."] in Term.(ret (const console $ setup_log $ socket $ vm_name)), Term.info "console" ~doc ~man +let vm_names = + let doc = "Name virtual machine." in + Arg.(value & opt_all vm_c [] & info [ "n" ; "name" ] ~doc) + +let stats_cmd = + let doc = "statistics of VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows statistics of VMs."] + in + Term.(ret (const stats $ setup_log $ socket $ vm_names)), + Term.info "stats" ~doc ~man + let help_cmd = let topic = let doc = "The topic to get help on. `topics' lists the topics." in @@ -276,7 +349,7 @@ let default_cmd = Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man -let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ; console_cmd ] +let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ] let () = match Term.eval_choice default_cmd cmds diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index e4bf64b..aad9c0e 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -7,6 +7,9 @@ open Vmm_core open Rresult open R.Infix + + + 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 diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 2c138bb..8e23452 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -261,16 +261,19 @@ module Stats = struct | Add | Remove | Stats + | Data let op_to_int = function | Add -> 0x0200l | Remove -> 0x0201l | Stats -> 0x0202l + | Data -> 0x0203l let int_to_op = function | 0x0200l -> Some Add | 0x0201l -> Some Remove | 0x0202l -> Some Stats + | 0x0203l -> Some Data | _ -> None let rusage_len = 144l @@ -381,8 +384,9 @@ module Stats = struct let stat id version name = encode ~name version id (op_to_int Stats) - let stat_reply id version body = - reply ~body version id (op_to_int Stats) + let data id version vm body = + let name = Vmm_core.id_of_string vm in + encode ~name ~body version id (op_to_int Data) let encode_int64 i = let cs = Cstruct.create 8 in diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index e8268d7..cbe7328 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -16,22 +16,24 @@ external vmmapi_close : vmctx -> unit = "vmmanage_vmmapi_close" external vmmapi_statnames : vmctx -> string list = "vmmanage_vmmapi_statnames" external vmmapi_stats : vmctx -> int64 list = "vmmanage_vmmapi_stats" -let my_version = `WV1 +let my_version = `WV2 let descr = ref [] -type t = { +type 'a t = { pid_nic : ((vmctx, int) result * (int * string) list) IM.t ; - pid_rusage : rusage IM.t ; - pid_vmmapi : (string * int64) list IM.t ; - nic_ifdata : ifdata String.Map.t ; vmid_pid : int String.Map.t ; + name_sockets : 'a String.Map.t ; } let pp_strings pp taps = Fmt.(list ~sep:(unit ",@ ") string) pp taps let empty () = - { pid_nic = IM.empty ; pid_rusage = IM.empty ; pid_vmmapi = IM.empty ; nic_ifdata = String.Map.empty ; vmid_pid = String.Map.empty } + { pid_nic = IM.empty ; vmid_pid = String.Map.empty ; name_sockets = String.Map.empty } + +let remove_socket t name = + let name_sockets = String.Map.remove name t.name_sockets in + { t with name_sockets } let rec wrap f arg = try Some (f arg) with @@ -91,33 +93,33 @@ let gather pid vmctx nics = ifd | Some data -> Logs.debug (fun m -> m "adding ifdata for %s" nname) ; - String.Map.add data.name data ifd) - String.Map.empty nics + data::ifd) + [] nics let tick t = Logs.debug (fun m -> m "tick with %d vms" (IM.cardinal t.pid_nic)) ; - let pid_rusage, pid_vmmapi, nic_ifdata = - IM.fold (fun pid (vmctx, nics) (rus, vmms, ifds) -> - let ru, vmm, ifd = gather pid vmctx nics in - (match ru with - | None -> - Logs.warn (fun m -> m "failed to get rusage for %d" pid) ; - rus - | Some ru -> - Logs.debug (fun m -> m "adding resource usage for %d" pid) ; - IM.add pid ru rus), - (match vmm with - | None -> - Logs.warn (fun m -> m "failed to get vmmapi_stats for %d" pid) ; - vmms - | Some vmm -> - Logs.debug (fun m -> m "adding vmmapi_stats for %d" pid) ; - IM.add pid (List.combine !descr vmm) vmms), - String.Map.union (fun _k a _b -> Some a) ifd ifds) - t.pid_nic (IM.empty, IM.empty, String.Map.empty) - in let pid_nic = try_open_vmmapi t.pid_nic in - { t with pid_rusage ; pid_vmmapi ; nic_ifdata ; pid_nic } + let t' = { t with pid_nic } in + let outs = + String.Map.fold (fun name socket out -> + match String.Map.find_opt name t.vmid_pid with + | None -> Logs.warn (fun m -> m "couldn't find pid of %s" name) ; out + | Some pid -> match IM.find_opt pid t.pid_nic with + | None -> Logs.warn (fun m -> m "couldn't find nics of %d" pid) ; out + | Some (vmctx, nics) -> + let ru, vmm, ifd = gather pid vmctx nics in + match ru with + | None -> Logs.err (fun m -> m "failed to get rusage for %d" pid) ; out + | Some ru' -> + let stats = + let vmm' = match vmm with None -> [] | Some xs -> List.combine !descr xs in + ru', vmm', ifd + in + let stats_encoded = Vmm_wire.Stats.(data 0L my_version name (encode_stats stats)) in + (socket, name, stats_encoded) :: out) + t'.name_sockets [] + in + (t', outs) let add_pid t vmid pid nics = match wrap sysctl_ifcount () with @@ -143,35 +145,6 @@ let add_pid t vmid pid nics = in Ok { t with pid_nic ; vmid_pid } - -let stats t vmid = - Logs.debug (fun m -> m "querying statistics for vmid %s" vmid) ; - match String.Map.find vmid t.vmid_pid with - | None -> Error (`Msg ("unknown vm " ^ vmid)) - | Some pid -> - Logs.debug (fun m -> m "querying statistics for %d" pid) ; - try - let _, nics = IM.find pid t.pid_nic - and ru = IM.find pid t.pid_rusage - and vmm = - try IM.find pid t.pid_vmmapi with - | Not_found -> - Logs.err (fun m -> m "failed to find vmm stats for %d" pid); - [] - in - match - List.fold_left (fun acc nic -> - match String.Map.find nic t.nic_ifdata, acc with - | None, _ -> None - | _, None -> None - | Some ifd, Some acc -> Some (ifd :: acc)) - (Some []) (snd (List.split nics)) - with - | None -> Error (`Msg "failed to find interface statistics") - | Some ifd -> Ok (ru, vmm, ifd) - with - | _ -> Error (`Msg "failed to find resource usage") - let remove_vmid t vmid = Logs.info (fun m -> m "removing vmid %s" vmid) ; match String.Map.find vmid t.vmid_pid with @@ -192,14 +165,15 @@ let remove_vmid t vmid = let remove_vmids t vmids = List.fold_left remove_vmid t vmids -let handle t hdr cs = +let handle t socket hdr cs = let open Vmm_wire in let open Vmm_wire.Stats in let r = if not (version_eq my_version hdr.version) then Error (`Msg "cannot handle version") else - decode_string cs >>= fun (name, off) -> + decode_strings cs >>= fun (id, off) -> + let name = Vmm_core.string_of_id id in match int_to_op hdr.tag with | Some Add -> decode_pid_taps (Cstruct.shift cs off) >>= fun (pid, taps) -> @@ -209,8 +183,8 @@ let handle t hdr cs = let t = remove_vmid t name in Ok (t, `Remove name, success ~msg:"removed" my_version hdr.id (op_to_int Remove)) | Some Stats -> - stats t name >>= fun s -> - Ok (t, `None, stat_reply hdr.id my_version (encode_stats s)) + let name_sockets = String.Map.add name socket t.name_sockets in + Ok ({ t with name_sockets }, `None, success ~msg:"subscribed" my_version hdr.id (op_to_int Stats)) | _ -> Error (`Msg "unknown command") in match r with diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml index ce12b0f..642d4d0 100644 --- a/stats/vmm_stats_lwt.ml +++ b/stats/vmm_stats_lwt.ml @@ -29,7 +29,7 @@ let handle s addr () = | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return acc | Ok (hdr, data) -> Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ; - let t', action, out = Vmm_stats.handle !t hdr data in + let t', action, out = Vmm_stats.handle !t s hdr data in let acc = match action with | `Add pid -> pid :: acc | `Remove pid -> List.filter (fun m -> m <> pid) acc @@ -48,7 +48,15 @@ let handle s addr () = t := t' let rec timer interval () = - t := Vmm_stats.tick !t ; + let t', outs = Vmm_stats.tick !t in + t := t' ; + Lwt_list.iter_p (fun (s, name, stat) -> + Vmm_lwt.write_wire s stat >>= function + | Ok () -> Lwt.return_unit + | Error `Exception -> + t := Vmm_stats.remove_socket !t name ; + Vmm_lwt.safe_close s) + outs >>= fun () -> Lwt_unix.sleep interval >>= fun () -> timer interval () From 38b98ab3182c7c35812ef6c3912158fec57c28db Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 20 Sep 2018 23:19:55 +0200 Subject: [PATCH 05/73] minor --- src/vmm_engine.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index c1f9bba..a4e1af7 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -123,7 +123,7 @@ let handle_command t hdr buf = else Vmm_wire.decode_strings buf >>= fun (id, _off) -> match Vmm_wire.Vm.int_to_op hdr.Vmm_wire.tag with | None -> Error (`Msg "unknown command") - | Some Info -> + | Some Vmm_wire.Vm.Info -> Logs.debug (fun m -> m "info %a" pp_id id) ; begin match Vmm_resources.find t.resources id with | None -> @@ -136,10 +136,10 @@ let handle_command t hdr buf = let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version data in Ok (t, [ `Data out ], `End) end - | Some Create -> + | Some Vmm_wire.Vm.Create -> Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config -> handle_create t hdr vm_config - | Some Destroy -> + | Some Vmm_wire.Vm.Destroy -> match Vmm_resources.find_vm t.resources id with | Some vm -> Vmm_unix.destroy vm ; From 02f8d94db8534c6eb2957613cf986bdf47226ea9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 21 Sep 2018 22:31:04 +0200 Subject: [PATCH 06/73] s/ukvm/hvt/ --- README.md | 21 ++++++++++----------- app/vmmc.ml | 2 +- app/vmmd.ml | 2 +- provision/vmm_req_vm.ml | 4 ++-- src/vmm_asn.ml | 12 ++++++------ src/vmm_asn.mli | 5 +++-- src/vmm_core.ml | 20 ++++++++++---------- src/vmm_unix.ml | 10 +++++----- stats/vmm_stats.ml | 2 +- 9 files changed, 39 insertions(+), 39 deletions(-) diff --git a/README.md b/README.md index 9a5a400..b2985ec 100644 --- a/README.md +++ b/README.md @@ -14,13 +14,12 @@ is used on top to (more gracefully) handle multiple connection, and to have a watching thread (in `waitpid(2)`) for every virtual machine started by vmmd. To install Albatross, run `opam pin add albatross -https://github.com/hannesm/albatross`. On FreeBSD, `opam pin add -solo5-kernel-ukvm --dev` is needed as well. +https://github.com/hannesm/albatross`. The following elaborates on how to get the software up and running, following by provisioning and deploying some unikernels. There is a *server* (`SRV`) component which needs six binaries: vmm_console, vmm_log, vmm_stats_lwt, vmmd, -ukvm-bin.none, and ukvm-bin.net; a `CA` machine (which should be air-gapped, or +solo6-hvt.none, and solo5-hvt.net; a `CA` machine (which should be air-gapped, or at least use some hardware token) for provisioning which needs vmm_sign, and vmm_gen_ca; and a *development* (`DEV`) machine which has a fully featured OCaml and MirageOS environment. Each step is prefixed with the machine it is supposed @@ -63,15 +62,15 @@ steps to produce the remaining required binaries: CA> COPY cacert.pem server.pem server.key SRV: DEV> git clone https://github.com/mirage/mirage-skeleton.git DEV> cd mirage-skeleton/tutorial/hello -DEV> mirage configure -t ukvm +DEV> mirage configure -t hvt DEV> mirage build -DEV> mv ukvm-bin /tmp/ukvm-bin.none +DEV> mv solo5-hvt /tmp/solo5-hvt.none DEV> cd ../device-usage/network -DEV> mirage configure -t ukvm +DEV> mirage configure -t hvt DEV> mirage build -DEV> mv ukvm-bin /tmp/ukvm-bin.net +DEV> mv solo5-hvt /tmp/solo5-hvt.net DEV> cd ../../.. -DEV> COPY /tmp/ukvm-bin.none /tmp/ukvm-bin.net SRV:/var/db/albatross +DEV> COPY /tmp/solo5-hvt.none /tmp/solo5-hvt.net SRV:/var/db/albatross DEV> COPY vmm_console vmm_log vmm_stats_lwt vmmd SRV:/opt/bin/ ``` @@ -104,7 +103,7 @@ able to collect statistics unless running as a privileged user, the following ``` [albatross=10] -add path 'vmm/ukvm*' mode 0660 group albatross +add path 'vmm/solo5*' mode 0660 group albatross ``` Also need to activate by adding `devfs_system_ruleset="albatross"` to @@ -140,12 +139,12 @@ This produced in the first step two files, `admin.req` and `admin.key`, and in the second step two more files, `dev.db` and `admin.pem`. ``` -DEV> vmm_req_vm hello mirage-skeleton/tutorial/hello/hello.ukvm 12 1 +DEV> vmm_req_vm hello mirage-skeleton/tutorial/hello/hello.hvt 12 1 DEV> vmm_sign dev.db dev.pem dev.key hello.req ``` This generates a private key `hello.key` and a certificate signing request named -`hello.req` including the virtual machine image `hello.ukvm`, which gets 12MB +`hello.req` including the virtual machine image `hello.hvt`, which gets 12MB memory and CPU id 1. The second command used the `dev.key` to sign the signing request and output a `hello.pem`. diff --git a/app/vmmc.ml b/app/vmmc.ml index b5c2950..3f6713b 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -90,7 +90,7 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc | [] -> None | xs -> Some xs (* TODO we could do the compression btw *) - and vmimage = `Ukvm_amd64, Cstruct.of_string image' + and vmimage = `Hvt_amd64, Cstruct.of_string image' in let vm_config = { prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; diff --git a/app/vmmd.ml b/app/vmmd.ml index 9b54b4b..0416557 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -34,7 +34,7 @@ let handle state out c_fd fd addr = (c) create initiates the vm startup procedure: write image file, create fifo, create tap(s), send fifo to console -- Lwt effects happen (console) -- - executes ukvm-bin + waiter, send stats pid and taps, inserts await into state, logs "created vm" + executes solo5-hvt + waiter, send stats pid and taps, inserts await into state, logs "created vm" -- Lwt effects happen (stats, logs, wait_and_clear) -- (2) goto (1) *) diff --git a/provision/vmm_req_vm.ml b/provision/vmm_req_vm.ml index 60e1273..5e96c89 100644 --- a/provision/vmm_req_vm.ml +++ b/provision/vmm_req_vm.ml @@ -19,10 +19,10 @@ let vm_csr key name image cpu mem args block net force compression = and cmd = if force then `Force_create_vm else `Create_vm in let image = match compression with - | 0 -> image_to_cstruct (`Ukvm_amd64, image) + | 0 -> image_to_cstruct (`Hvt_amd64, image) | level -> let img = Vmm_compress.compress ~level (Cstruct.to_string image) in - image_to_cstruct (`Ukvm_amd64_compressed, Cstruct.of_string img) + image_to_cstruct (`Hvt_amd64_compressed, Cstruct.of_string img) in let exts = [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ; diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 88af92d..3a1bd24 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -105,13 +105,13 @@ let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string let image = let f = function - | `C1 x -> `Ukvm_amd64, x - | `C2 x -> `Ukvm_arm64, x - | `C3 x -> `Ukvm_amd64_compressed, x + | `C1 x -> `Hvt_amd64, x + | `C2 x -> `Hvt_arm64, x + | `C3 x -> `Hvt_amd64_compressed, x and g = function - | `Ukvm_amd64, x -> `C1 x - | `Ukvm_arm64, x -> `C2 x - | `Ukvm_amd64_compressed, x -> `C3 x + | `Hvt_amd64, x -> `C1 x + | `Hvt_arm64, x -> `C2 x + | `Hvt_amd64_compressed, x -> `C3 x in Asn.S.map f g @@ Asn.S.(choice3 diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 30143c9..15d42f9 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -52,8 +52,9 @@ module Oid : sig 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. *) + (** [vmimage] is a [CHOICE] between [ [0] OCTET_STRING] for an hvt amd64 + image, [ [1] OCTET_STRING] for an hvt arm64 image, and [ [2] OCTET_STRING] + for a compressed am64 hvt image. *) val vmimage : Asn.OID.t (** [argv] is a [SEQUENCE OF UTF8STRING] denoting the boot parameters passed diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 235c0e3..0c10bfb 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -60,23 +60,23 @@ let command_of_string = function | x when x = "destroy-block" -> Some `Destroy_block | _ -> None -type vmtype = [ `Ukvm_amd64 | `Ukvm_arm64 | `Ukvm_amd64_compressed ] +type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ] let vmtype_to_int = function - | `Ukvm_amd64 -> 0 - | `Ukvm_arm64 -> 1 - | `Ukvm_amd64_compressed -> 2 + | `Hvt_amd64 -> 0 + | `Hvt_arm64 -> 1 + | `Hvt_amd64_compressed -> 2 let int_to_vmtype = function - | 0 -> Some `Ukvm_amd64 - | 1 -> Some `Ukvm_arm64 - | 2 -> Some `Ukvm_amd64_compressed + | 0 -> Some `Hvt_amd64 + | 1 -> Some `Hvt_arm64 + | 2 -> Some `Hvt_amd64_compressed | _ -> None let pp_vmtype ppf = function - | `Ukvm_amd64 -> Fmt.pf ppf "ukvm-amd64" - | `Ukvm_amd64_compressed -> Fmt.pf ppf "ukvm-amd64-compressed" - | `Ukvm_arm64 -> Fmt.pf ppf "ukvm-arm64" + | `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64" + | `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed" + | `Hvt_arm64 -> Fmt.pf ppf "hvt-arm64" type id = string list diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index 7b5bc4b..c2649bc 100644 --- a/src/vmm_unix.ml +++ b/src/vmm_unix.ml @@ -116,13 +116,13 @@ let create_bridge bname = let prepare vm = (match vm.vmimage with - | `Ukvm_amd64, blob -> Ok blob - | `Ukvm_amd64_compressed, blob -> + | `Hvt_amd64, blob -> Ok blob + | `Hvt_amd64_compressed, blob -> begin match Vmm_compress.uncompress (Cstruct.to_string blob) with | Ok blob -> Ok (Cstruct.of_string blob) | Error () -> Error (`Msg "failed to uncompress") end - | `Ukvm_arm64, _ -> Error (`Msg "no amd64 ukvm image found")) >>= fun image -> + | `Hvt_arm64, _ -> Error (`Msg "no amd64 hvt image found")) >>= fun image -> let fifo = fifo_file vm in (match fifo_exists fifo with | Ok true -> Ok () @@ -161,8 +161,8 @@ let exec vm taps = let net = List.map (fun t -> "--net=" ^ t) taps in let argv = match vm.argv with None -> [] | Some xs -> xs in (match taps with - | [] -> Ok Fpath.(dbdir / "ukvm-bin.none") - | [_] -> Ok Fpath.(dbdir / "ukvm-bin.net") + | [] -> Ok Fpath.(dbdir / "solo5-hvt.none") + | [_] -> Ok Fpath.(dbdir / "solo5-hvt.net") | _ -> Error (`Msg "cannot handle multiple network interfaces")) >>= fun bin -> cpuset vm.cpuid >>= fun cpuset -> let mem = "--mem=" ^ string_of_int vm.requested_memory in diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index cbe7328..ba7c3b4 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -56,7 +56,7 @@ let fill_descr ctx = | ds -> Logs.info (fun m -> m "%d descr are already present" (List.length ds)) let open_vmmapi ?(retries = 4) pid = - let name = "ukvm" ^ string_of_int pid in + let name = "solo5-" ^ string_of_int pid in if retries = 0 then begin Logs.debug (fun m -> m "(ignored 0) vmmapi_open failed for %d" pid) ; Error 0 From 95cdd18f44d183d4742192eb0f84d1eba9c4c59e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 22 Sep 2018 00:26:52 +0200 Subject: [PATCH 07/73] . --- README.md | 2 +- app/vmm_console.ml | 8 +++++--- stats/vmm_stats_lwt.ml | 2 +- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index b2985ec..9c7b89d 100644 --- a/README.md +++ b/README.md @@ -65,7 +65,7 @@ DEV> cd mirage-skeleton/tutorial/hello DEV> mirage configure -t hvt DEV> mirage build DEV> mv solo5-hvt /tmp/solo5-hvt.none -DEV> cd ../device-usage/network +DEV> cd ../../device-usage/network DEV> mirage configure -t hvt DEV> mirage build DEV> mv solo5-hvt /tmp/solo5-hvt.net diff --git a/app/vmm_console.ml b/app/vmm_console.ml index ae2d781..6fb2197 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -33,7 +33,7 @@ let read_console name ring channel () = | Some fd -> Vmm_lwt.write_wire fd (Vmm_wire.Console.data my_version id t line) >>= function | Error _ -> - Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) >|= fun () -> + Vmm_lwt.safe_close fd >|= fun () -> active := String.Map.remove name !active | Ok () -> Lwt.return_unit) >>= loop @@ -83,7 +83,9 @@ let attach s id = let name = Vmm_core.string_of_id id in Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ; match String.Map.find name !t with - | None -> Lwt.return (Error (`Msg "not found")) + | None -> + active := String.Map.add name s !active ; + Lwt.return (Ok "waiing for VM") | Some r -> let entries = Vmm_ring.read r in Logs.debug (fun m -> m "found %d history" (List.length entries)) ; @@ -131,7 +133,7 @@ let handle s addr () = Lwt.return_unit in loop () >>= fun () -> - Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () -> + Vmm_lwt.safe_close s >|= fun () -> Logs.warn (fun m -> m "disconnected") let jump _ file = diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml index 642d4d0..04d754d 100644 --- a/stats/vmm_stats_lwt.ml +++ b/stats/vmm_stats_lwt.ml @@ -42,7 +42,7 @@ let handle s addr () = | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc in loop [] >>= fun vmids -> - Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () -> + Vmm_lwt.safe_close s >|= fun () -> Logs.warn (fun m -> m "disconnect, dropping %d vms!" (List.length vmids)) ; let t' = Vmm_stats.remove_vmids !t vmids in t := t' From 0e975a2b3220adfe163e5d431d8188cb1774e54e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 22 Sep 2018 00:39:07 +0200 Subject: [PATCH 08/73] vmmc: info of everything --- app/vmmc.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/app/vmmc.ml b/app/vmmc.ml index 3f6713b..c22527e 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -267,13 +267,17 @@ let destroy_cmd = Term.(ret (const destroy $ setup_log $ socket $ vm_name)), Term.info "destroy" ~doc ~man +let opt_vmname = + let doc = "Name virtual machine." in + Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc) + let info_cmd = let doc = "information about VMs" in let man = [`S "DESCRIPTION"; `P "Shows information about VMs."] in - Term.(ret (const info_ $ setup_log $ socket $ vm_name)), + Term.(ret (const info_ $ setup_log $ socket $ opt_vmname)), Term.info "info" ~doc ~man let cpu = From 91bda433e8a1bb959506a07c8ce90f288b45a03e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 22 Sep 2018 11:54:10 +0200 Subject: [PATCH 09/73] vmmc: some newlines --- app/vmmc.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/vmmc.ml b/app/vmmc.ml index c22527e..0298f28 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -207,7 +207,7 @@ let stats _ opt_socket vms = in match r with | Ok (name, (ru, vmm, ifs)) -> - Logs.app (fun m -> m "stats %s: %a %a %a" + Logs.app (fun m -> m "stats %s@.%a@.%a@.%a@." name Vmm_core.pp_rusage ru Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ; From 38094a53e3004c2fdbed3fd34f5e122e7c5c4697 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 28 Sep 2018 22:44:38 +0200 Subject: [PATCH 10/73] use vmm_trie in log and stat, cleanups --- app/vmm_influxdb_stats.ml | 38 ++++++------ app/vmm_log.ml | 125 +++++++++++--------------------------- app/vmmc.ml | 81 +++++++++++++++++++----- src/vmm_commands.ml | 3 - src/vmm_core.ml | 9 ++- src/vmm_engine.ml | 2 +- src/vmm_lwt.ml | 6 +- src/vmm_trie.ml | 79 ++++++++++++++++++++++++ src/vmm_trie.mli | 15 +++++ src/vmm_wire.ml | 23 +++---- stats/vmm_stats.ml | 70 +++++++++++---------- stats/vmm_stats_lwt.ml | 7 +-- 12 files changed, 274 insertions(+), 184 deletions(-) create mode 100644 src/vmm_trie.ml create mode 100644 src/vmm_trie.mli diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index 1ccb359..cc84072 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -239,18 +239,11 @@ let rec read_sock_write_tcp c ?fd addr addrtype = Lwt.return (Some fd)) >>= fun fd -> read_sock_write_tcp c ?fd addr addrtype -let query_sock vms c = - (* query c for everyone in db *) - Lwt_list.fold_left_s (fun r name -> - match r with - | Error e -> Lwt.return (Error e) - | Ok () -> - let id = Astring.String.cuts ~sep:"." name in - let request = Vmm_wire.Stats.stat !command my_version id in - command := Int64.succ !command ; - Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id id) ; - Vmm_lwt.write_wire c request) - (Ok ()) vms +let query_sock vm c = + let request = Vmm_wire.Stats.subscribe !command my_version vm in + command := Int64.succ !command ; + Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id vm) ; + Vmm_lwt.write_wire c request let rec maybe_connect stat_socket = let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in @@ -267,7 +260,7 @@ let rec maybe_connect stat_socket = Lwt_unix.sleep (float_of_int 5) >>= fun () -> maybe_connect stat_socket) -let client stat_socket influxhost influxport vms = +let client stat_socket influxhost influxport vm = (* figure out address of influx *) Lwt_unix.gethostbyname influxhost >>= fun host_entry -> let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in @@ -292,7 +285,7 @@ let client stat_socket influxhost influxport vms = let rec loop () = (* start a socket connection to vmm_stats *) maybe_connect stat_socket >>= fun c -> - query_sock vms c >>= function + query_sock vm c >>= function | Error e -> Logs.err (fun m -> m "error %s while writing to stat socket" (str_of_e e)) ; Lwt.return_unit @@ -302,9 +295,9 @@ let client stat_socket influxhost influxport vms = in loop () -let run_client _ socket (influxhost, influxport) vms = +let run_client _ socket (influxhost, influxport) vm = Sys.(set_signal sigpipe Signal_ignore) ; - Lwt_main.run (client socket influxhost influxport vms) + Lwt_main.run (client socket influxhost influxport vm) let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); @@ -339,9 +332,14 @@ let influx = Arg.(required & pos 0 (some host_port) None & info [] ~docv:"influx" ~doc:"the influx hostname:port to connect to") -let vms = - let doc = "virtual machine names" in - Arg.(value & opt_all string [] & info [ "n" ; "name" ] ~doc) +let vm_c = + let parse s = `Ok (Vmm_core.id_of_string s) + in + (parse, Vmm_core.pp_id) + +let opt_vmname = + let doc = "Name virtual machine." in + Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc) let cmd = let doc = "VMM InfluxDB connector" in @@ -349,7 +347,7 @@ let cmd = `S "DESCRIPTION" ; `P "$(tname) connects to a vmm stats socket, pulls statistics and pushes them via TCP to influxdb" ] in - Term.(pure run_client $ setup_log $ socket $ influx $ vms), + Term.(pure run_client $ setup_log $ socket $ influx $ opt_vmname), Term.info "vmm_influxdb_stats" ~version:"%%VERSION_NUM%%" ~doc ~man let () = diff --git a/app/vmm_log.ml b/app/vmm_log.ml index ba5824e..0338ab8 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -16,66 +16,12 @@ open Astring let my_version = `WV2 -type t = N of Lwt_unix.file_descr list * t String.Map.t - -let empty = N ([], String.Map.empty) - -let insert id fd t = - let rec go (N (fds, m)) = function - | [] -> N ((fd :: fds), m) - | x::xs -> - let n = match String.Map.find_opt x m with - | None -> empty - | Some n -> n - in - let entry = go n xs in - N (fds, String.Map.add x entry m) - in - go t id - -let remove id fd t = - let rec go (N (fds, m)) = function - | [] -> - begin match List.filter (fun fd' -> fd <> fd') fds with - | [] -> None - | fds' -> Some (N (fds', m)) - end - | x::xs -> - let n' = match String.Map.find_opt x m with - | None -> None - | Some n -> go n xs - in - let m' = match n' with - | None -> String.Map.remove x m - | Some entry -> String.Map.add x entry m - in - if String.Map.is_empty m' && fds = [] then None else Some (N (fds, m')) - in - match go t id with - | None -> empty - | Some n -> n - -let collect id t = - let rec go acc prefix (N (fds, m)) = - let acc' = - let here = List.map (fun fd -> (prefix, fd)) fds in - here @ acc - in - function - | [] -> acc' - | x::xs -> - match String.Map.find_opt x m with - | None -> acc' - | Some n -> go acc' (prefix @ [ x ]) n xs - in - go [] [] t id - let broadcast prefix data t = Lwt_list.fold_left_s (fun t (id, s) -> Vmm_lwt.write_wire s data >|= function | Ok () -> t - | Error `Exception -> remove id s t) - t (collect prefix t) + | Error `Exception -> Vmm_trie.remove id t) + t (Vmm_trie.collect prefix t) let write_complete s cs = let l = Cstruct.len cs in @@ -116,10 +62,33 @@ let write_to_file file = - should there be acks for history/datain? *) -let tree = ref empty +let tree = ref Vmm_trie.empty let bcast = ref 0L +let send_history s ring id cmd_id = + let elements = Vmm_ring.read ring in + let res = + List.fold_left (fun acc (_, x) -> + let cs = Cstruct.of_string x in + match Vmm_wire.Log.decode_log_hdr cs with + | Ok (hdr, _) -> + begin match Vmm_core.drop_super ~super:id ~sub:hdr.Vmm_core.Log.context with + | Some [] -> cs :: acc + | _ -> acc + end + | _ -> acc) + [] elements + in + (* just need a wrapper in tag = Log.Data, id = reqid *) + Lwt_list.fold_left_s (fun r body -> + match r with + | Ok () -> + let data = Vmm_wire.encode ~body my_version cmd_id (Vmm_wire.Log.op_to_int Vmm_wire.Log.Broadcast) in + Vmm_lwt.write_wire s data + | Error e -> Lwt.return (Error e)) + (Ok ()) res + let handle mvar ring s addr () = Logs.info (fun m -> m "handling connection from %a" Vmm_lwt.pp_sockaddr addr) ; let str = Fmt.strf "%a: CONNECT\n" (Ptime.pp_human ()) (Ptime_clock.now ()) in @@ -153,48 +122,28 @@ let handle mvar ring s addr () = tree := tree' ; loop () end - | Some Vmm_wire.Log.History -> - begin match Vmm_wire.decode_id_ts data with - | Error (`Msg err) -> - Logs.warn (fun m -> m "ignoring error %s while decoding history" err) ; - loop () - | Ok ((sub, ts), _) -> - let elements = Vmm_ring.read_history ring ts in - let res = - List.fold_left (fun acc (_, x) -> - let cs = Cstruct.of_string x in - match Vmm_wire.Log.decode_log_hdr cs with - | Ok (hdr, _) when Vmm_core.is_sub_id ~super:hdr.Vmm_core.Log.context ~sub -> - cs :: acc - | _ -> acc) - [] elements - in - (* just need a wrapper in tag = Log.Data, id = reqid *) - Lwt_list.fold_left_s (fun r body -> - match r with - | Ok () -> - let data = Vmm_wire.encode ~body my_version hdr.Vmm_wire.id (Vmm_wire.Log.op_to_int Vmm_wire.Log.Log) in - Vmm_lwt.write_wire s data - | Error e -> Lwt.return (Error e)) - (Ok ()) res >>= function - | Ok () -> loop () - | Error _ -> - Logs.err (fun m -> m "error while sending data in history") ; - Lwt.return_unit - end | Some Vmm_wire.Log.Subscribe -> begin match Vmm_wire.decode_strings data with | Error (`Msg err) -> Logs.warn (fun m -> m "ignoring error %s while decoding subscribe" err) ; loop () | Ok (id, _) -> - tree := insert id s !tree ; + let tree', ret = Vmm_trie.insert id s !tree in + tree := tree' ; + (match ret with + | None -> Lwt.return_unit + | Some s' -> Vmm_lwt.safe_close s') >>= fun () -> let out = Vmm_wire.success my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in Vmm_lwt.write_wire s out >>= function - | Ok () -> loop () | Error _ -> Logs.err (fun m -> m "error while sending reply for subscribe") ; Lwt.return_unit + | Ok () -> + send_history s ring id hdr.Vmm_wire.id >>= function + | Error _ -> + Logs.err (fun m -> m "error while sending history") ; + Lwt.return_unit + | Ok () -> loop () (* TODO no need to loop ;) *) end | _ -> Logs.err (fun m -> m "unknown command") ; diff --git a/app/vmmc.ml b/app/vmmc.ml index 0298f28..4265b34 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -164,16 +164,13 @@ let console _ opt_socket name = Vmm_lwt.safe_close fd) ; `Ok () -let stats _ opt_socket vms = +let stats _ opt_socket vm = Lwt_main.run ( connect (socket `Stats opt_socket) >>= fun fd -> - let count = ref 0L in - Lwt_list.iter_s (fun name -> - let cmd = Vmm_wire.Stats.stat !count my_version name in - count := Int64.succ !count ; - Vmm_lwt.write_wire fd cmd >>= function - | Error `Exception -> Lwt.fail_with "write error" - | Ok () -> Lwt.return_unit) vms >>= fun () -> + let cmd = Vmm_wire.Stats.subscribe my_command my_version vm in + (Vmm_lwt.write_wire fd cmd >>= function + | Error `Exception -> Lwt.fail_with "write error" + | Ok () -> Lwt.return_unit) >>= fun () -> (* now we busy read and process stat output *) let rec loop () = Vmm_lwt.read_wire fd >>= function @@ -220,6 +217,57 @@ let stats _ opt_socket vms = Vmm_lwt.safe_close fd) ; `Ok () +let event_log _ opt_socket vm = + Lwt_main.run ( + connect (socket `Log opt_socket) >>= fun fd -> + let cmd = Vmm_wire.Log.subscribe my_command my_version vm in + (Vmm_lwt.write_wire fd cmd >>= function + | Error `Exception -> Lwt.fail_with "write error" + | Ok () -> Lwt.return_unit) >>= fun () -> + (* now we busy read and process stat output *) + let rec loop () = + Vmm_lwt.read_wire fd >>= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () + | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit + | Ok (hdr, data) -> + if Vmm_wire.is_fail hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ; + Lwt.return_unit + else if Vmm_wire.is_reply hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; + loop () + else + begin + (match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with + | Some Vmm_wire.Log.Broadcast -> + begin match Vmm_wire.Log.decode_log_hdr data with + | Error (`Msg err) -> + Logs.warn (fun m -> m "ignoring error %s while decoding log" err) ; + | Ok (loghdr, logdata) -> + match Vmm_wire.Log.decode_event logdata with + | Error (`Msg err) -> + Logs.warn (fun m -> m "loghdr %a ignoring error %s while decoding logdata" + Vmm_core.Log.pp_hdr loghdr err) + | Ok event -> + Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event)) + end + | _ -> + Logs.warn (fun m -> m "unknown operation %lx" hdr.Vmm_wire.tag)) ; + loop () + end + in + loop () >>= fun () -> + Vmm_lwt.safe_close fd) ; + `Ok () + let help _ _ man_format cmds = function | None -> `Help (`Pager, None) | Some t when List.mem t cmds -> `Help (man_format, Some t) @@ -318,19 +366,24 @@ let console_cmd = Term.(ret (const console $ setup_log $ socket $ vm_name)), Term.info "console" ~doc ~man -let vm_names = - let doc = "Name virtual machine." in - Arg.(value & opt_all vm_c [] & info [ "n" ; "name" ] ~doc) - let stats_cmd = let doc = "statistics of VMs" in let man = [`S "DESCRIPTION"; `P "Shows statistics of VMs."] in - Term.(ret (const stats $ setup_log $ socket $ vm_names)), + Term.(ret (const stats $ setup_log $ socket $ opt_vmname)), Term.info "stats" ~doc ~man +let log_cmd = + let doc = "Event log" in + let man = + [`S "DESCRIPTION"; + `P "Shows event log of VM."] + in + Term.(ret (const event_log $ setup_log $ socket $ opt_vmname)), + Term.info "log" ~doc ~man + let help_cmd = let topic = let doc = "The topic to get help on. `topics' lists the topics." in @@ -353,7 +406,7 @@ let default_cmd = Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man -let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ] +let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] let () = match Term.eval_choice default_cmd cmds diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index aad9c0e..e4bf64b 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -7,9 +7,6 @@ open Vmm_core open Rresult open R.Infix - - - 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 diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 0c10bfb..a567fed 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -323,9 +323,8 @@ module Log = struct name : string ; } - let pp_hdr db ppf (hdr : hdr) = - let name = translate_serial db hdr.name in - Fmt.pf ppf "%a: %s" (Ptime.pp_human ()) hdr.ts name + let pp_hdr ppf (hdr : hdr) = + Fmt.pf ppf "%a: %s" (Ptime.pp_human ()) hdr.ts hdr.name let hdr context name = { ts = Ptime_clock.now () ; context ; name } @@ -355,6 +354,6 @@ module Log = struct type msg = hdr * event - let pp db ppf (hdr, event) = - Fmt.pf ppf "%a %a" (pp_hdr db) hdr pp_event event + let pp ppf (hdr, event) = + Fmt.pf ppf "%a %a" pp_hdr hdr pp_event event end diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index a4e1af7..c81aa22 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -36,7 +36,7 @@ let init () = { let log state (hdr, event) = let data = Vmm_wire.Log.log state.log_counter state.log_version hdr event in let log_counter = Int64.succ state.log_counter in - Logs.debug (fun m -> m "LOG %a" (Log.pp []) (hdr, event)) ; + Logs.debug (fun m -> m "LOG %a" Log.pp (hdr, event)) ; ({ state with log_counter }, `Log data) let handle_create t hdr vm_config (* policies *) = diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml index 80dfb34..bfe0382 100644 --- a/src/vmm_lwt.ml +++ b/src/vmm_lwt.ml @@ -71,9 +71,9 @@ let read_wire s = r b 0 l >|= function | Error e -> Error e | Ok () -> - Logs.debug (fun m -> m "read hdr %a, body %a" +(* Logs.debug (fun m -> m "read hdr %a, body %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf) - Cstruct.hexdump_pp (Cstruct.of_bytes b)) ; + Cstruct.hexdump_pp (Cstruct.of_bytes b)) ; *) Ok (hdr, Cstruct.of_bytes b) else Lwt.return (Ok (hdr, Cstruct.empty)) @@ -91,7 +91,7 @@ let write_wire s buf = Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ; Lwt.return (Error `Exception)) in - Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; + (* Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *) w 0 (Bytes.length buf) let safe_close fd = diff --git a/src/vmm_trie.ml b/src/vmm_trie.ml new file mode 100644 index 0000000..dc85b0a --- /dev/null +++ b/src/vmm_trie.ml @@ -0,0 +1,79 @@ +open Astring + +type 'a t = N of 'a option * 'a t String.Map.t + +let empty = N (None, String.Map.empty) + +let insert id e t = + let rec go (N (es, m)) = function + | [] -> + begin match es with + | None -> N (Some e, m), None + | Some es' -> N (Some e, m), Some es' + end + | x::xs -> + let n = match String.Map.find_opt x m with + | None -> empty + | Some n -> n + in + let entry, ret = go n xs in + N (es, String.Map.add x entry m), ret + in + go t id + +let remove id t = + let rec go (N (es, m)) = function + | [] -> if String.Map.is_empty m then None else Some (N (None, m)) + | x::xs -> + let n' = match String.Map.find_opt x m with + | None -> None + | Some n -> go n xs + in + let m' = match n' with + | None -> String.Map.remove x m + | Some entry -> String.Map.add x entry m + in + if String.Map.is_empty m' && es = None then None else Some (N (es, m')) + in + match go t id with + | None -> empty + | Some n -> n + +let find id t = + let rec go (N (es, m)) = function + | [] -> es + | x::xs -> + match String.Map.find_opt x m with + | None -> None + | Some n -> go n xs + in + go t id + +let collect id t = + let rec go acc prefix (N (es, m)) = + let acc' = + match es with + | None -> acc + | Some e -> (prefix, e) :: acc + in + function + | [] -> acc' + | x::xs -> + match String.Map.find_opt x m with + | None -> acc' + | Some n -> go acc' (prefix @ [ x ]) n xs + in + go [] [] t id + +let all t = + let rec go acc prefix (N (es, m)) = + let acc' = + match es with + | None -> acc + | Some e -> (prefix, e) :: acc + in + List.fold_left (fun acc (name, node) -> + go acc (prefix@[name]) node) + acc' (String.Map.bindings m) + in + go [] [] t diff --git a/src/vmm_trie.mli b/src/vmm_trie.mli new file mode 100644 index 0000000..5e2bca2 --- /dev/null +++ b/src/vmm_trie.mli @@ -0,0 +1,15 @@ +open Vmm_core + +type 'a t + +val empty : 'a t + +val insert : id -> 'a -> 'a t -> 'a t * 'a option + +val remove : id -> 'a t -> 'a t + +val find : id -> 'a t -> 'a option + +val collect : id -> 'a t -> (id * 'a) list + +val all : 'a t -> (id * 'a) list diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 8e23452..267b00a 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -260,19 +260,19 @@ module Stats = struct type op = | Add | Remove - | Stats + | Subscribe | Data let op_to_int = function | Add -> 0x0200l | Remove -> 0x0201l - | Stats -> 0x0202l + | Subscribe -> 0x0202l | Data -> 0x0203l let int_to_op = function | 0x0200l -> Some Add | 0x0201l -> Some Remove - | 0x0202l -> Some Stats + | 0x0202l -> Some Subscribe | 0x0203l -> Some Data | _ -> None @@ -382,7 +382,7 @@ module Stats = struct let remove id version name = encode ~name version id (op_to_int Remove) - let stat id version name = encode ~name version id (op_to_int Stats) + let subscribe id version name = encode ~name version id (op_to_int Subscribe) let data id version vm body = let name = Vmm_core.id_of_string vm in @@ -440,30 +440,27 @@ let split_id id = match List.rev id with module Log = struct type op = | Log - | History | Broadcast | Subscribe let op_to_int = function | Log -> 0x0300l - | History -> 0x0301l + | Subscribe -> 0x0301l | Broadcast -> 0x0302l - | Subscribe -> 0x0303l let int_to_op = function | 0x0300l -> Some Log - | 0x0301l -> Some History + | 0x0301l -> Some Subscribe | 0x0302l -> Some Broadcast - | 0x0303l -> Some Subscribe | _ -> None - let history id version name ts = - encode ~name ~body:(encode_ptime ts) version id (op_to_int History) + let subscribe id version name = + encode ~name version id (op_to_int Subscribe) let decode_log_hdr cs = decode_id_ts cs >>= fun ((id, ts), off) -> split_id id >>= fun (name, context) -> - Ok ({ Log.ts ; context ; name }, Cstruct.shift cs (16 + off)) + Ok ({ Log.ts ; context ; name }, Cstruct.shift cs off) let encode_addr ip port = let cs = Cstruct.create 6 in @@ -490,7 +487,7 @@ module Log = struct decode_string r >>= fun (block, l) -> let block = if block = "" then None else Some block in cs_shift r l >>= fun r' -> - decode_strings r' >>= fun taps -> + decode_strings r' >>= fun (taps, _) -> Ok (pid, taps, block) let encode_pid_exit pid c = diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index ba7c3b4..9571eee 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -22,17 +22,17 @@ let descr = ref [] type 'a t = { pid_nic : ((vmctx, int) result * (int * string) list) IM.t ; - vmid_pid : int String.Map.t ; - name_sockets : 'a String.Map.t ; + vmid_pid : int Vmm_trie.t ; + name_sockets : 'a Vmm_trie.t ; } let pp_strings pp taps = Fmt.(list ~sep:(unit ",@ ") string) pp taps let empty () = - { pid_nic = IM.empty ; vmid_pid = String.Map.empty ; name_sockets = String.Map.empty } + { pid_nic = IM.empty ; vmid_pid = Vmm_trie.empty ; name_sockets = Vmm_trie.empty } -let remove_socket t name = - let name_sockets = String.Map.remove name t.name_sockets in +let remove_entry t name = + let name_sockets = Vmm_trie.remove name t.name_sockets in { t with name_sockets } let rec wrap f arg = @@ -50,10 +50,10 @@ let fill_descr ctx = Logs.err (fun m -> m "vmmapi_statnames failed, shouldn't happen") ; () | Some d -> - Logs.info (fun m -> m "descr are %a" pp_strings d) ; + Logs.debug (fun m -> m "descr are %a" pp_strings d) ; descr := d end - | ds -> Logs.info (fun m -> m "%d descr are already present" (List.length ds)) + | ds -> Logs.debug (fun m -> m "%d descr are already present" (List.length ds)) let open_vmmapi ?(retries = 4) pid = let name = "solo5-" ^ string_of_int pid in @@ -91,20 +91,18 @@ let gather pid vmctx nics = | None -> Logs.warn (fun m -> m "failed to get ifdata for %s" nname) ; ifd - | Some data -> - Logs.debug (fun m -> m "adding ifdata for %s" nname) ; - data::ifd) + | Some data -> data::ifd) [] nics let tick t = - Logs.debug (fun m -> m "tick with %d vms" (IM.cardinal t.pid_nic)) ; let pid_nic = try_open_vmmapi t.pid_nic in let t' = { t with pid_nic } in let outs = - String.Map.fold (fun name socket out -> - match String.Map.find_opt name t.vmid_pid with - | None -> Logs.warn (fun m -> m "couldn't find pid of %s" name) ; out - | Some pid -> match IM.find_opt pid t.pid_nic with + List.fold_left (fun out (vmid, pid) -> + let listeners = Vmm_trie.collect vmid t'.name_sockets in + match listeners with + | [] -> Logs.warn (fun m -> m "nobody is listening") ; out + | xs -> match IM.find_opt pid t.pid_nic with | None -> Logs.warn (fun m -> m "couldn't find nics of %d" pid) ; out | Some (vmctx, nics) -> let ru, vmm, ifd = gather pid vmctx nics in @@ -115,9 +113,15 @@ let tick t = let vmm' = match vmm with None -> [] | Some xs -> List.combine !descr xs in ru', vmm', ifd in - let stats_encoded = Vmm_wire.Stats.(data 0L my_version name (encode_stats stats)) in - (socket, name, stats_encoded) :: out) - t'.name_sockets [] + List.fold_left (fun out (id, socket) -> + match Vmm_core.drop_super ~super:id ~sub:vmid with + | None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.pp_id id Vmm_core.pp_id vmid) ; out + | Some real_id -> + let name = Vmm_core.string_of_id real_id in + let stats_encoded = Vmm_wire.Stats.(data 0L my_version name (encode_stats stats)) in + (socket, vmid, stats_encoded) :: out) + out xs) + [] (Vmm_trie.all t'.vmid_pid) in (t', outs) @@ -141,14 +145,15 @@ let add_pid t vmid pid nics = Logs.info (fun m -> m "adding %d %a with vmctx %b" pid pp_strings nics (match vmctx with Error _ -> false | Ok _ -> true)) ; let pid_nic = IM.add pid (vmctx, nic_ids) t.pid_nic - and vmid_pid = String.Map.add vmid pid t.vmid_pid + and vmid_pid, ret = Vmm_trie.insert vmid pid t.vmid_pid in + assert (ret = None) ; Ok { t with pid_nic ; vmid_pid } let remove_vmid t vmid = - Logs.info (fun m -> m "removing vmid %s" vmid) ; - match String.Map.find vmid t.vmid_pid with - | None -> Logs.warn (fun m -> m "no pid found for %s" vmid) ; t + Logs.info (fun m -> m "removing vmid %a" Vmm_core.pp_id vmid) ; + match Vmm_trie.find vmid t.vmid_pid with + | None -> Logs.warn (fun m -> m "no pid found for %a" Vmm_core.pp_id vmid) ; t | Some pid -> Logs.info (fun m -> m "removing pid %d" pid) ; (try @@ -158,7 +163,7 @@ let remove_vmid t vmid = with _ -> ()) ; let pid_nic = IM.remove pid t.pid_nic - and vmid_pid = String.Map.remove vmid t.vmid_pid + and vmid_pid = Vmm_trie.remove vmid t.vmid_pid in { t with pid_nic ; vmid_pid } @@ -173,22 +178,21 @@ let handle t socket hdr cs = Error (`Msg "cannot handle version") else decode_strings cs >>= fun (id, off) -> - let name = Vmm_core.string_of_id id in match int_to_op hdr.tag with | Some Add -> decode_pid_taps (Cstruct.shift cs off) >>= fun (pid, taps) -> - add_pid t name pid taps >>= fun t -> - Ok (t, `Add name, success ~msg:"added" my_version hdr.id (op_to_int Add)) + add_pid t id pid taps >>= fun t -> + Ok (t, `Add id, None, success ~msg:"added" my_version hdr.id (op_to_int Add)) | Some Remove -> - let t = remove_vmid t name in - Ok (t, `Remove name, success ~msg:"removed" my_version hdr.id (op_to_int Remove)) - | Some Stats -> - let name_sockets = String.Map.add name socket t.name_sockets in - Ok ({ t with name_sockets }, `None, success ~msg:"subscribed" my_version hdr.id (op_to_int Stats)) + let t = remove_vmid t id in + Ok (t, `Remove id, None, success ~msg:"removed" my_version hdr.id (op_to_int Remove)) + | Some Subscribe -> + let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in + Ok ({ t with name_sockets }, `None, close, success ~msg:"subscribed" my_version hdr.id (op_to_int Subscribe)) | _ -> Error (`Msg "unknown command") in match r with - | Ok (t, action, out) -> t, action, out + | Ok (t, action, close, out) -> t, action, close, out | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing %s" msg) ; - t, `None, fail ~msg my_version hdr.id + t, `None, None, fail ~msg my_version hdr.id diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml index 04d754d..0300e4d 100644 --- a/stats/vmm_stats_lwt.ml +++ b/stats/vmm_stats_lwt.ml @@ -28,15 +28,14 @@ let handle s addr () = | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop acc | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return acc | Ok (hdr, data) -> - Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ; - let t', action, out = Vmm_stats.handle !t s hdr data in + let t', action, close, out = Vmm_stats.handle !t s hdr data in let acc = match action with | `Add pid -> pid :: acc | `Remove pid -> List.filter (fun m -> m <> pid) acc | `None -> acc in t := t' ; - Logs.debug (fun m -> m "sent %a" Cstruct.hexdump_pp out) ; + (match close with None -> Lwt.return_unit | Some s' -> Vmm_lwt.safe_close s') >>= fun () -> Vmm_lwt.write_wire s out >>= function | Ok () -> loop acc | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc @@ -54,7 +53,7 @@ let rec timer interval () = Vmm_lwt.write_wire s stat >>= function | Ok () -> Lwt.return_unit | Error `Exception -> - t := Vmm_stats.remove_socket !t name ; + t := Vmm_stats.remove_entry !t name ; Vmm_lwt.safe_close s) outs >>= fun () -> Lwt_unix.sleep interval >>= fun () -> From b90bae0340a5cfaad1c982c6da53ec5a7a1bdfdf Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 30 Sep 2018 12:13:24 +0200 Subject: [PATCH 11/73] vmm_influxdb: if there are no vmm stats, don\t report them --- app/vmm_influxdb_stats.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index cc84072..61b6cbd 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -220,9 +220,9 @@ let rec read_sock_write_tcp c ?fd addr addrtype = Lwt.return (Some fd) | Ok (name, (ru, vmm, ifs)) -> let ru = P.encode_ru name ru in - let vmm = P.encode_vmm name vmm in + let vmm = match vmm with [] -> [] | _ -> [ P.encode_vmm name vmm ] in let taps = List.map (P.encode_if name) ifs in - let out = (String.concat ~sep:"\n" (ru :: vmm :: taps)) ^ "\n" in + let out = (String.concat ~sep:"\n" (ru :: vmm @ taps)) ^ "\n" in Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ; Vmm_lwt.write_wire fd (Cstruct.of_string out) >>= function | Ok () -> From 49ab6a94cef6284b5a5aafcb6cae5aa3118bff17 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 30 Sep 2018 13:15:28 +0200 Subject: [PATCH 12/73] adjust decompress bound --- opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opam b/opam index 0b5376b..fbc7f10 100644 --- a/opam +++ b/opam @@ -26,7 +26,7 @@ depends: [ "nocrypto" "asn1-combinators" {>= "0.2.0"} "duration" - "decompress" {>= "0.7"} + "decompress" {= "0.7"} ] build: [ From 133884faf477d261fc25d913292c864a158d81bc Mon Sep 17 00:00:00 2001 From: Stefan Grundmann Date: Sun, 7 Oct 2018 00:04:13 +0000 Subject: [PATCH 13/73] log, stats and console socket go in their own directory --- src/vmm_core.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/vmm_core.ml b/src/vmm_core.ml index a567fed..7e8e755 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -8,10 +8,10 @@ let tmpdir = Fpath.(v "/var" / "run" / "albatross") let dbdir = Fpath.(v "/var" / "db" / "albatross") let socket_path = - let path name = Fpath.(to_string (tmpdir / name + "sock")) in + let path name = Fpath.(to_string (tmpdir / "util" / name + "sock")) in function | `Console -> path "console" - | `Vmmd -> path "vmmd" + | `Vmmd -> Fpath.(to_string (tmpdir / "vmmd.sock")) | `Stats -> path "stat" | `Log -> path "log" From 4c5a795a3bfd7ee798293b987b933d1d2ced617b Mon Sep 17 00:00:00 2001 From: Stefan Grundmann Date: Sun, 7 Oct 2018 01:22:48 +0000 Subject: [PATCH 14/73] console fifos in separate directory --- app/vmm_console.ml | 2 +- src/vmm_unix.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 6fb2197..3ec0cc6 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -51,7 +51,7 @@ let read_console name ring channel () = Lwt_io.close channel) let open_fifo name = - let fifo = Fpath.(Vmm_core.tmpdir / name + "fifo") in + let fifo = Fpath.(Vmm_core.tmpdir / "fifo" / name) in Lwt.catch (fun () -> Logs.debug (fun m -> m "opening %a for reading" Fpath.pp fifo) ; Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string fifo) >>= fun channel -> diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index c2649bc..b30eb65 100644 --- a/src/vmm_unix.ml +++ b/src/vmm_unix.ml @@ -59,7 +59,7 @@ let rec mkfifo name = let image_file, fifo_file = ((fun vm -> Fpath.(tmpdir / (vm_id vm) + "img")), - (fun vm -> Fpath.(tmpdir / (vm_id vm) + "fifo"))) + (fun vm -> Fpath.(tmpdir / "fifo" / (vm_id vm)))) let rec fifo_exists file = try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with From b66be32e8b9464da4cf88583561ff18963d903c1 Mon Sep 17 00:00:00 2001 From: Stefan Grundmann Date: Fri, 5 Oct 2018 22:46:53 +0000 Subject: [PATCH 15/73] FreeBSD rc(8) service scripts --- packaging/rc.d/albatross_console | 39 +++++++++++++++++ packaging/rc.d/albatross_daemon | 74 ++++++++++++++++++++++++++++++++ packaging/rc.d/albatross_log | 47 ++++++++++++++++++++ packaging/rc.d/albatross_stat | 39 +++++++++++++++++ packaging/rc.d/albatross_x | 72 +++++++++++++++++++++++++++++++ 5 files changed, 271 insertions(+) create mode 100755 packaging/rc.d/albatross_console create mode 100755 packaging/rc.d/albatross_daemon create mode 100755 packaging/rc.d/albatross_log create mode 100755 packaging/rc.d/albatross_stat create mode 100755 packaging/rc.d/albatross_x diff --git a/packaging/rc.d/albatross_console b/packaging/rc.d/albatross_console new file mode 100755 index 0000000..be7ac92 --- /dev/null +++ b/packaging/rc.d/albatross_console @@ -0,0 +1,39 @@ +#!/bin/sh + +# $FreeBSD$ +# +# PROVIDE: albatross_console +# REQUIRE: LOGIN +# KEYWORD: shutdown nojail +# +# Define these albatross_console_* variables in one of these files +# /etc/rc.conf +# /etc/rc.conf.local +# /etc/rc.conf.d/albatross_console +# /usr/local/etc/rc.conf.d/albatross_console +# +# albatross_console_flags: +# Default: "" +# + +. /etc/rc.subr + +name=albatross_console +rcvar=${name}_enable +desc="Albatross console service" +load_rc_config $name +start_cmd="albatross_console_start" + +: ${albatross_console_enable:="NO"} +: ${albatross_console_flags:=""} +: ${albatross_console_user:="albatross"} + +pidfile="/var/run/albatross_console.pid" +procname="/usr/local/libexec/albatross/vmm_console" + +albatross_console_start () { + /usr/sbin/daemon -p "${pidfile}" -u "${albatross_console_user}" -S \ + "${procname}" "${albatross_console_flags}" +} + +run_rc_command "$1" diff --git a/packaging/rc.d/albatross_daemon b/packaging/rc.d/albatross_daemon new file mode 100755 index 0000000..cfeeb8c --- /dev/null +++ b/packaging/rc.d/albatross_daemon @@ -0,0 +1,74 @@ +#!/bin/sh + +# $FreeBSD$ +# +# PROVIDE: albatross_daemon +# REQUIRE: LOGIN albatross_console albatross_log albatross_stat +# KEYWORD: shutdown nojail +# +# Define these albatross_daemon_* variables in one of these files +# /etc/rc.conf +# /etc/rc.conf.local +# /etc/rc.conf.d/albatross_daemon +# /usr/local/etc/rc.conf.d/albatross_daemon +# +# albatross_daemon_enable: Set YES to enable the albatross daemon service +# Default: NO +# albatross_daemon_flags: +# Default: "" +# +# + +. /etc/rc.subr + +name=albatross_daemon +rcvar=${name}_enable +desc="Albatross service" +load_rc_config $name +start_cmd="albatross_daemon_start" +start_precmd="albatross_daemon_precmd" + +: ${albatross_daemon_enable:="NO"} +: ${albatross_daemon_flags:=""} + +pidfile="/var/run/albatross_daemon.pid" +procname="/usr/local/libexec/albatross/vmmd" + +# +# force_depend script [rcvar] +# Force a service to start. Intended for use by services +# to resolve dependency issues. +# $1 - filename of script, in /usr/local/etc/rc.d, to run +# $2 - name of the script's rcvar (minus the _enable) +# +my_force_depend() +{ + local _depend _dep_rcvar + + _depend="$1" + _dep_rcvar="${2:-$1}_enable" + + [ -n "$rc_fast" ] && ! checkyesno always_force_depends && + checkyesno $_dep_rcvar && return 0 + + /usr/local/etc/rc.d/${_depend} forcestatus >/dev/null 2>&1 && return 0 + + info "${name} depends on ${_depend}, which will be forced to start." + if ! /usr/local/etc/rc.d/${_depend} forcestart; then + warn "Unable to force ${_depend}. It may already be running." + return 1 + fi +} + +albatross_daemon_precmd() { + my_force_depend albatross_console || err 1 "Cannot run albatross_console" + my_force_depend albatross_log || err 1 "Cannot run albatross_log" + my_force_depend albatross_stat || err 1 "Cannot run albatross_stat" +} + +albatross_daemon_start () { + /usr/sbin/daemon -S -o "{albatross_daemon_output}" -p "${pidfile}" \ + "${procname}" "${albatross_daemon_flags}" +} + +run_rc_command "$1" diff --git a/packaging/rc.d/albatross_log b/packaging/rc.d/albatross_log new file mode 100755 index 0000000..e49b02e --- /dev/null +++ b/packaging/rc.d/albatross_log @@ -0,0 +1,47 @@ +#!/bin/sh + +# $FreeBSD$ +# +# PROVIDE: albatross_log +# REQUIRE: LOGIN +# KEYWORD: shutdown nojail +# +# Define these albatross_log_* variables in one of these files +# /etc/rc.conf +# /etc/rc.conf.local +# /etc/rc.conf.d/albatross_log +# /usr/local/etc/rc.conf.d/albatross_log +# +# albatross_log_flags: +# Default: "" +# + +. /etc/rc.subr + +name=albatross_log +rcvar=${name}_enable +desc="Albatross log service" +load_rc_config $name +start_cmd="albatross_log_start" +start_precmd="albatross_log_precmd" + +: ${albatross_log_enable:="NO"} +: ${albatross_log_flags:=""} +: ${albatross_log_user:="albatross"} + +pidfile="/var/run/albatross_log.pid" +procname="/usr/local/libexec/albatross/vmm_log" +logfile="/var/log/albatross" + +albatross_log_precmd () { + [ -e "${logfile}" ] || + install -g ${albatross_log_user} -o ${albatross_log_user} \ + -- /dev/null "${logfile}"; +} + +albatross_log_start () { + /usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_log_user}" \ + "${procname}" "${albatross_log_flags}" +} + +run_rc_command "$1" diff --git a/packaging/rc.d/albatross_stat b/packaging/rc.d/albatross_stat new file mode 100755 index 0000000..04b215d --- /dev/null +++ b/packaging/rc.d/albatross_stat @@ -0,0 +1,39 @@ +#!/bin/sh + +# $FreeBSD$ +# +# PROVIDE: albatross_stat +# REQUIRE: LOGIN +# KEYWORD: shutdown nojail +# +# Define these albatross_stat_* variables in one of these files +# /etc/rc.conf +# /etc/rc.conf.local +# /etc/rc.conf.d/albatross_stat +# /usr/local/etc/rc.conf.d/albatross_stat +# +# albatross_stat_flags: +# Default: "" +# + +. /etc/rc.subr + +name=albatross_stat +rcvar=${name}_enable +desc="Albatross stat service" +load_rc_config $name +start_cmd="albatross_stat_start" + +: ${albatross_stat_enable:="NO"} +: ${albatross_stat_flags:=""} +: ${albatross_stat_user:="albatross"} + +pidfile="/var/run/albatross_stat.pid" +procname="/usr/local/libexec/albatross/vmm_stats_lwt" + +albatross_stat_start () { + /usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_stat_user}" \ + "${procname}" "${albatross_stat_flags}" +} + +run_rc_command "$1" diff --git a/packaging/rc.d/albatross_x b/packaging/rc.d/albatross_x new file mode 100755 index 0000000..0cfa493 --- /dev/null +++ b/packaging/rc.d/albatross_x @@ -0,0 +1,72 @@ +#!/bin/sh + +# $FreeBSD$ +# +# PROVIDE: albatross_x +# REQUIRE: LOGIN albatross_daemon +# KEYWORDS: shutdown nojail +# +# Define these albatross_x_* variables in one of these files +# /etc/rc.conf +# /etc/rc.conf.local +# /etc/rc.conf.d/albatross_x +# /usr/local/etc/rc.conf.d/albatross_x +# +# albatross_x_enable: Set YES to enable the albatross vm start service +# Default: NO +# albatross_x_vms: list of vms to manage +# Default: "" +# albatross_x_args_$VM: vm create arguments +# +# + +. /etc/rc.subr + +name=albatross_x +rcvar=${name}_enable +desc="Manage Albatross VMs" +load_rc_config $name +start_cmd="albatross_x_start" +stop_cmd="albatross_x_stop" +status_cmd="albatross_x_status" +extra_commands="status" + +: ${albatross_x_enable:="NO"} +: ${albatross_x_vms:=""} + +albatross_x_start () { + case $1 in + _ALL) + for _vm in $albatross_x_vms; do + eval _create_args=\"\$albatross_x_args_${_vm}\" + /usr/local/sbin/vmmc create $_vm $_create_args + done + return + ;; + esac + for _vm in $@; do + eval _create_args=\"\$albatross_x_args_${_vm}\" + /usr/local/sbin/vmmc create $_vm $_create_args + done +} + +albatross_x_stop () { + case $1 in + ALL) + for _vm in $albatross_x_vms + do /usr/local/sbin/vmmc destroy $_vm; done + return + esac + for _vm in $@ + do /usr/local/sbin/vmmc destroy $_vm; done +} + +albatross_x_status () { + /usr/local/sbin/vmmc info +} + +case $# in + 1) run_rc_command $@ ${albatross_x_list:-_ALL} ;; + *) run_rc_command $@ ;; +esac + From 6e925700f5ecb8048e1b473412d290262b8c1af1 Mon Sep 17 00:00:00 2001 From: Stefan Grundmann Date: Sat, 6 Oct 2018 23:34:47 +0000 Subject: [PATCH 16/73] FreeBSD package creation --- packaging/MANIFEST | 83 +++++++++++++++++++++++++++++++++++++ packaging/create_package.sh | 54 ++++++++++++++++++++++++ 2 files changed, 137 insertions(+) create mode 100644 packaging/MANIFEST create mode 100755 packaging/create_package.sh diff --git a/packaging/MANIFEST b/packaging/MANIFEST new file mode 100644 index 0000000..f15ccac --- /dev/null +++ b/packaging/MANIFEST @@ -0,0 +1,83 @@ +name: albatross +version: 1.0.%%GITVER%%_1 +origin: local/albatross +comment: Albatross: Managing virtual machines +www: https://github.com/hannesm/vmm +maintainer: Hannes Mehnert +prefix: /usr/local +licenselogic: single +licenses: [NONE] +flatsize: %%FLATSIZE%% +categories: [local] +deps { + gmp { + origin = "math/gmp"; + version = "6.1.2"; + } +} +scripts : { + pre-install = < Creating groups." +if ! ${PW} groupshow albatross >/dev/null 2>&1; then + echo "Creating group 'albatross' with gid '496'." + ${PW} groupadd albatross -g 496 +else + echo "Using existing group 'albatross'." +fi +echo "===> Creating users" +if ! ${PW} usershow albatross >/dev/null 2>&1; then + echo "Creating user 'albatross' with uid '496'." + ${PW} useradd albatross -u 496 -g 496 -c "albatross daemon" -d /nonexistent -s /usr/sbin/nologin +else + echo "Using existing user 'albatross'." +fi +EOD; + post-install = </dev/null 2>&1; then + echo "==> You should manually remove the \"albatross\" user. " +fi +if ${PW} groupshow albatross >/dev/null 2>&1; then + echo "==> You should manually remove the \"albatross\" group " +fi +EOD; + +} +desc = < "$manifest" + +{ + printf '\nfiles {\n' + find "$rootdir" -type f -exec sha256 -r {} + | + awk '{print " " $2 ": \"" $1 "\"," }' + find "$rootdir" -type l | + awk "{print \" \"\$1 \": -,\"}" + printf '}\n' +} | sed -e "s:${rootdir}::" >> "$manifest" + +pkg create -r "$rootdir" -M "$manifest" -o $basedir/_build/ From 7275073d6bf4068d6fdcdd7a2c234ff7057da7bb Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 9 Oct 2018 18:41:46 +0100 Subject: [PATCH 17/73] 4.04 is broken, and unsupported --- .travis.yml | 1 - opam | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 1ef11ef..b8ac43c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,7 +7,6 @@ env: - PACKAGE="albatross" - TESTS=false matrix: - - OCAML_VERSION=4.04 - OCAML_VERSION=4.05 - OCAML_VERSION=4.06 notifications: diff --git a/opam b/opam index fbc7f10..79e236f 100644 --- a/opam +++ b/opam @@ -4,7 +4,7 @@ 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"] +available: [ ocaml-version >= "4.05.0"] depends: [ "ocamlfind" {build} From e413b8c99acd3d3aad198fd7873100b501c3b683 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 12 Oct 2018 19:45:46 +0200 Subject: [PATCH 18/73] remove naming struggle in vm_config and Log.hdr --- app/vmm_log.ml | 4 ++-- app/vmmc.ml | 8 ++------ src/vmm_asn.ml | 4 ++-- src/vmm_core.ml | 22 ++++++++-------------- src/vmm_engine.ml | 22 ++++++++++------------ src/vmm_unix.ml | 4 ++-- src/vmm_wire.ml | 23 +++++++++-------------- 7 files changed, 35 insertions(+), 52 deletions(-) diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 0338ab8..649a548 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -73,7 +73,7 @@ let send_history s ring id cmd_id = let cs = Cstruct.of_string x in match Vmm_wire.Log.decode_log_hdr cs with | Ok (hdr, _) -> - begin match Vmm_core.drop_super ~super:id ~sub:hdr.Vmm_core.Log.context with + begin match Vmm_core.drop_super ~super:id ~sub:hdr.Vmm_core.Log.name with | Some [] -> cs :: acc | _ -> acc end @@ -118,7 +118,7 @@ let handle mvar ring s addr () = Lwt_mvar.put mvar data >>= fun () -> let data' = Vmm_wire.encode ~body:data my_version !bcast (Vmm_wire.Log.op_to_int Vmm_wire.Log.Broadcast) in bcast := Int64.succ !bcast ; - broadcast hdr.Vmm_core.Log.context data' !tree >>= fun tree' -> + broadcast hdr.Vmm_core.Log.name data' !tree >>= fun tree' -> tree := tree' ; loop () end diff --git a/app/vmmc.ml b/app/vmmc.ml index 4265b34..d7ad5fa 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -82,18 +82,14 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc | Ok data -> data | Error (`Msg s) -> invalid_arg s in - let prefix, vname = match List.rev name with - | [ name ] -> [], name - | name::tl -> List.rev tl, name - | [] -> assert false - and argv = match boot_params with + let argv = match boot_params with | [] -> None | xs -> Some xs (* TODO we could do the compression btw *) and vmimage = `Hvt_amd64, Cstruct.of_string image' in let vm_config = { - prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; + vname = name ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in Lwt_main.run ( diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 3a1bd24..d054e41 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -213,9 +213,9 @@ let vm_of_cert prefix cert = 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 vname = prefix @ [ id cert ] in let network = match network with None -> [] | Some x -> x in - Ok { prefix ; vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } + Ok { vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } let command_of_cert version cert = version_of_cert version cert >>= fun () -> diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 7e8e755..6b088e6 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -154,8 +154,7 @@ let is_sub ~super ~sub = sub_bridges super.bridges sub.bridges && sub_block super.block sub.block type vm_config = { - prefix : id ; - vname : string ; + vname : id ; cpuid : int ; requested_memory : int ; block_device : string option ; @@ -164,13 +163,9 @@ type vm_config = { argv : string list option ; } -let fullname vm = vm.prefix @ [ vm.vname ] - -let vm_id vm = string_of_id (fullname vm) - (* used for block devices *) -let location vm = match vm.prefix with - | tld::rest -> tld, String.concat ~sep:"." (rest@[vm.vname]) +let location vm = match vm.vname with + | tld::rest -> tld, String.concat ~sep:"." rest | [] -> invalid_arg "dunno how this happened" let pp_image ppf (typ, blob) = @@ -178,8 +173,8 @@ let pp_image ppf (typ, blob) = Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l let pp_vm_config ppf (vm : vm_config) = - Fmt.pf ppf "%s cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a" - vm.vname vm.cpuid vm.requested_memory + Fmt.pf ppf "%a cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a" + pp_id vm.vname vm.cpuid vm.requested_memory Fmt.(option ~none:(unit "no") string) vm.block_device Fmt.(list ~sep:(unit ", ") string) vm.network pp_image vm.vmimage @@ -319,14 +314,13 @@ let pp_ifdata ppf i = module Log = struct type hdr = { ts : Ptime.t ; - context : id ; - name : string ; + name : id ; } let pp_hdr ppf (hdr : hdr) = - Fmt.pf ppf "%a: %s" (Ptime.pp_human ()) hdr.ts hdr.name + Fmt.pf ppf "%a: %a" (Ptime.pp_rfc3339 ()) hdr.ts pp_id hdr.name - let hdr context name = { ts = Ptime_clock.now () ; context ; name } + let hdr name = { ts = Ptime_clock.now () ; name } type event = [ `Startup diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index c81aa22..7a4f0b9 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -40,8 +40,7 @@ let log state (hdr, event) = ({ state with log_counter }, `Log data) let handle_create t hdr vm_config (* policies *) = - let full = fullname vm_config in - (if Vmm_resources.exists t.resources full then + (if Vmm_resources.exists t.resources vm_config.vname then Error (`Msg "VM with same name is already running") else Ok ()) >>= fun () -> @@ -51,14 +50,14 @@ let handle_create t hdr vm_config (* policies *) = Vmm_unix.prepare vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; (* TODO should we pre-reserve sth in t? *) - let cons = Vmm_wire.Console.add t.console_counter t.console_version full in + let cons = Vmm_wire.Console.add t.console_counter t.console_version vm_config.vname in Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons ], `Create (fun t task -> (* actually execute the vm *) Vmm_unix.exec vm_config taps >>= fun vm -> Logs.debug (fun m -> m "exec()ed vm") ; - Vmm_resources.insert t.resources full vm >>= fun resources -> - let tasks = String.Map.add (string_of_id full) task t.tasks in + Vmm_resources.insert t.resources vm_config.vname vm >>= fun resources -> + let tasks = String.Map.add (string_of_id vm_config.vname) task t.tasks in let used_bridges = List.fold_left2 (fun b br ta -> let old = match String.Map.find br b with @@ -69,12 +68,12 @@ let handle_create t hdr vm_config (* policies *) = t.used_bridges vm_config.network taps in let t = { t with resources ; tasks ; used_bridges } in - let t, out = log t (Log.hdr vm_config.prefix vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in + let t, out = log t (Log.hdr vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in let data = Vmm_wire.success t.client_version hdr.Vmm_wire.id Vmm_wire.Vm.(op_to_int Create) in Ok (t, [ `Data data ; out ], vm))) let setup_stats t vm = - let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version (fullname vm.config) vm.pid vm.taps in + let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version vm.config.vname vm.pid vm.taps in let t = { t with stats_counter = Int64.succ t.stats_counter } in Ok (t, [ `Stat stat_out ]) @@ -83,7 +82,7 @@ let handle_shutdown t vm r = | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; let resources = - match Vmm_resources.remove t.resources (fullname vm.config) vm with + match Vmm_resources.remove t.resources vm.config.vname vm with | Ok resources -> resources | Error (`Msg e) -> Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ; @@ -98,11 +97,10 @@ let handle_shutdown t vm r = String.Map.add br (String.Set.remove ta old) b) t.used_bridges vm.config.network vm.taps in - let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version (fullname vm.config) in - let tasks = String.Map.remove (vm_id vm.config) t.tasks in + let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version vm.config.vname in + let tasks = String.Map.remove (string_of_id vm.config.vname) t.tasks in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in - let t, logout = log t (Log.hdr vm.config.prefix vm.config.vname, - `VM_stop (vm.pid, r)) + let t, logout = log t (Log.hdr vm.config.vname, `VM_stop (vm.pid, r)) in (t, [ `Stat stat_out ; logout ]) diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index b30eb65..3b17165 100644 --- a/src/vmm_unix.ml +++ b/src/vmm_unix.ml @@ -58,8 +58,8 @@ let rec mkfifo name = | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name let image_file, fifo_file = - ((fun vm -> Fpath.(tmpdir / (vm_id vm) + "img")), - (fun vm -> Fpath.(tmpdir / "fifo" / (vm_id vm)))) + ((fun vm -> Fpath.(tmpdir / (string_of_id vm.vname) + "img")), + (fun vm -> Fpath.(tmpdir / "fifo" / (string_of_id vm.vname)))) let rec fifo_exists file = try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 267b00a..e8356b5 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -458,9 +458,8 @@ module Log = struct encode ~name version id (op_to_int Subscribe) let decode_log_hdr cs = - decode_id_ts cs >>= fun ((id, ts), off) -> - split_id id >>= fun (name, context) -> - Ok ({ Log.ts ; context ; name }, Cstruct.shift cs off) + decode_id_ts cs >>= fun ((name, ts), off) -> + Ok ({ Log.ts ; name }, Cstruct.shift cs off) let encode_addr ip port = let cs = Cstruct.create 6 in @@ -538,10 +537,8 @@ module Log = struct | x -> R.error_msgf "couldn't parse event type %d" x let log id version hdr event = - let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) - and name = hdr.Log.context @ [ hdr.Log.name ] - in - encode ~name ~body version id (op_to_int Log) + let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) in + encode ~name:hdr.name ~body version id (op_to_int Log) end module Vm = struct @@ -566,7 +563,7 @@ module Vm = struct encode ~name version id (op_to_int Info) let encode_vm vm = - let name = encode_strings (vm.config.prefix @ [ vm.config.vname ]) + let name = encode_strings vm.config.vname and memory = encode_int vm.config.requested_memory and cs = encode_string (Bos.Cmd.to_string vm.cmd) and pid = encode_int vm.pid @@ -605,9 +602,8 @@ module Vm = struct Cstruct.concat [ cpu ; mem ; block ; network ; vmimage ; args ] let decode_vm_config buf = - decode_strings buf >>= fun (id, off) -> - Logs.debug (fun m -> m "vm_config id %a" pp_id id) ; - split_id id >>= fun (vname, prefix) -> + decode_strings buf >>= fun (vname, off) -> + Logs.debug (fun m -> m "vm_config name %a" pp_id vname) ; cs_shift buf off >>= fun buf' -> decode_int buf' >>= fun cpuid -> Logs.debug (fun m -> m "cpuid %d" cpuid) ; @@ -630,12 +626,11 @@ module Vm = struct cs_shift buf'''' (16 + size) >>= fun buf''''' -> decode_strings buf''''' >>= fun (argv, _) -> let argv = match argv with [] -> None | xs -> Some xs in - Ok { vname ; prefix ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } + Ok { vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } let create id version vm = let body = encode_vm_config vm in - let name = vm.prefix @ [ vm.vname ] in - encode ~name ~body version id (op_to_int Create) + encode ~name:vm.vname ~body version id (op_to_int Create) let destroy id version name = encode ~name version id (op_to_int Destroy) From 3abd769425449294478e0925bffab9af9d2fee23 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 12 Oct 2018 19:56:17 +0200 Subject: [PATCH 19/73] minor pkg fixes --- packaging/MANIFEST | 2 +- packaging/rc.d/albatross_console | 2 +- packaging/rc.d/albatross_daemon | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/packaging/MANIFEST b/packaging/MANIFEST index f15ccac..fc8baec 100644 --- a/packaging/MANIFEST +++ b/packaging/MANIFEST @@ -2,7 +2,7 @@ name: albatross version: 1.0.%%GITVER%%_1 origin: local/albatross comment: Albatross: Managing virtual machines -www: https://github.com/hannesm/vmm +www: https://github.com/hannesm/albatross maintainer: Hannes Mehnert prefix: /usr/local licenselogic: single diff --git a/packaging/rc.d/albatross_console b/packaging/rc.d/albatross_console index be7ac92..7b3df7b 100755 --- a/packaging/rc.d/albatross_console +++ b/packaging/rc.d/albatross_console @@ -32,7 +32,7 @@ pidfile="/var/run/albatross_console.pid" procname="/usr/local/libexec/albatross/vmm_console" albatross_console_start () { - /usr/sbin/daemon -p "${pidfile}" -u "${albatross_console_user}" -S \ + /usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_console_user}" \ "${procname}" "${albatross_console_flags}" } diff --git a/packaging/rc.d/albatross_daemon b/packaging/rc.d/albatross_daemon index cfeeb8c..8ec44fa 100755 --- a/packaging/rc.d/albatross_daemon +++ b/packaging/rc.d/albatross_daemon @@ -67,8 +67,8 @@ albatross_daemon_precmd() { } albatross_daemon_start () { - /usr/sbin/daemon -S -o "{albatross_daemon_output}" -p "${pidfile}" \ - "${procname}" "${albatross_daemon_flags}" + /usr/sbin/daemon -S -p "${pidfile}" "${procname}" \ + "${albatross_daemon_flags}" } run_rc_command "$1" From f8d8cffa4698f548f21ef289e9650d3c1940232e Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 12 Oct 2018 20:03:41 +0200 Subject: [PATCH 20/73] no libs --- pkg/pkg.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 259b560..c97fff5 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -18,7 +18,7 @@ let () = Pkg.bin "provision/vmm_sign" ; Pkg.bin "provision/vmm_revoke" ; Pkg.bin "provision/vmm_gen_ca" ; - Pkg.clib "stats/libvmm_stats_stubs.clib" ; + (* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *) Pkg.bin "stats/vmm_stats_lwt" ; (* Pkg.bin "app/vmm_prometheus_stats" ; *) Pkg.bin "app/vmm_influxdb_stats" ; From ea83013068b6b13e829900241ef42562c4727c31 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 12 Oct 2018 20:34:00 +0200 Subject: [PATCH 21/73] delegation -> policy --- provision/vmm_sign.ml | 22 +++++++++++----------- src/vmm_asn.ml | 2 +- src/vmm_asn.mli | 2 +- src/vmm_core.ml | 8 ++++---- src/vmm_resources.ml | 2 +- src/vmm_resources.mli | 2 +- 6 files changed, 19 insertions(+), 19 deletions(-) diff --git a/provision/vmm_sign.ml b/provision/vmm_sign.ml index b425818..f7bb51a 100644 --- a/provision/vmm_sign.ml +++ b/provision/vmm_sign.ml @@ -31,12 +31,12 @@ let sign dbname cacert key csr days = (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 + let policy = match Vmm_asn.policy_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) ; + Fmt.(option ~none:(unit "no") Vmm_core.pp_policy) policy) ; let req_exts = match List.find (function `Extensions _ -> true | _ -> false) ri.X509.CA.extensions @@ -66,7 +66,7 @@ let sign dbname cacert key csr days = 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 + let cpuids = match policy with | None -> None | Some x -> Some (Vmm_core.IS.elements x.Vmm_core.cpuids) in @@ -91,7 +91,7 @@ let sign dbname cacert key csr days = 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 + let memory = match policy with | None -> None | Some x -> Some x.Vmm_core.memory in @@ -119,7 +119,7 @@ let sign dbname cacert key csr days = | None -> Ok None | Some [] -> Ok None | Some x -> - match delegation with + match policy with | None -> Ok (Some x) | Some del -> let bridges = del.Vmm_core.bridges in @@ -141,7 +141,7 @@ let sign dbname cacert key csr days = (opt Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>= function | None -> Ok None | Some x -> - match delegation with + match policy 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") @@ -167,7 +167,7 @@ let sign dbname cacert key csr days = Ok (exts @ l_exts) | `Delegation -> (req Vmm_asn.Oid.cpuids req_exts Vmm_asn.ints_of_cstruct >>= fun x -> - match delegation with + match policy 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 @@ -177,7 +177,7 @@ let sign dbname cacert key csr days = 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 + match policy with | None -> Ok x | Some d when d.Vmm_core.memory >= x -> Ok x | Some d -> Rresult.R.error_msgf @@ -187,7 +187,7 @@ let sign dbname cacert key csr days = (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 + | Some x -> match policy 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") @@ -200,7 +200,7 @@ let sign dbname cacert key csr days = | 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 + match policy with | None -> Ok x | Some d when d.Vmm_core.vms >= x -> Ok x | Some d -> Rresult.R.error_msgf @@ -210,7 +210,7 @@ let sign dbname cacert key csr days = (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 + | Some xs -> match policy with | None -> Ok (Some xs) | Some x -> let sub = diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index d054e41..d541d3b 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -170,7 +170,7 @@ let version_of_cert version cert = R.error_msgf "unsupported asn version %a (expected %a)" pp_version version' pp_version version -let delegation_of_cert version cert = +let policy_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 -> diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 15d42f9..7a571b5 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -154,7 +154,7 @@ val vm_of_cert : Vmm_core.id -> X509.t -> (Vmm_core.vm_config, [> `Msg of string 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 +val policy_of_cert : version -> X509.t -> (Vmm_core.policy, [> `Msg of string ]) result (** [command_of_cert version cert] is either the decoded command, or an error. *) val command_of_cert : version -> X509.t -> (Vmm_core.command, [> `Msg of string ]) result diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 6b088e6..9c470b2 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -111,7 +111,7 @@ let pp_bridge ppf = function Fmt.pf ppf "%s: %a - %a, GW: %a/%d" name Ipaddr.V4.pp_hum l Ipaddr.V4.pp_hum h Ipaddr.V4.pp_hum gw nm -type delegation = { +type policy = { vms : int ; cpuids : IS.t ; memory : int ; @@ -119,8 +119,8 @@ type delegation = { bridges : bridge String.Map.t ; } -let pp_delegation ppf res = - Fmt.pf ppf "delegated: %d vms %a cpus %d MB memory %a MB block bridges: %a" +let pp_policy ppf res = + Fmt.pf ppf "policy: %d vms %a cpus %d MB memory %a MB block bridges: %a" res.vms pp_is res.cpuids res.memory Fmt.(option ~none:(unit "no") int) res.block Fmt.(list ~sep:(unit ", ") pp_bridge) @@ -184,7 +184,7 @@ let good_bridge idxs nets = (* TODO: uniqueness of n -- it should be an ordered set? *) List.for_all (fun n -> String.Map.mem n nets) idxs -let vm_matches_res (res : delegation) (vm : vm_config) = +let vm_matches_res (res : policy) (vm : vm_config) = res.vms >= 1 && IS.mem vm.cpuid res.cpuids && vm.requested_memory <= res.memory && good_bridge vm.network res.bridges diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 0a9e5ef..e5e84d7 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -15,7 +15,7 @@ let pp_res_entry ppf res = let empty_res = { running_vms = 0 ; used_memory = 0 } -let check_resource (policy : delegation) (vm : vm_config) (res : res_entry) = +let check_resource (policy : policy) (vm : vm_config) (res : res_entry) = succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory let add (vm : vm) (res : res_entry) = diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index 697b778..08a12ca 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -29,7 +29,7 @@ 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 -> + Vmm_core.vm_config -> (string * Vmm_core.policy) list -> (unit, [> `Msg of string ]) result (** [exists t id] is [true] if the [id] already exists, [false] otherwise. *) From 182e2ae10cdaa76e5b9fc31f6a42c2e8f052b0ba Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 13 Oct 2018 01:05:21 +0200 Subject: [PATCH 22/73] policies: vmmc now has more subcommands - policy [-n name] returns all policies in name and below - add_policy [-n name] [--cpu cpuid] [--mem mem] [--bridge bridge] [--block size] adds a policy - remove [-n name] removes policy at name policy is just the same which is in vmm_req_delegation, and vmm_resources now check them: - you cannot insert a subpolicy violating the prefix - you cannot insert a policy which would forbid current resource usage - you cannot insert a policy with which any subpolicy would be invalid - you can adjust (increase/decrease) a policy if the above invariants are kept implement "force create" directly in vmmd: much nicer to - check resource constraints, - kill vm potentially, - and create a new vm, all as single transaction. --- app/vmmc.ml | 170 ++++++++++++++++++++++++++++++++++++------ app/vmmd.ml | 104 +++++++++++++++----------- src/vmm_asn.ml | 32 ++++++++ src/vmm_asn.mli | 9 ++- src/vmm_core.ml | 21 ++++-- src/vmm_engine.ml | 96 ++++++++++++++++++------ src/vmm_resources.ml | 166 +++++++++++++++++------------------------ src/vmm_resources.mli | 48 ++++-------- src/vmm_trie.ml | 18 +++++ src/vmm_trie.mli | 2 + src/vmm_wire.ml | 164 +++++++++++----------------------------- 11 files changed, 483 insertions(+), 347 deletions(-) diff --git a/app/vmmc.ml b/app/vmmc.ml index d7ad5fa..2452939 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -2,6 +2,8 @@ open Lwt.Infix +open Astring + open Vmm_core let my_version = `WV2 @@ -62,19 +64,74 @@ let info_ _ opt_socket name = ) ; `Ok () -let really_destroy opt_socket name = - connect (socket `Vmmd opt_socket) >>= fun fd -> - let cmd = Vmm_wire.Vm.destroy my_command my_version name in - (Vmm_lwt.write_wire fd cmd >>= function - | Ok () -> - (process fd >|= function - | Error () -> () - | Ok _ -> Logs.app (fun m -> m "destroyed VM")) - | Error `Exception -> Lwt.return_unit) >>= fun () -> - Vmm_lwt.safe_close fd +let policy _ opt_socket name = + Lwt_main.run ( + connect (socket `Vmmd opt_socket) >>= fun fd -> + let policy = Vmm_wire.Vm.policy my_command my_version name in + (Vmm_lwt.write_wire fd policy >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok data -> + match Vmm_wire.Vm.decode_policies data with + | Ok (policies, _) -> + List.iter (fun (id, policy) -> + Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy)) + policies + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while decoding policies" msg)) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd + ) ; + `Ok () + +let remove_policy _ opt_socket name = + Lwt_main.run ( + connect (socket `Vmmd opt_socket) >>= fun fd -> + let cmd = Vmm_wire.Vm.remove_policy my_command my_version name in + (Vmm_lwt.write_wire fd cmd >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok _ -> Logs.app (fun m -> m "removed policy")) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd) ; + `Ok () + +let add_policy _ opt_socket name vms memory cpus block bridges = + Lwt_main.run ( + connect (socket `Vmmd opt_socket) >>= fun fd -> + let bridges = match bridges with + | xs -> + let add m v = + let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in + String.Map.add n v m + in + List.fold_left add String.Map.empty xs + and cpuids = IS.of_list cpus + in + let policy = { vms ; cpuids ; memory ; block ; bridges } in + let cmd = Vmm_wire.Vm.insert_policy my_command my_version name policy in + (Vmm_lwt.write_wire fd cmd >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok _ -> Logs.app (fun m -> m "added policy")) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd) ; + `Ok () let destroy _ opt_socket name = - Lwt_main.run (really_destroy opt_socket name) ; + Lwt_main.run ( + connect (socket `Vmmd opt_socket) >>= fun fd -> + let cmd = Vmm_wire.Vm.destroy my_command my_version name in + (Vmm_lwt.write_wire fd cmd >>= function + | Ok () -> + (process fd >|= function + | Error () -> () + | Ok _ -> Logs.app (fun m -> m "destroyed VM")) + | Error `Exception -> Lwt.return_unit) >>= fun () -> + Vmm_lwt.safe_close fd) ; `Ok () let create _ opt_socket force name image cpuid requested_memory boot_params block_device network = @@ -93,19 +150,19 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc vmimage ; argv } in Lwt_main.run ( - (if force then - really_destroy opt_socket name - else - Lwt.return_unit) >>= fun () -> connect (socket `Vmmd opt_socket) >>= fun fd -> - let vm = Vmm_wire.Vm.create my_command my_version vm_config in + let vm = + if force then + Vmm_wire.Vm.force_create my_command my_version vm_config + else + Vmm_wire.Vm.create my_command my_version vm_config + in (Vmm_lwt.write_wire fd vm >>= function | Error `Exception -> Lwt.return_unit | Ok () -> process fd >|= function | Ok _ -> Logs.app (fun m -> m "successfully started VM") | Error () -> ()) >>= fun () -> - Vmm_lwt.safe_close fd - ) ; + Vmm_lwt.safe_close fd ) ; `Ok () let console _ opt_socket name = @@ -315,6 +372,15 @@ let opt_vmname = let doc = "Name virtual machine." in Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc) +let remove_policy_cmd = + let doc = "removes a policy" in + let man = + [`S "DESCRIPTION"; + `P "Removes a policy."] + in + Term.(ret (const remove_policy $ setup_log $ socket $ opt_vmname)), + Term.info "remove" ~doc ~man + let info_cmd = let doc = "information about VMs" in let man = @@ -324,14 +390,72 @@ let info_cmd = Term.(ret (const info_ $ setup_log $ socket $ opt_vmname)), Term.info "info" ~doc ~man +let policy_cmd = + let doc = "active policies" in + let man = + [`S "DESCRIPTION"; + `P "Shows information about policies."] + in + Term.(ret (const policy $ setup_log $ socket $ opt_vmname)), + Term.info "policy" ~doc ~man + +let cpus = + let doc = "CPUids to allow" in + Arg.(value & opt_all int [] & info [ "cpu" ] ~doc) + +let vms = + let doc = "Number of VMs to allow" in + Arg.(required & pos 0 (some int) None & info [] ~doc) + +let block = + let doc = "Block storage to allow" in + Arg.(value & opt (some int) None & info [ "block" ] ~doc) + +let mem = + let doc = "Memory to allow" in + Arg.(value & opt int 512 & info [ "mem" ] ~doc) + +let 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 add_policy_cmd = + let doc = "Add a policy" in + let man = + [`S "DESCRIPTION"; + `P "Adds a policy."] + in + Term.(ret (const add_policy $ setup_log $ socket $ opt_vmname $ vms $ mem $ cpus $ block $ bridge)), + Term.info "add_policy" ~doc ~man + let cpu = let doc = "CPUid" in Arg.(value & opt int 0 & info [ "cpu" ] ~doc) -let mem = - let doc = "Memory to provision" in - Arg.(value & opt int 512 & info [ "mem" ] ~doc) - let args = let doc = "Boot arguments" in Arg.(value & opt_all string [] & info [ "arg" ] ~doc) @@ -402,7 +526,7 @@ let default_cmd = Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man -let cmds = [ help_cmd ; info_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] +let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] let () = match Term.eval_choice default_cmd cmds diff --git a/app/vmmd.ml b/app/vmmd.ml index 0416557..fe5380e 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -22,7 +22,53 @@ type out = [ | `Log of Cstruct.t ] -let handle state out c_fd fd addr = +let state = ref (Vmm_engine.init ()) + +let create c_fd process cont = + Vmm_lwt.read_wire c_fd >>= function + | Ok (hdr, data) -> + if Vmm_wire.is_fail hdr then begin + Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; + Lwt.return_unit + end else if Vmm_wire.is_reply hdr then begin + (* assert hdr.id = id! *) + let await, wakeme = Lwt.wait () in + begin match cont !state await with + | Error (`Msg msg) -> + Logs.err (fun m -> m "create continuation failed %s" msg) ; + Lwt.return_unit + | Ok (state'', out, vm) -> + state := state'' ; + s := { !s with vm_created = succ !s.vm_created } ; + Lwt.async (fun () -> + Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> + let state', out' = Vmm_engine.handle_shutdown !state vm r in + s := { !s with vm_destroyed = succ !s.vm_destroyed } ; + state := state' ; + process out' >|= fun () -> + Lwt.wakeup wakeme ()) ; + process out >>= fun () -> + begin match Vmm_engine.setup_stats !state vm with + | Ok (state', out) -> + state := state' ; + process out (* TODO: need to read from stats socket! *) + | Error (`Msg e) -> + Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; + Lwt.return_unit + end + end + end else begin + Logs.err (fun m -> m "reading from console %lx, %a" hdr.Vmm_wire.tag Cstruct.hexdump_pp data) ; + Lwt.return_unit + end + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while reading from console" msg) ; + Lwt.return_unit + | Error _ -> + Logs.err (fun m -> m "error while reading from console") ; + Lwt.return_unit + +let handle out c_fd fd addr = (* out is for `Log | `Stat | `Cons (including reconnect semantics) *) (* need to handle data out (+ die on write failure) *) Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ; @@ -58,50 +104,19 @@ let handle state out c_fd fd addr = match next with | `End -> Lwt.return_unit | `Wait (task, out) -> task >>= fun () -> process out + | `Wait_and_create (state', task, next) -> + state := state' ; + task >>= fun () -> + let state', data, n = next !state in + state := state' ; + process data >>= fun () -> + (match n with + | `End -> Lwt.return_unit + | `Create cont -> create c_fd process cont) | `Create cont -> + create c_fd process cont (* data contained a write to console, we need to wait for its reply first *) - Vmm_lwt.read_wire c_fd >>= function - | Ok (hdr, data) -> - if Vmm_wire.is_fail hdr then begin - Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; - Lwt.return_unit - end else if Vmm_wire.is_reply hdr then begin - (* assert hdr.id = id! *) - let await, wakeme = Lwt.wait () in - begin match cont !state await with - | Error (`Msg msg) -> - Logs.err (fun m -> m "create continuation failed %s" msg) ; - Lwt.return_unit - | Ok (state'', out, vm) -> - state := state'' ; - s := { !s with vm_created = succ !s.vm_created } ; - Lwt.async (fun () -> - Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> - let state', out' = Vmm_engine.handle_shutdown !state vm r in - s := { !s with vm_destroyed = succ !s.vm_destroyed } ; - state := state' ; - process out' >|= fun () -> - Lwt.wakeup wakeme ()) ; - process out >>= fun () -> - begin match Vmm_engine.setup_stats !state vm with - | Ok (state', out) -> - state := state' ; - process out (* TODO: need to read from stats socket! *) - | Error (`Msg e) -> - Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; - Lwt.return_unit - end - end - end else begin - Logs.err (fun m -> m "reading from console %lx, %a" hdr.Vmm_wire.tag Cstruct.hexdump_pp data) ; - Lwt.return_unit - end - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while reading from console" msg) ; - Lwt.return_unit - | Error _ -> - Logs.err (fun m -> m "error while reading from console") ; - Lwt.return_unit ) >>= fun () -> + ) >>= fun () -> Vmm_lwt.safe_close fd let init_sock sock = @@ -162,7 +177,6 @@ let jump _ = (create_mbox `Log >|= function | None -> invalid_arg "cannot connect to log socket" | Some l -> l) >>= fun (l, _l_fd) -> - let state = ref (Vmm_engine.init ()) in let out = function | `Stat data -> (match s with None -> Lwt.return_unit | Some (s, _s_fd) -> Lwt_mvar.put s data) | `Log data -> Lwt_mvar.put l data @@ -172,7 +186,7 @@ let jump _ = let rec loop () = Lwt_unix.accept ss >>= fun (fd, addr) -> Lwt_unix.set_close_on_exec fd ; - Lwt.async (fun () -> handle state out c_fd fd addr) ; + Lwt.async (fun () -> handle out c_fd fd addr) ; loop () in loop ()) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index d541d3b..46b623e 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -103,6 +103,38 @@ let strings_of_cstruct, strings_to_cstruct = let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string +let policy_obj = + let f (cpuids, vms, memory, block, bridges) = + let bridges = match bridges with + | xs -> + let add m v = + let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in + String.Map.add n v m + in + List.fold_left add String.Map.empty xs + and cpuids = IS.of_list cpuids + in + { vms ; cpuids ; memory ; block ; bridges } + and g policy = + (IS.elements policy.cpuids, policy.vms, policy.memory, policy.block, + snd @@ List.split @@ String.Map.bindings policy.bridges) + in + Asn.S.map f g @@ + Asn.S.(sequence5 + (required ~label:"cpuids" Asn.S.(sequence_of int)) + (required ~label:"vms" int) + (required ~label:"memory" int) + (optional ~label:"block" int) + (required ~label:"bridges" Asn.S.(sequence_of bridge))) + +let policy_of_cstruct, policy_to_cstruct = + let c = Asn.codec Asn.der policy_obj in + ((fun cs -> match Asn.decode c cs with + | Ok x -> Ok x + | Error (`Parse msg) -> Error (`Msg msg)), + Asn.encode c) + + let image = let f = function | `C1 x -> `Hvt_amd64, x diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 7a571b5..f44b3e1 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -139,6 +139,13 @@ val strings_to_cstruct : string list -> Cstruct.t encoded [buffer] or an error. *) val strings_of_cstruct : Cstruct.t -> (string list, [> `Msg of string ]) result +(** [policy_to_cstruct xs] is the DER encoded policy. *) +val policy_to_cstruct : Vmm_core.policy -> Cstruct.t + +(** [policy_of_cstruct buffer] is either a decoded policy of the DER + encoded [buffer] or an error. *) +val policy_of_cstruct : Cstruct.t -> (Vmm_core.policy * Cstruct.t, [> `Msg of string ]) result + (** {1 Decoding functions} *) (** [contains_vm cert] is [true] if the certificate contains a virtual machine image. *) @@ -153,7 +160,7 @@ val vm_of_cert : Vmm_core.id -> X509.t -> (Vmm_core.vm_config, [> `Msg of string (** [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. *) +(** [policy_of_cert version cert] is either the decoded policy, or an error. *) val policy_of_cert : version -> X509.t -> (Vmm_core.policy, [> `Msg of string ]) result (** [command_of_cert version cert] is either the decoded command, or an error. *) diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 9c470b2..ae04661 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -7,13 +7,15 @@ open Rresult.R.Infix let tmpdir = Fpath.(v "/var" / "run" / "albatross") let dbdir = Fpath.(v "/var" / "db" / "albatross") -let socket_path = - let path name = Fpath.(to_string (tmpdir / "util" / name + "sock")) in - function - | `Console -> path "console" - | `Vmmd -> Fpath.(to_string (tmpdir / "vmmd.sock")) - | `Stats -> path "stat" - | `Log -> path "log" +let socket_path t = + let path name = Fpath.(tmpdir / "util" / name + "sock") in + let path = match t with + | `Console -> path "console" + | `Vmmd -> Fpath.(tmpdir / "vmmd" + "sock") + | `Stats -> path "stat" + | `Log -> path "log" + in + Fpath.to_string path let pp_socket ppf t = let name = socket_path t in @@ -95,6 +97,10 @@ let drop_super ~super ~sub = let is_sub_id ~super ~sub = match drop_super ~super ~sub with None -> false | Some _ -> true +let domain id = match List.rev id with + | _::prefix -> List.rev prefix + | [] -> [] + let pp_id ppf ids = Fmt.(pf ppf "%a" (list ~sep:(unit ".") string) ids) @@ -185,6 +191,7 @@ let good_bridge idxs nets = List.for_all (fun n -> String.Map.mem n nets) idxs let vm_matches_res (res : policy) (vm : vm_config) = + (* TODO block device *) res.vms >= 1 && IS.mem vm.cpuid res.cpuids && vm.requested_memory <= res.memory && good_bridge vm.network res.bridges diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 7a4f0b9..cf52778 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -39,13 +39,15 @@ let log state (hdr, event) = Logs.debug (fun m -> m "LOG %a" Log.pp (hdr, event)) ; ({ state with log_counter }, `Log data) -let handle_create t hdr vm_config (* policies *) = - (if Vmm_resources.exists t.resources vm_config.vname then - Error (`Msg "VM with same name is already running") +let handle_create t hdr vm_config = + (match Vmm_resources.find_vm t.resources vm_config.vname with + | Some _ -> Error (`Msg "VM with same name is already running") + | None -> Ok ()) >>= fun () -> + Logs.debug (fun m -> m "now checking resource policies") ; + (if Vmm_resources.check_vm_policy t.resources vm_config then + Ok () else - Ok ()) >>= fun () -> - (* Logs.debug (fun m -> m "now checking dynamic policies") ; - Vmm_resources.check_dynamic t.resources vm_config policies >>= fun () -> *) + Error (`Msg "resource policies don't allow this")) >>= fun () -> (* prepare VM: save VM image to disk, create fifo, ... *) Vmm_unix.prepare vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; @@ -56,7 +58,7 @@ let handle_create t hdr vm_config (* policies *) = (* actually execute the vm *) Vmm_unix.exec vm_config taps >>= fun vm -> Logs.debug (fun m -> m "exec()ed vm") ; - Vmm_resources.insert t.resources vm_config.vname vm >>= fun resources -> + Vmm_resources.insert_vm t.resources vm >>= fun resources -> let tasks = String.Map.add (string_of_id vm_config.vname) task t.tasks in let used_bridges = List.fold_left2 (fun b br ta -> @@ -81,13 +83,7 @@ let handle_shutdown t vm r = (match Vmm_unix.shutdown vm with | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; - let resources = - match Vmm_resources.remove t.resources vm.config.vname vm with - | Ok resources -> resources - | Error (`Msg e) -> - Logs.warn (fun m -> m "%s while removing vm %a" e pp_vm vm) ; - t.resources - in + let resources = Vmm_resources.remove t.resources vm.config.vname in let used_bridges = List.fold_left2 (fun b br ta -> let old = match String.Map.find br b with @@ -118,25 +114,79 @@ let handle_command t hdr buf = Ok (t, [], `End) end else if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then Error (`Msg "unknown client version") - else Vmm_wire.decode_strings buf >>= fun (id, _off) -> + else Vmm_wire.decode_strings buf >>= fun (id, off) -> match Vmm_wire.Vm.int_to_op hdr.Vmm_wire.tag with | None -> Error (`Msg "unknown command") + | Some Vmm_wire.Vm.Remove_policy -> + Logs.debug (fun m -> m "remove policy %a" pp_id id) ; + let resources = Vmm_resources.remove t.resources id in + let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in + Ok ({ t with resources }, [ `Data success ], `End) + | Some Vmm_wire.Vm.Insert_policy -> + begin + Logs.debug (fun m -> m "insert policy %a" pp_id id) ; + Vmm_asn.policy_of_cstruct (Cstruct.shift buf off) >>= fun (policy, _) -> + Vmm_resources.insert_policy t.resources id policy >>= fun resources -> + let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in + Ok ({ t with resources }, [ `Data success ], `End) + end + | Some Vmm_wire.Vm.Policy -> + begin + Logs.debug (fun m -> m "policy %a" pp_id id) ; + let policies = + Vmm_resources.fold t.resources id + (fun _ policies -> policies) + (fun prefix policy policies-> (prefix, policy) :: policies) + [] + in + match policies with + | [] -> + Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ; + Error (`Msg "policy: not found") + | _ -> + let out = Vmm_wire.Vm.policy_reply hdr.Vmm_wire.id t.client_version policies in + Ok (t, [ `Data out ], `End) + end | Some Vmm_wire.Vm.Info -> - Logs.debug (fun m -> m "info %a" pp_id id) ; - begin match Vmm_resources.find t.resources id with - | None -> + begin + Logs.debug (fun m -> m "info %a" pp_id id) ; + let vms = + Vmm_resources.fold t.resources id + (fun vm vms -> vm :: vms) + (fun _ _ vms-> vms) + [] + in + match vms with + | [] -> Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ; Error (`Msg "info: not found") - | Some x -> - let data = - Vmm_resources.fold (fun acc vm -> vm :: acc) [] x - in - let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version data in + | _ -> + let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version vms in Ok (t, [ `Data out ], `End) end | Some Vmm_wire.Vm.Create -> Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config -> handle_create t hdr vm_config + | Some Vmm_wire.Vm.Force_create -> + Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config -> + let resources = Vmm_resources.remove t.resources vm_config.vname in + if Vmm_resources.check_vm_policy resources vm_config then + begin match Vmm_resources.find_vm t.resources id with + | None -> handle_create t hdr vm_config + | Some vm -> + Vmm_unix.destroy vm ; + let id_str = string_of_id id in + match String.Map.find_opt id_str t.tasks with + | None -> handle_create t hdr vm_config + | Some task -> + let tasks = String.Map.remove id_str t.tasks in + let t = { t with tasks } in + Ok (t, [], `Wait_and_create + (t, task, fun t -> + msg_to_err @@ handle_create t hdr vm_config)) + end + else + Error (`Msg "wouldn't match policy") | Some Vmm_wire.Vm.Destroy -> match Vmm_resources.find_vm t.resources id with | Some vm -> diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index e5e84d7..a3be201 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -1,8 +1,5 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) -open Astring -open Rresult.R.Infix - open Vmm_core type res_entry = { @@ -10,118 +7,93 @@ type res_entry = { used_memory : int ; } -let pp_res_entry ppf res = - Fmt.pf ppf "%d vms %d memory" res.running_vms res.used_memory - let empty_res = { running_vms = 0 ; used_memory = 0 } let check_resource (policy : policy) (vm : vm_config) (res : res_entry) = - succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory + succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory && + vm_matches_res policy vm + +let check_resource_policy (policy : policy) (res : res_entry) = + res.running_vms <= policy.vms && res.used_memory <= policy.memory let add (vm : vm) (res : res_entry) = { running_vms = succ res.running_vms ; used_memory = vm.config.requested_memory + res.used_memory } -let rem (vm : vm) (res : res_entry) = - { running_vms = pred res.running_vms ; - used_memory = res.used_memory - vm.config.requested_memory } - type entry = - | Leaf of vm - | Subtree of res_entry * entry String.Map.t + | Vm of vm + | Policy of policy -type t = entry String.Map.t +type t = entry Vmm_trie.t -let empty = String.Map.empty +let empty = Vmm_trie.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 remove t name = Vmm_trie.remove name t -let rec pp_entry ppf = function - | Leaf vm -> pp_vm ppf vm - | Subtree (res, m) -> - Fmt.pf ppf "%a %a" - pp_res_entry res - Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry)) - (String.Map.bindings m) +let fold t name f g acc = + Vmm_trie.fold name t (fun prefix entry acc -> + match entry with + | Vm vm -> f vm acc + | Policy p -> g prefix p acc) acc -let pp ppf map = - Fmt.pf ppf "%a" - Fmt.(list ~sep:(unit "@ ") (pair ~sep:(unit " -> ") string pp_entry)) - (String.Map.bindings map) +(* we should hide this type and confirm the following invariant: + - in case Vm, there are no siblings *) -let find t name = - let rec find r m = function - | [] -> Some (Subtree (r, m)) - | x::xs -> match String.Map.find x m with - | None -> None - | Some (Subtree (r, m)) -> find r m xs - | Some (Leaf vm) -> Some (Leaf vm) - in - find empty_res t name +let resource_usage t name = + Vmm_trie.fold name t (fun _ entry acc -> + match entry with + | Policy _ -> acc + | Vm vm -> add vm acc) + empty_res -let exists t name = match find t name with None -> false | Some _ -> true - -let find_vm t name = match find t name with - | Some (Leaf vm) -> Some vm +let find_vm t name = match Vmm_trie.find name t with + | Some (Vm vm) -> Some vm | _ -> None -let rec iter f = function - | Leaf vm -> f vm - | Subtree (_, m) -> List.iter (fun (_, e) -> iter f e) (String.Map.bindings m) +let check_vm_policy t vm = + let dom = domain vm.vname in + let res = resource_usage t dom in + match Vmm_trie.find dom t with + | None -> true + | Some (Vm _) -> assert false + | Some (Policy p) -> check_resource p vm res -let 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_vm t vm = + if check_vm_policy t vm.config then + match Vmm_trie.insert vm.config.vname (Vm vm) t with + | t', None -> Ok t' + | _, Some _ -> Error (`Msg "vm already exists") + else + Error (`Msg "resource policy mismatch") -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 check_policy_above t name p = + let above = Vmm_trie.collect name t in + List.for_all (fun (_, node) -> match node with + | Vm _ -> assert false + | Policy p' -> is_sub ~super:p' ~sub:p) + above -let remove m name vm = - let rec del m = function - | [] -> Error (`Msg "should not happen: empty labels in remove") - | [l] -> Ok (String.Map.remove l m) - | l::ls -> match String.Map.find l m with - | None -> Error (`Msg "should not happen: found nothing in remove while still had some labels") - | Some (Subtree (r, m')) -> - del m' ls >>= fun m' -> - if String.Map.is_empty m' then - Ok (String.Map.remove l m) - else - let res = rem vm r in - Ok (String.Map.add l (Subtree (res, m')) m) - | Some (Leaf _) -> Error (`Msg "should not happen: found a leaf, but had some labels") - in - del m name +let check_policy_below t name p = + Vmm_trie.fold name t (fun name entry res -> + match name with + | [] -> res + | _ -> + match res, entry with + | Ok p, Policy p' -> if is_sub ~super:p ~sub:p then Ok p' else Error () + | Ok p, Vm vm -> + (* TODO block device *) + if IS.mem vm.config.cpuid p.cpuids && good_bridge vm.config.network p.bridges then Ok p else Error () + | res, _ -> res) + (Ok p) + +let insert_policy t name p = + let dom = domain name in + match + check_policy_above t dom p, + check_policy_below t name p, + check_resource_policy p (resource_usage t dom) + with + | true, Ok _, true -> Ok (fst (Vmm_trie.insert name (Policy p) t)) + | false, _, _ -> Error (`Msg "policy violates other policies above") + | _, Error (), _ -> Error (`Msg "policy violates other policies below") + | _, _, false -> Error (`Msg "more resources used than policy would allow") diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index 08a12ca..9878c65 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -1,6 +1,6 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) -(** A tree data structure tracking dynamic resource usage. +(** A tree data structure including policies and dynamic usage. Considering delegation of resources to someone, and further delegation to others - using a process which is not controlled by the authority - @@ -14,43 +14,27 @@ (** 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.policy) 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 +(** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be + allowed under the current policies. *) +val check_vm_policy : t -> Vmm_core.vm_config -> bool -(** [fold f entry acc] folds [f] over [entry]. *) -val fold : ('a -> Vmm_core.vm -> 'a) -> 'a -> entry -> 'a +(** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or + an error. *) +val insert_vm : t -> Vmm_core.vm -> (t, [> `Msg of string]) result -(** [insert t id vm] inserts [vm] under [id] in [t], and returns the new [t] or - an error. It also updates the resource usages on the path. *) -val insert : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result +(** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns + the new [t] or an error. *) +val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result -(** [remove 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 +(** [remove t id] removes [id] from [t]. *) +val remove : t -> Vmm_core.id -> t + +(** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *) +val fold : t -> Vmm_core.id -> (Vmm_core.vm -> 'a -> 'a) -> + (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a diff --git a/src/vmm_trie.ml b/src/vmm_trie.ml index dc85b0a..ae1559b 100644 --- a/src/vmm_trie.ml +++ b/src/vmm_trie.ml @@ -77,3 +77,21 @@ let all t = acc' (String.Map.bindings m) in go [] [] t + +let fold id t f acc = + let rec explore (N (es, m)) prefix acc = + let acc' = + String.Map.fold (fun name node acc -> explore node (prefix@[name]) acc) + m acc + in + match es with + | None -> acc' + | Some e -> f prefix e acc' + and down prefix (N (es, m)) = + match prefix with + | [] -> explore (N (es, m)) [] acc + | x :: xs -> match String.Map.find_opt x m with + | None -> acc + | Some n -> down xs n + in + down id t diff --git a/src/vmm_trie.mli b/src/vmm_trie.mli index 5e2bca2..2564df1 100644 --- a/src/vmm_trie.mli +++ b/src/vmm_trie.mli @@ -13,3 +13,5 @@ val find : id -> 'a t -> 'a option val collect : id -> 'a t -> (id * 'a) list val all : 'a t -> (id * 'a) list + +val fold : id -> 'a t -> (id -> 'a -> 'b -> 'b) -> 'b -> 'b diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index e8356b5..47f81c8 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -546,19 +546,40 @@ module Vm = struct | Create | Destroy | Info - (* | Add_policy *) + | Policy + | Insert_policy + | Remove_policy + | Force_create let op_to_int = function | Create -> 0x0400l | Destroy -> 0x0401l | Info -> 0x0402l + | Policy -> 0x0403l + | Insert_policy -> 0x0404l + | Remove_policy -> 0x0405l + | Force_create -> 0x0406l let int_to_op = function | 0x0400l -> Some Create | 0x0401l -> Some Destroy | 0x0402l -> Some Info + | 0x0403l -> Some Policy + | 0x0404l -> Some Insert_policy + | 0x0405l -> Some Remove_policy + | 0x0406l -> Some Force_create | _ -> None + let policy id version name = + encode ~name version id (op_to_int Policy) + + let insert_policy id version name policy = + let body = Vmm_asn.policy_to_cstruct policy in + encode ~name ~body version id (op_to_int Insert_policy) + + let remove_policy id version name = + encode ~name version id (op_to_int Remove_policy) + let info id version name = encode ~name version id (op_to_int Info) @@ -575,6 +596,25 @@ module Vm = struct let body = encode_list encode_vm vms in reply ~body version id (op_to_int Info) + let policy_reply id version policies = + let body = encode_list + (fun (prefix, policy) -> + let name_cs = encode_strings prefix + and pol_cs = Vmm_asn.policy_to_cstruct policy in + Cstruct.append name_cs pol_cs) + policies + in + reply ~body version id (op_to_int Policy) + + let decode_policies buf = + decode_list (fun cs -> + decode_strings cs >>= fun (id, l) -> + cs_shift cs l >>= fun cs' -> + Vmm_asn.policy_of_cstruct cs' >>= fun (policy, cs'') -> + let off = Cstruct.len cs - Cstruct.len cs'' in + Ok ((id, policy), off)) + buf + let decode_vm cs = decode_strings cs >>= fun (id, l) -> cs_shift cs l >>= fun cs' -> @@ -632,124 +672,10 @@ module Vm = struct let body = encode_vm_config vm in encode ~name:vm.vname ~body version id (op_to_int Create) + let force_create id version vm = + let body = encode_vm_config vm in + encode ~name:vm.vname ~body version id (op_to_int Force_create) + let destroy id version name = encode ~name version id (op_to_int Destroy) end - -(* -module Client = struct - let cmd_to_int = function - | Info -> 0x0500l - | Destroy_vm -> 0x0501l - | Create_block -> 0x0502l - | Destroy_block -> 0x0503l - | Statistics -> 0x0504l - | Attach -> 0x0505l - | Detach -> 0x0506l - | Log -> 0x0507l - and cmd_of_int = function - | 0x0500l -> Some Info - | 0x0501l -> Some Destroy_vm - | 0x0502l -> Some Create_block - | 0x0503l -> Some Destroy_block - | 0x0504l -> Some Statistics - | 0x0505l -> Some Attach - | 0x0506l -> Some Detach - | 0x0507l -> Some Log - | _ -> None - - let cmd ?arg it id version = - let pay, length = may_enc_str arg - and tag = cmd_to_int it - in - let length = Int32.of_int length 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 = cs_len payload in - let r = - Cstruct.append - (create_header { length ; id = 0L ; version ; tag = Log.(op_to_int Data) }) - payload - in - Cstruct.to_string r - - let stat data id version = - let length = Int32.of_int (String.length data) in - let hdr = create_header { length ; id ; version ; tag = Stats.(op_to_int Stat_reply) } 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 length = Int32.of_int length in - let hdr = - create_header { length ; id = 0L ; version ; tag = Console.(op_to_int Data) } - 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_int 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 length = Int32.of_int length in - let hdr = create_header { length ; id ; version ; tag = success_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_int (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 - *) From efc043cd5cf4e92dbed65bfc99abc32c0c4b9b1f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 13 Oct 2018 01:25:18 +0200 Subject: [PATCH 23/73] fix 'vmmc info' --- src/vmm_wire.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 47f81c8..9153fbc 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -625,7 +625,7 @@ module Vm = struct decode_int cs''' >>= fun pid -> cs_shift cs''' 8 >>= fun cs'''' -> decode_strings cs'''' >>= fun (taps, l'') -> - Ok ((id, memory, cmd, pid, taps), l + 8 + l' + l'') + Ok ((id, memory, cmd, pid, taps), l + 8 + l' + 8 + l'') let decode_vms buf = decode_list decode_vm buf From bcb280aa002fa559d2d9bd23b3cac1681986c855 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 14 Oct 2018 01:02:52 +0200 Subject: [PATCH 24/73] refactor commands into vmm_commands --- _tags | 2 +- app/vmm_tls_endpoint.ml | 117 ++++-------- app/vmmc.ml | 395 +++++++++++++--------------------------- pkg/pkg.ml | 2 +- src/vmm_commands.ml | 282 +++++++--------------------- src/vmm_core.ml | 4 +- src/vmm_x509.ml | 72 +++++--- 7 files changed, 274 insertions(+), 600 deletions(-) diff --git a/_tags b/_tags index fe13147..45dcadd 100644 --- a/_tags +++ b/_tags @@ -10,7 +10,7 @@ true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring : package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress) : package(nocrypto tls.lwt nocrypto.lwt) -: package(tls.lwt) +: package(tls.lwt) : package(nocrypto tls.lwt nocrypto.lwt) : package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt decompress) diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index af82442..909c27a 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -2,24 +2,42 @@ open Lwt.Infix -let write_tls state t data = - Vmm_tls.write_tls (fst t) data >>= function - | Ok () -> Lwt.return_unit - | Error `Exception -> - let state', out = Vmm_engine.handle_disconnect !state t in - state := state' ; - Lwt_list.iter_s (fun (s, data) -> write_raw s data) out >>= fun () -> - Tls_lwt.Unix.close (fst t) - -let 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 +let pp_sockaddr ppf = function | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d" (Unix.string_of_inet_addr addr) port +let connect socket_path = + let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.set_close_on_exec c ; + Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> + c + +let client_auth ca tls addr = + Logs.debug (fun m -> m "connection from %a" pp_sockaddr addr) ; + let authenticator = + let time = Ptime_clock.now () in + X509.Authenticator.chain_of_trust ~time (* ~crls:!state.Vmm_engine.crls *) [ca] + in + Lwt.catch + (fun () -> Tls_lwt.Unix.reneg ~authenticator tls) + (fun e -> + (match e with + | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a)) + | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f)) + | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ; + Tls_lwt.Unix.close tls >>= fun () -> + Lwt.fail e) >>= fun () -> + (match Tls_lwt.Unix.epoch tls with + | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain + | `Error -> + Tls_lwt.Unix.close tls >>= fun () -> + Lwt.fail_with "error while getting epoch") + +let handle ca (tls, addr) = + client_auth ca tls addr >>= fun chain -> + let _ = Vmm_x509.handle_initial tls addr chain ca in + Lwt.return_unit let server_socket port = let open Lwt_unix in @@ -30,69 +48,10 @@ let server_socket port = listen s 10 ; Lwt.return s -let rec read_log state s = - Vmm_lwt.read_exactly s >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "reading log error %s" msg) ; - read_log state s - | Error _ -> - Logs.err (fun m -> m "exception while reading log") ; - invalid_arg "log socket communication issue" - | Ok (hdr, data) -> - let state', outs = Vmm_engine.handle_log !state hdr data in - state := state' ; - process state outs >>= fun () -> - read_log state s - -let rec read_cons state s = - Vmm_lwt.read_exactly s >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "reading console error %s" msg) ; - read_cons state s - | Error _ -> - Logs.err (fun m -> m "exception while reading console socket") ; - invalid_arg "console socket communication issue" - | Ok (hdr, data) -> - let state', outs = Vmm_engine.handle_cons !state hdr data in - state := state' ; - process state outs >>= fun () -> - read_cons state s - -let rec read_stats state s = - Vmm_lwt.read_exactly s >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "reading stats error %s" msg) ; - read_stats state s - | Error _ -> - Logs.err (fun m -> m "exception while reading stats") ; - Lwt.catch (fun () -> Lwt_unix.close s) (fun _ -> Lwt.return_unit) >|= fun () -> - invalid_arg "stat socket communication issue" - | Ok (hdr, data) -> - let state', outs = Vmm_engine.handle_stat !state hdr data in - state := state' ; - process state outs >>= fun () -> - read_stats state s - -let cmp_s (_, a) (_, b) = - let open Lwt_unix in - match a, b with - | ADDR_UNIX str, ADDR_UNIX str' -> String.compare str str' = 0 - | ADDR_INET (addr, port), ADDR_INET (addr', port') -> - port = port' && - String.compare (Unix.string_of_inet_addr addr) (Unix.string_of_inet_addr addr') = 0 - | _ -> false - let jump _ cacert cert priv_key port = Sys.(set_signal sigpipe Signal_ignore) ; Lwt_main.run (Nocrypto_entropy_lwt.initialize () >>= fun () -> - (init_sock Vmm_core.tmpdir "cons" >|= function - | None -> invalid_arg "cannot connect to console socket" - | Some c -> c) >>= fun c -> - init_sock Vmm_core.tmpdir "stat" >>= fun s -> - (init_sock Vmm_core.tmpdir "log" >|= function - | None -> invalid_arg "cannot connect to log socket" - | Some l -> l) >>= fun l -> server_socket port >>= fun socket -> X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert -> X509_lwt.certs_of_pem cacert >>= (function @@ -102,16 +61,6 @@ let jump _ cacert cert priv_key port = Tls.(Config.server ~version:(Core.TLS_1_2, Core.TLS_1_2) ~reneg:true ~certificates:(`Single cert) ()) in - (match Vmm_engine.init cmp_s c s l with - | Ok s -> Lwt.return s - | Error (`Msg m) -> Lwt.fail_with m) >>= fun t -> - let state = ref t in - Lwt.async (fun () -> read_cons state c) ; - (match s with - | None -> () - | Some s -> Lwt.async (fun () -> read_stats state s)) ; - Lwt.async (fun () -> read_log state l) ; - Lwt.async stats_loop ; let rec loop () = Lwt.catch (fun () -> Lwt_unix.accept socket >>= fun (fd, addr) -> @@ -123,7 +72,7 @@ let jump _ cacert cert priv_key port = Lwt.fail exn) >>= fun t -> Lwt.async (fun () -> Lwt.catch - (fun () -> handle ca state t) + (fun () -> handle ca t) (fun e -> Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ; diff --git a/app/vmmc.ml b/app/vmmc.ml index 2452939..45bd79f 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -6,31 +6,11 @@ open Astring open Vmm_core -let my_version = `WV2 -let my_command = 1L - let process fd = Vmm_lwt.read_wire fd >|= function - | Error _ -> Error () - | Ok (hdr, data) -> - if not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) then begin - Logs.err (fun m -> m "unknown wire protocol version") ; - Error () - end else begin - if Vmm_wire.is_fail hdr then begin - let msg = match Vmm_wire.decode_string data with - | Ok (msg, _) -> Some msg - | Error _ -> None - in - Logs.err (fun m -> m "command failed %a" Fmt.(option ~none:(unit "") string) msg) ; - Error () - end else if Vmm_wire.is_reply hdr && hdr.Vmm_wire.id = my_command then - Ok data - else begin - Logs.err (fun m -> m "received unexpected data") ; - Error () - end - end + | Error (`Msg m) -> Error (`Msg m) + | Error _ -> Error (`Msg "read error") + | Ok data -> Vmm_commands.handle_reply data let socket t = function | Some x -> x @@ -42,97 +22,94 @@ let connect socket_path = Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> c +let read fd f = + (* now we busy read and process output *) + let rec loop () = + Vmm_lwt.read_wire fd >>= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () + | Error _ -> Lwt.return (Error (`Msg "exception while reading")) + | Ok (hdr, data) -> + Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ; + if Vmm_wire.is_fail hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> "" + | Ok (m, _) -> m + in + Lwt.return (Error (`Msg ("operation failed " ^ msg))) + else if Vmm_wire.is_reply hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; + loop () + else + match f (hdr, data) with + | Ok () -> loop () + | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) + in + loop () + +let handle opt_socket (cmd : Vmm_commands.t) f = + let sock, next, cmd = Vmm_commands.handle cmd in + connect (socket sock opt_socket) >>= fun fd -> + Vmm_lwt.write_wire fd cmd >>= function + | Error `Exception -> Lwt.return (Error (`Msg "couldn't write")) + | Ok () -> + (match next with + | `Read -> read fd f + | `End -> + process fd >|= function + | Error e -> Error e + | Ok data -> f data) >>= fun res -> + Vmm_lwt.safe_close fd >|= fun () -> + res + +let jump opt_socket cmd f = + match + Lwt_main.run (handle opt_socket cmd f) + with + | Ok () -> `Ok () + | Error (`Msg m) -> `Error (false, m) + let info_ _ opt_socket name = - Lwt_main.run ( - connect (socket `Vmmd opt_socket) >>= fun fd -> - let info = Vmm_wire.Vm.info my_command my_version name in - (Vmm_lwt.write_wire fd info >>= function - | Ok () -> - (process fd >|= function - | Error () -> () - | Ok data -> - match Vmm_wire.Vm.decode_vms data with - | Ok (vms, _) -> - List.iter (fun (id, memory, cmd, pid, taps) -> - Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a" - pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) - vms - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while decoding vms" msg)) - | Error `Exception -> Lwt.return_unit) >>= fun () -> - Vmm_lwt.safe_close fd - ) ; - `Ok () + jump opt_socket (`Info name) (fun (_, data) -> + let open Rresult.R.Infix in + Vmm_wire.Vm.decode_vms data >>| fun (vms, _) -> + List.iter (fun (id, memory, cmd, pid, taps) -> + Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a" + pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) + vms) let policy _ opt_socket name = - Lwt_main.run ( - connect (socket `Vmmd opt_socket) >>= fun fd -> - let policy = Vmm_wire.Vm.policy my_command my_version name in - (Vmm_lwt.write_wire fd policy >>= function - | Ok () -> - (process fd >|= function - | Error () -> () - | Ok data -> - match Vmm_wire.Vm.decode_policies data with - | Ok (policies, _) -> - List.iter (fun (id, policy) -> - Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy)) - policies - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while decoding policies" msg)) - | Error `Exception -> Lwt.return_unit) >>= fun () -> - Vmm_lwt.safe_close fd - ) ; - `Ok () + jump opt_socket (`Policy name) (fun (_, data) -> + let open Rresult.R.Infix in + Vmm_wire.Vm.decode_policies data >>| fun (policies, _) -> + List.iter (fun (id, policy) -> + Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy)) + policies) let remove_policy _ opt_socket name = - Lwt_main.run ( - connect (socket `Vmmd opt_socket) >>= fun fd -> - let cmd = Vmm_wire.Vm.remove_policy my_command my_version name in - (Vmm_lwt.write_wire fd cmd >>= function - | Ok () -> - (process fd >|= function - | Error () -> () - | Ok _ -> Logs.app (fun m -> m "removed policy")) - | Error `Exception -> Lwt.return_unit) >>= fun () -> - Vmm_lwt.safe_close fd) ; - `Ok () + jump opt_socket (`Remove_policy name) (fun _ -> + Ok (Logs.app (fun m -> m "removed policy"))) let add_policy _ opt_socket name vms memory cpus block bridges = - Lwt_main.run ( - connect (socket `Vmmd opt_socket) >>= fun fd -> - let bridges = match bridges with - | xs -> - let add m v = - let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in - String.Map.add n v m - in - List.fold_left add String.Map.empty xs - and cpuids = IS.of_list cpus - in - let policy = { vms ; cpuids ; memory ; block ; bridges } in - let cmd = Vmm_wire.Vm.insert_policy my_command my_version name policy in - (Vmm_lwt.write_wire fd cmd >>= function - | Ok () -> - (process fd >|= function - | Error () -> () - | Ok _ -> Logs.app (fun m -> m "added policy")) - | Error `Exception -> Lwt.return_unit) >>= fun () -> - Vmm_lwt.safe_close fd) ; - `Ok () + let bridges = match bridges with + | xs -> + let add m v = + let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in + String.Map.add n v m + in + List.fold_left add String.Map.empty xs + and cpuids = IS.of_list cpus + in + let policy = { vms ; cpuids ; memory ; block ; bridges } in + jump opt_socket (`Add_policy (name, policy)) (fun _ -> + Ok (Logs.app (fun m -> m "added policy"))) let destroy _ opt_socket name = - Lwt_main.run ( - connect (socket `Vmmd opt_socket) >>= fun fd -> - let cmd = Vmm_wire.Vm.destroy my_command my_version name in - (Vmm_lwt.write_wire fd cmd >>= function - | Ok () -> - (process fd >|= function - | Error () -> () - | Ok _ -> Logs.app (fun m -> m "destroyed VM")) - | Error `Exception -> Lwt.return_unit) >>= fun () -> - Vmm_lwt.safe_close fd) ; - `Ok () + jump opt_socket (`Destroy_vm name) (fun _ -> + Ok (Logs.app (fun m -> m "destroyed VM"))) let create _ opt_socket force name image cpuid requested_memory boot_params block_device network = let image' = match Bos.OS.File.read (Fpath.v image) with @@ -149,177 +126,51 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc vname = name ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in - Lwt_main.run ( - connect (socket `Vmmd opt_socket) >>= fun fd -> - let vm = - if force then - Vmm_wire.Vm.force_create my_command my_version vm_config - else - Vmm_wire.Vm.create my_command my_version vm_config - in - (Vmm_lwt.write_wire fd vm >>= function - | Error `Exception -> Lwt.return_unit - | Ok () -> process fd >|= function - | Ok _ -> Logs.app (fun m -> m "successfully started VM") - | Error () -> ()) >>= fun () -> - Vmm_lwt.safe_close fd ) ; - `Ok () + let cmd = + if force then + `Force_create_vm vm_config + else + `Create_vm vm_config + in + let succ _ = Ok (Logs.app (fun m -> m "successfully started VM")) in + jump opt_socket cmd succ let console _ opt_socket name = - Lwt_main.run ( - connect (socket `Console opt_socket) >>= fun fd -> - let cmd = Vmm_wire.Console.attach my_command my_version name in - (Vmm_lwt.write_wire fd cmd >>= function - | Error `Exception -> - Logs.err (fun m -> m "couldn't write to socket") ; - Lwt.return_unit - | Ok () -> - (* now we busy read and process console output *) - let rec loop () = - Vmm_lwt.read_wire fd >>= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () - | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (hdr, data) -> - Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ; - if Vmm_wire.is_fail hdr then - let msg = match Vmm_wire.decode_string data with - | Error _ -> None - | Ok (m, _) -> Some m - in - Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ; - Lwt.return_unit - else if Vmm_wire.is_reply hdr then - let msg = match Vmm_wire.decode_string data with - | Error _ -> None - | Ok (m, _) -> Some m - in - Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; - loop () - else - let r = - let open Rresult.R.Infix in - match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with - | Some Vmm_wire.Console.Data -> - Vmm_wire.decode_id_ts data >>= fun ((name, ts), off) -> - Vmm_wire.decode_string (Cstruct.shift data off) >>= fun (msg, _) -> - Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts Vmm_core.pp_id name msg) ; - Ok () - | _ -> - Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)) - in - match r with - | Ok () -> loop () - | Error (`Msg msg) -> - Logs.err (fun m -> m "%s" msg) ; - Lwt.return_unit - in - loop ()) >>= fun () -> - Vmm_lwt.safe_close fd) ; - `Ok () + jump opt_socket (`Console name) (fun (hdr, data) -> + let open Rresult.R.Infix in + match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with + | Some Vmm_wire.Console.Data -> + Vmm_wire.decode_id_ts data >>= fun ((name, ts), off) -> + Vmm_wire.decode_string (Cstruct.shift data off) >>= fun (msg, _) -> + Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts Vmm_core.pp_id name msg) ; + Ok () + | _ -> + Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag))) -let stats _ opt_socket vm = - Lwt_main.run ( - connect (socket `Stats opt_socket) >>= fun fd -> - let cmd = Vmm_wire.Stats.subscribe my_command my_version vm in - (Vmm_lwt.write_wire fd cmd >>= function - | Error `Exception -> Lwt.fail_with "write error" - | Ok () -> Lwt.return_unit) >>= fun () -> - (* now we busy read and process stat output *) - let rec loop () = - Vmm_lwt.read_wire fd >>= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () - | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (hdr, data) -> - if Vmm_wire.is_fail hdr then - let msg = match Vmm_wire.decode_string data with - | Error _ -> None - | Ok (m, _) -> Some m - in - Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ; - Lwt.return_unit - else if Vmm_wire.is_reply hdr then - let msg = match Vmm_wire.decode_string data with - | Error _ -> None - | Ok (m, _) -> Some m - in - Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; - loop () - else - let r = - let open Rresult.R.Infix in - match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with - | Some Vmm_wire.Stats.Data -> - Vmm_wire.decode_strings data >>= fun (id, off) -> - Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun stats -> - (Astring.String.concat ~sep:"." id, stats) - | _ -> - Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag)) - in - match r with - | Ok (name, (ru, vmm, ifs)) -> - Logs.app (fun m -> m "stats %s@.%a@.%a@.%a@." - name Vmm_core.pp_rusage ru - Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm - Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ; - loop () - | Error (`Msg msg) -> - Logs.err (fun m -> m "%s" msg) ; - Lwt.return_unit - in - loop () >>= fun () -> - Vmm_lwt.safe_close fd) ; - `Ok () +let stats _ opt_socket name = + jump opt_socket (`Statistics name) (fun (hdr, data) -> + let open Rresult.R.Infix in + match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with + | Some Vmm_wire.Stats.Data -> + Vmm_wire.decode_strings data >>= fun (name', off) -> + Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun (ru, vmm, ifs) -> + Logs.app (fun m -> m "stats %a@.%a@.%a@.%a@." + pp_id name' Vmm_core.pp_rusage ru + Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm + Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ; + | _ -> + Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag))) -let event_log _ opt_socket vm = - Lwt_main.run ( - connect (socket `Log opt_socket) >>= fun fd -> - let cmd = Vmm_wire.Log.subscribe my_command my_version vm in - (Vmm_lwt.write_wire fd cmd >>= function - | Error `Exception -> Lwt.fail_with "write error" - | Ok () -> Lwt.return_unit) >>= fun () -> - (* now we busy read and process stat output *) - let rec loop () = - Vmm_lwt.read_wire fd >>= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () - | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (hdr, data) -> - if Vmm_wire.is_fail hdr then - let msg = match Vmm_wire.decode_string data with - | Error _ -> None - | Ok (m, _) -> Some m - in - Logs.err (fun m -> m "operation failed: %a" Fmt.(option ~none:(unit "") string) msg) ; - Lwt.return_unit - else if Vmm_wire.is_reply hdr then - let msg = match Vmm_wire.decode_string data with - | Error _ -> None - | Ok (m, _) -> Some m - in - Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; - loop () - else - begin - (match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with - | Some Vmm_wire.Log.Broadcast -> - begin match Vmm_wire.Log.decode_log_hdr data with - | Error (`Msg err) -> - Logs.warn (fun m -> m "ignoring error %s while decoding log" err) ; - | Ok (loghdr, logdata) -> - match Vmm_wire.Log.decode_event logdata with - | Error (`Msg err) -> - Logs.warn (fun m -> m "loghdr %a ignoring error %s while decoding logdata" - Vmm_core.Log.pp_hdr loghdr err) - | Ok event -> - Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event)) - end - | _ -> - Logs.warn (fun m -> m "unknown operation %lx" hdr.Vmm_wire.tag)) ; - loop () - end - in - loop () >>= fun () -> - Vmm_lwt.safe_close fd) ; - `Ok () +let event_log _ opt_socket name = + jump opt_socket (`Log name) (fun (hdr, data) -> + let open Rresult.R.Infix in + match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with + | Some Vmm_wire.Log.Broadcast -> + Vmm_wire.Log.decode_log_hdr data >>= fun (loghdr, logdata) -> + Vmm_wire.Log.decode_event logdata >>| fun event -> + Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event)) + | _ -> + Ok (Logs.warn (fun m -> m "unknown operation %lx" hdr.Vmm_wire.tag))) let help _ _ man_format cmds = function | None -> `Help (`Pager, None) diff --git a/pkg/pkg.ml b/pkg/pkg.ml index c97fff5..a8823a6 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -10,7 +10,7 @@ let () = Pkg.bin "app/vmm_console" ; Pkg.bin "app/vmm_log" ; (* Pkg.bin "app/vmm_client" ; *) - (* Pkg.bin "app/vmm_tls_endpoint" ; *) + Pkg.bin "app/vmm_tls_endpoint" ; Pkg.bin "app/vmmc" ; Pkg.bin "provision/vmm_req_command" ; Pkg.bin "provision/vmm_req_delegation" ; diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index e4bf64b..fb8f7f3 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -1,223 +1,71 @@ -(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) - -open Astring +(* (c) 2018 Hannes Mehnert, all rights reserved *) open Vmm_core -open Rresult -open R.Infix +let c = 0L +let ver = `WV2 -let handle_command t s prefix perms hdr buf = - let res = - if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then - Error (`Msg "unknown client version") - else match Vmm_wire.Client.cmd_of_int hdr.Vmm_wire.tag with - | None -> Error (`Msg "unknown command") - | Some x when cmd_allowed perms x -> - begin - Vmm_wire.decode_str buf >>= fun (buf, _l) -> - let arg = if String.length buf = 0 then prefix else prefix @ [buf] in - let vmid = string_of_id arg in - match x with - | Info -> - begin match Vmm_resources.find t.resources arg with - | None -> - Logs.debug (fun m -> m "info: couldn't find %a" pp_id arg) ; - R.error_msgf "info: %s not found" buf - | Some x -> - let data = - Vmm_resources.fold (fun acc vm -> - acc ^ Vmm_wire.Client.encode_vm vm.config.vname vm) - "" x - in - let out = Vmm_wire.Client.info data hdr.Vmm_wire.id t.client_version in - Ok (t, [ `Tls (s, out) ]) - end - | Destroy_vm -> - begin match Vmm_resources.find_vm t.resources arg with - | Some vm -> - Vmm_unix.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 on_success t = - let cons = Vmm_wire.Console.history t.console_counter t.console_version vmid Ptime.epoch in - let old = match String.Map.find vmid t.console_attached with - | None -> [] - | Some s -> - let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in - [ `Tls (s, out) ] - in - let console_attached = String.Map.add vmid s t.console_attached in - { t with console_counter = succ t.console_counter ; console_attached }, - `Raw (t.console_socket, cons) :: old - in - let cons = Vmm_wire.Console.attach t.console_counter t.console_version vmid in - let console_requests = IM.add t.console_counter on_success t.console_requests in - Ok ({ t with console_counter = succ t.console_counter ; console_requests }, - [ `Raw (t.console_socket, cons) ]) - | Detach -> - let cons = Vmm_wire.Console.detach t.console_counter t.console_version vmid in - (match String.Map.find vmid t.console_attached with - | None -> Error (`Msg "not attached") - | Some x when t.cmp x s -> Ok (String.Map.remove vmid t.console_attached) - | Some _ -> Error (`Msg "this socket is not attached")) >>= fun console_attached -> - let out = Vmm_wire.success hdr.Vmm_wire.id t.client_version in - Ok ({ t with console_counter = succ t.console_counter ; console_attached }, - [ `Raw (t.console_socket, cons) ; `Tls (s, out) ]) - | Statistics -> - begin match t.stats_socket with - | None -> Error (`Msg "no statistics available") - | Some _ -> match Vmm_resources.find_vm t.resources arg with - | Some vm -> - let stat_out = Vmm_wire.Stats.stat t.stats_counter t.stats_version vmid in - let d = (s, hdr.Vmm_wire.id, translate_tap vm) in - let stats_requests = IM.add t.stats_counter d t.stats_requests in - Ok ({ t with stats_counter = succ t.stats_counter ; stats_requests }, - stat t stat_out) - | _ -> Error (`Msg ("statistics: not found " ^ buf)) - end - | Log -> - begin - let log_out = Vmm_wire.Log.history t.log_counter t.log_version (string_of_id prefix) Ptime.epoch in - let log_requests = IM.add t.log_counter (s, hdr.Vmm_wire.id) t.log_requests in - let log_counter = succ t.log_counter in - Ok ({ t with log_counter ; log_requests }, [ `Raw (t.log_socket, log_out) ]) - end - | Create_block | Destroy_block -> Error (`Msg "NYI") - end - | Some _ -> Error (`Msg "unauthorised command") - in - match res with - | Ok r -> r - | Error (`Msg msg) -> - Logs.debug (fun m -> m "error while processing command: %s" msg) ; - let out = Vmm_wire.fail ~msg hdr.Vmm_wire.id t.client_version in - (t, [ `Tls (s, out) ]) +type t = [ + | `Info of id + | `Policy of id + | `Add_policy of id * policy + | `Remove_policy of id + | `Create_vm of vm_config + | `Force_create_vm of vm_config + | `Destroy_vm of id + | `Statistics of id + | `Console of id + | `Log of id +] -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, [] +let handle = function + | `Info name -> + let cmd = Vmm_wire.Vm.info c ver name in + `Vmmd, `End, cmd + | `Policy name -> + let cmd = Vmm_wire.Vm.policy c ver name in + `Vmmd, `End, cmd + | `Remove_policy name -> + let cmd = Vmm_wire.Vm.remove_policy c ver name in + `Vmmd, `End, cmd + | `Add_policy (name, policy) -> + let cmd = Vmm_wire.Vm.insert_policy c ver name policy in + `Vmmd, `End, cmd + | `Create_vm vm -> + let cmd = Vmm_wire.Vm.create c ver vm in + `Vmmd, `End, cmd + | `Force_create_vm vm -> + let cmd = Vmm_wire.Vm.force_create c ver vm in + `Vmmd, `End, cmd + | `Destroy_vm name -> + let cmd = Vmm_wire.Vm.destroy c ver name in + `Vmmd, `End, cmd + | `Statistics name -> + let cmd = Vmm_wire.Stats.subscribe c ver name in + `Stats, `Read, cmd + | `Console name -> + let cmd = Vmm_wire.Console.attach c ver name in + `Console, `Read, cmd + | `Log name -> + let cmd = Vmm_wire.Log.subscribe c ver name in + `Log, `Read, cmd +(* | `Crl _ -> assert false + (* write_to_file_unless_serial_smaller ; potentially destroy vms *) + | `Create_block (name, size) -> assert false + | `Destroy_block name -> assert false +*) + +let handle_reply (hdr, data) = + if not (Vmm_wire.version_eq hdr.Vmm_wire.version ver) then + Error (`Msg "unknown wire protocol version") else - match IM.find hdr.id state.stats_requests with - | exception Not_found -> - Logs.err (fun m -> m "couldn't find stat request") ; - state, [] - | (s, req_id, f) -> - let stats_requests = IM.remove hdr.id state.stats_requests in - let state = { state with stats_requests } in - let out = - match Stats.int_to_op hdr.tag with - | Some Stats.Stat_reply -> - begin match Stats.decode_stats (Cstruct.of_string data) with - | Ok (ru, vmm, ifs) -> - let ifs = - List.map - (fun x -> - match f x.name with - | Some name -> { x with name } - | None -> x) - ifs - in - let data = Cstruct.to_string (Stats.encode_stats (ru, vmm, ifs)) in - let out = Client.stat data req_id state.client_version in - [ `Tls (s, out) ] - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while decode statistics" msg) ; - let out = fail req_id state.client_version in - [ `Tls (s, out) ] - end - | None when hdr.tag = fail_tag -> - let out = fail ~msg:data req_id state.client_version in - [ `Tls (s, out) ] - | _ -> - Logs.err (fun m -> m "unexpected reply from stat") ; - [] - in - (state, out) - -let handle_cons state hdr data = - let open Vmm_wire in - if not (version_eq hdr.version state.console_version) then begin - Logs.warn (fun m -> m "ignoring message with unknown console version") ; - state, [] - end else match Console.int_to_op hdr.tag with - | Some Console.Data -> - begin match decode_str data with - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while decoding console message %s" msg) ; - (state, []) - | Ok (file, off) -> - (match String.Map.find file state.console_attached with - | Some s -> - let out = Client.console off file data state.client_version in - (state, [ `Tls (s, out) ]) - | None -> - (* TODO: should detach? *) - Logs.err (fun m -> m "couldn't find attached console for %s" file) ; - (state, [])) - end - | None when hdr.tag = success_tag -> - (match IM.find hdr.id state.console_requests with - | exception Not_found -> - (state, []) - | cont -> - let state', outs = cont state in - let console_requests = IM.remove hdr.id state.console_requests in - ({ state' with console_requests }, outs)) - | None when hdr.tag = fail_tag -> - (match IM.find hdr.id state.console_requests with - | exception Not_found -> - Logs.err (fun m -> m "fail couldn't find request id") ; - (state, []) - | _ -> - Logs.err (fun m -> m "failed while trying to do something on console") ; - let console_requests = IM.remove hdr.id state.console_requests in - ({ state with console_requests }, [])) - | _ -> - Logs.err (fun m -> m "unexpected message received from console socket") ; - (state, []) - -let handle_log state hdr buf = - let open Vmm_wire in - let open Vmm_wire.Log in - if not (version_eq hdr.version state.log_version) then begin - Logs.warn (fun m -> m "ignoring message with unknown stats version") ; - state, [] - end else match IM.find hdr.id state.log_requests with - | exception Not_found -> - Logs.warn (fun m -> m "(ignored) coudn't find log request") ; - (state, []) - | (s, rid) -> - let r = match int_to_op hdr.tag with - | Some Data -> - decode_log_hdr (Cstruct.of_string buf) >>= fun (hdr, rest) -> - decode_event rest >>= fun event -> - let tls = Vmm_wire.Client.log hdr event state.client_version in - Ok (state, [ `Tls (s, tls) ]) - | None when hdr.tag = success_tag -> - let log_requests = IM.remove hdr.id state.log_requests in - let tls = Vmm_wire.success rid state.client_version in - Ok ({ state with log_requests }, [ `Tls (s, tls) ]) - | None when hdr.tag = fail_tag -> - let log_requests = IM.remove hdr.id state.log_requests in - let tls = Vmm_wire.fail rid state.client_version in - Ok ({ state with log_requests }, [ `Tls (s, tls) ]) - | _ -> - Logs.err (fun m -> m "couldn't parse log reply") ; - let log_requests = IM.remove hdr.id state.log_requests in - Ok ({ state with log_requests }, []) - in - match r with - | Ok (s, out) -> s, out - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while processing log %s" msg) ; - state, [] + if Vmm_wire.is_fail hdr then + let msg = match Vmm_wire.decode_string data with + | Ok (msg, _) -> msg + | Error _ -> "" + in + Error (`Msg ("command failed " ^ msg)) + else if Vmm_wire.is_reply hdr && hdr.Vmm_wire.id = c then + Ok (hdr, data) + else + Error (`Msg "received unexpected data") diff --git a/src/vmm_core.ml b/src/vmm_core.ml index ae04661..c4d2ae4 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -229,10 +229,12 @@ 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) + | `Hex str -> str let id cert = identifier (X509.serial cert) +let name cert = X509.common_name_to_string cert + let parse_db lines = List.fold_left (fun acc s -> acc >>= fun datas -> diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index b1f5445..0f19478 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -1,6 +1,11 @@ +open Astring +open Rresult.R.Infix + +open Vmm_core let asn_version = `AV1 +(* let handle_single_revocation t prefix serial = let id = identifier serial in (match Vmm_resources.find t.resources (prefix @ [ id ]) with @@ -39,7 +44,9 @@ let handle_single_revocation t prefix serial = (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))! *) @@ -85,20 +92,51 @@ let handle_revocation t s leaf chain ca prefix = 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 = +let my_command = 1L +let my_version = `WV2 + + +let handle_initial s addr chain ca = separate_chain chain >>= fun (leaf, chain) -> + let prefix = List.map name chain in + let name = prefix @ [ name leaf ] in Logs.debug (fun m -> m "leaf is %s, chain %a" (X509.common_name_to_string leaf) - Fmt.(list ~sep:(unit "->") string) + Fmt.(list ~sep:(unit " -> ") string) (List.map X509.common_name_to_string chain)) ; (* TODO here: inspect top-level-cert of chain. may need to create bridges and/or block device subdirectory (zfs create) *) - let prefix = List.map id chain in - let login_hdr, login_ev = Log.hdr prefix (id leaf), `Login addr in - let t, out = log t (login_hdr, login_ev) in - let initial_out = `Tls (s, Vmm_wire.Client.log login_hdr login_ev t.client_version) in - Vmm_asn.permissions_of_cert asn_version leaf >>= fun perms -> + (* let login_hdr, login_ev = Log.hdr name, `Login addr in *) + Ok () +(* Vmm_asn.command_of_cert asn_version leaf >>= function + | `Info -> + let cmd = Vmm_wire.Vm.info my_command my_version name in + Ok (`Vmmd, cmd) + | `Create_vm -> + Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config -> + let cmd = Vmm_wire.Vm.create my_command my_version vm_config in + (* TODO: update acl *) + Ok (`Vmmd, cmd) + | `Force_create_vm -> + Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config -> + let cmd = Vmm_wire.Vm.force_create my_command my_version vm_config in + (* TODO: update acl *) + Ok (`Vmmd, cmd) + | `Destroy_vm -> + let cmd = Vmm_wire.Vm.destroy my_command my_version name in + Ok (`Vmmd, cmd) + | `Statistics -> + let cmd = Vmm_wire.Stats.subscribe my_command my_version name in + Ok (`Stats, cmd) + | `Console -> `Cons, Vmm_wire.Console.attach ; read there and write to tls + | `Log -> `Log, Vmm_wire.Log.subscribe ; read there and write to tls + | `Crl -> write_to_file_unless_serial_smaller ; potentially destroy vms + | `Create_block -> ?? + | `Destroy_block -> ?? + + (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then (* convert certificate to vm_config *) Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config -> @@ -144,20 +182,6 @@ let handle_initial t s addr chain ca = cont) in Ok (t, [], `Create (task, next)) - else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then - handle_revocation t s leaf chain ca prefix - else - let log_attached = - if cmd_allowed perms Log then - let pre = string_of_id prefix in - let v = match String.Map.find pre t.log_attached with - | None -> [] - | Some xs -> xs - in - String.Map.add pre ((s, id leaf) :: v) t.log_attached - else - t.log_attached - in - Ok ({ t with log_attached }, [], `Loop (prefix, perms)) - ) >>= fun (t, outs, res) -> - Ok (t, initial_out :: out @ outs, res) +(* else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then + handle_revocation t s leaf chain ca prefix *) + *) From 2239aafdb722cd332dc6ba6a1254deea49dc7e07 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 14 Oct 2018 02:18:33 +0200 Subject: [PATCH 25/73] revive vmm_client --- app/vmm_client.ml | 101 +++----------------- app/vmm_tls_endpoint.ml | 43 ++++++++- app/vmmc.ml | 112 ++++++---------------- pkg/pkg.ml | 2 +- src/vmm_commands.ml | 59 +++++++++++- src/vmm_tls.ml | 6 +- src/vmm_x509.ml | 206 +++++++--------------------------------- 7 files changed, 176 insertions(+), 353 deletions(-) diff --git a/app/vmm_client.ml b/app/vmm_client.ml index 46b5485..4599ad6 100644 --- a/app/vmm_client.ml +++ b/app/vmm_client.ml @@ -4,85 +4,20 @@ open Lwt.Infix open Vmm_core -let my_version = `WV2 -let command = ref 1 - -let process db hdr data = - let open Vmm_wire in - let open Rresult.R.Infix in - if not (version_eq hdr.version my_version) then - Logs.err (fun m -> m "unknown wire protocol version") - else - let r = - match hdr.tag with - | x when x = Client.stat_msg_tag -> - Client.decode_stat data >>= fun (ru, vmm, ifd) -> - Logs.app (fun m -> m "statistics: %a %a %a" - pp_rusage ru - Fmt.(list ~sep:(unit ", ") (pair ~sep:(unit ": ") string uint64)) vmm - Fmt.(list ~sep:(unit ", ") pp_ifdata) ifd) ; - Ok () - | x when x = Client.log_msg_tag -> - Client.decode_log data >>= fun log -> - Logs.app (fun m -> m "log: %a" (Vmm_core.Log.pp db) log) ; - Ok () - | x when x = Client.console_msg_tag -> - Client.decode_console data >>= fun (name, ts, msg) -> - Logs.app (fun m -> m "console %s: %a %s" (translate_serial db name) (Ptime.pp_human ~tz_offset_s:0 ()) ts msg) ; - Ok () - | x when x = Client.info_msg_tag -> - Client.decode_info data >>= fun vms -> - List.iter (fun (name, cmd, pid, taps) -> - Logs.app (fun m -> m "info %s: %s %d taps %a" (translate_serial db name) - cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) - vms ; - Ok () - | x when x = fail_tag -> - decode_str data >>= fun (msg, _) -> - Logs.err (fun m -> m "failed %s" msg) ; - Ok () - | x when x = success_tag -> - decode_str data >>= fun (msg, _) -> - Logs.app (fun m -> m "success %s" msg) ; - Ok () - | x -> Rresult.R.error_msgf "unknown header tag %02X" x - in - match r with - | Ok () -> () - | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg) - -let rec read_tls_write_cons db t = +let rec read_tls_write_cons t = Vmm_tls.read_tls t >>= function | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; - read_tls_write_cons db t + read_tls_write_cons t | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (hdr, data) -> - process db hdr data ; - read_tls_write_cons db t + | Ok data -> + match Vmm_commands.log_pp_reply data with + | Ok () -> read_tls_write_cons t + | Error (`Msg msg) -> + Logs.warn (fun m -> m "error %s while logging message" msg) ; + read_tls_write_cons t -let rec read_cons_write_tls db t = - Lwt.catch (fun () -> - Lwt_io.read_line Lwt_io.stdin >>= fun line -> - let cmd, arg = match Astring.String.cut ~sep:" " line with - | None -> line, None - | Some (a, b) -> a, Some (translate_name db b) - in - match Vmm_core.cmd_of_string cmd with - | None -> Logs.err (fun m -> m "unknown command") ; read_cons_write_tls db t - | Some cmd -> - let out = Vmm_wire.Client.cmd ?arg cmd !command my_version in - command := succ !command ; - Vmm_tls.write_tls t out >>= function - | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return_unit - | Ok () -> - Logs.debug (fun m -> m "wrote %a" Cstruct.hexdump_pp (Cstruct.of_string out)) ; - read_cons_write_tls db t) - (fun e -> - Logs.err (fun m -> m "exception %s in read_cons_write_tls" (Printexc.to_string e)) ; - Lwt.return_unit) - -let client cas host port cert priv_key db = +let client cas host port cert priv_key = Nocrypto_entropy_lwt.initialize () >>= fun () -> let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in X509_lwt.authenticator auth >>= fun authenticator -> @@ -99,12 +34,7 @@ let client cas host port cert priv_key db = let certificates = `Single cert in let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t -> - - if Vmm_asn.contains_vm leaf || Vmm_asn.contains_crl leaf then - read_tls_write_cons db t - else - (Logs.debug (fun m -> m "read/write games!") ; - Lwt.join [ read_tls_write_cons db t ; read_cons_write_tls db t ])) + read_tls_write_cons t) (fun exn -> Logs.err (fun m -> m "failed to establish TLS connection: %s" (Printexc.to_string exn)) ; @@ -116,16 +46,7 @@ let run_client _ cas cert key (host, port) db = | 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) + Lwt_main.run (client cas host port cert key) let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 909c27a..087f3e2 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -34,10 +34,45 @@ let client_auth ca tls addr = Tls_lwt.Unix.close tls >>= fun () -> Lwt.fail_with "error while getting epoch") +let read fd tls = + (* now we busy read and process output *) + let rec loop () = + Vmm_lwt.read_wire fd >>= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () + | Error _ -> Lwt.return (Error (`Msg "exception while reading")) + | Ok (hdr, data) -> + let full = Cstruct.append (Vmm_wire.encode_header hdr) data in + Vmm_tls.write_tls tls full >>= function + | Ok () -> loop () + | Error `Exception -> Lwt.return (Error (`Msg "exception")) + in + loop () + +let process fd tls = + Vmm_lwt.read_wire fd >>= function + | Error (`Msg m) -> Lwt.return (Error (`Msg m)) + | Error _ -> Lwt.return (Error (`Msg "read error")) + | Ok (hdr, data) -> + let full = Cstruct.append (Vmm_wire.encode_header hdr) data in + Vmm_tls.write_tls tls full >|= function + | Ok () -> Ok () + | Error `Exception -> Error (`Msg "exception on write") + let handle ca (tls, addr) = client_auth ca tls addr >>= fun chain -> - let _ = Vmm_x509.handle_initial tls addr chain ca in - Lwt.return_unit + match Vmm_x509.handle addr chain with + | Error (`Msg m) -> Lwt.fail_with m + | Ok cmd -> + let sock, next, cmd = Vmm_commands.handle cmd in + connect (Vmm_core.socket_path sock) >>= fun fd -> + Vmm_lwt.write_wire fd cmd >>= function + | Error `Exception -> Lwt.return (Error (`Msg "couldn't write")) + | Ok () -> + (match next with + | `Read -> read fd tls + | `End -> process fd tls) >>= fun res -> + Vmm_lwt.safe_close fd >|= fun () -> + res let server_socket port = let open Lwt_unix in @@ -72,7 +107,9 @@ let jump _ cacert cert priv_key port = Lwt.fail exn) >>= fun t -> Lwt.async (fun () -> Lwt.catch - (fun () -> handle ca t) + (fun () -> handle ca t >|= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg) + | Ok () -> ()) (fun e -> Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ; diff --git a/app/vmmc.ml b/app/vmmc.ml index 45bd79f..1ce632c 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -22,76 +22,56 @@ let connect socket_path = Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> c -let read fd f = +let read fd = (* now we busy read and process output *) let rec loop () = Vmm_lwt.read_wire fd >>= function | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () | Error _ -> Lwt.return (Error (`Msg "exception while reading")) - | Ok (hdr, data) -> - Logs.debug (fun m -> m "received %a" Cstruct.hexdump_pp data) ; - if Vmm_wire.is_fail hdr then - let msg = match Vmm_wire.decode_string data with - | Error _ -> "" - | Ok (m, _) -> m - in - Lwt.return (Error (`Msg ("operation failed " ^ msg))) - else if Vmm_wire.is_reply hdr then - let msg = match Vmm_wire.decode_string data with - | Error _ -> None - | Ok (m, _) -> Some m - in - Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; - loop () - else - match f (hdr, data) with - | Ok () -> loop () - | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) + | Ok data -> match Vmm_commands.handle_reply data with + | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) + | Ok (hdr, data) -> + if Vmm_wire.is_reply hdr then + let msg = match Vmm_wire.decode_string data with + | Error _ -> None + | Ok (m, _) -> Some m + in + Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; + loop () + else + match Vmm_commands.log_pp_reply (hdr, data) with + | Ok () -> loop () + | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) in loop () -let handle opt_socket (cmd : Vmm_commands.t) f = +let handle opt_socket (cmd : Vmm_commands.t) = let sock, next, cmd = Vmm_commands.handle cmd in connect (socket sock opt_socket) >>= fun fd -> Vmm_lwt.write_wire fd cmd >>= function | Error `Exception -> Lwt.return (Error (`Msg "couldn't write")) | Ok () -> (match next with - | `Read -> read fd f + | `Read -> read fd | `End -> process fd >|= function | Error e -> Error e - | Ok data -> f data) >>= fun res -> + | Ok data -> Vmm_commands.log_pp_reply data) >>= fun res -> Vmm_lwt.safe_close fd >|= fun () -> res -let jump opt_socket cmd f = +let jump opt_socket cmd = match - Lwt_main.run (handle opt_socket cmd f) + Lwt_main.run (handle opt_socket cmd) with | Ok () -> `Ok () | Error (`Msg m) -> `Error (false, m) -let info_ _ opt_socket name = - jump opt_socket (`Info name) (fun (_, data) -> - let open Rresult.R.Infix in - Vmm_wire.Vm.decode_vms data >>| fun (vms, _) -> - List.iter (fun (id, memory, cmd, pid, taps) -> - Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a" - pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) - vms) +let info_ _ opt_socket name = jump opt_socket (`Info name) -let policy _ opt_socket name = - jump opt_socket (`Policy name) (fun (_, data) -> - let open Rresult.R.Infix in - Vmm_wire.Vm.decode_policies data >>| fun (policies, _) -> - List.iter (fun (id, policy) -> - Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy)) - policies) +let policy _ opt_socket name = jump opt_socket (`Policy name) -let remove_policy _ opt_socket name = - jump opt_socket (`Remove_policy name) (fun _ -> - Ok (Logs.app (fun m -> m "removed policy"))) +let remove_policy _ opt_socket name = jump opt_socket (`Remove_policy name) let add_policy _ opt_socket name vms memory cpus block bridges = let bridges = match bridges with @@ -104,12 +84,10 @@ let add_policy _ opt_socket name vms memory cpus block bridges = and cpuids = IS.of_list cpus in let policy = { vms ; cpuids ; memory ; block ; bridges } in - jump opt_socket (`Add_policy (name, policy)) (fun _ -> - Ok (Logs.app (fun m -> m "added policy"))) + jump opt_socket (`Add_policy (name, policy)) let destroy _ opt_socket name = - jump opt_socket (`Destroy_vm name) (fun _ -> - Ok (Logs.app (fun m -> m "destroyed VM"))) + jump opt_socket (`Destroy_vm name) let create _ opt_socket force name image cpuid requested_memory boot_params block_device network = let image' = match Bos.OS.File.read (Fpath.v image) with @@ -132,45 +110,13 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc else `Create_vm vm_config in - let succ _ = Ok (Logs.app (fun m -> m "successfully started VM")) in - jump opt_socket cmd succ + jump opt_socket cmd -let console _ opt_socket name = - jump opt_socket (`Console name) (fun (hdr, data) -> - let open Rresult.R.Infix in - match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with - | Some Vmm_wire.Console.Data -> - Vmm_wire.decode_id_ts data >>= fun ((name, ts), off) -> - Vmm_wire.decode_string (Cstruct.shift data off) >>= fun (msg, _) -> - Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts Vmm_core.pp_id name msg) ; - Ok () - | _ -> - Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag))) +let console _ opt_socket name = jump opt_socket (`Console name) -let stats _ opt_socket name = - jump opt_socket (`Statistics name) (fun (hdr, data) -> - let open Rresult.R.Infix in - match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with - | Some Vmm_wire.Stats.Data -> - Vmm_wire.decode_strings data >>= fun (name', off) -> - Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun (ru, vmm, ifs) -> - Logs.app (fun m -> m "stats %a@.%a@.%a@.%a@." - pp_id name' Vmm_core.pp_rusage ru - Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm - Fmt.(list ~sep:(unit "@.") Vmm_core.pp_ifdata) ifs) ; - | _ -> - Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.Vmm_wire.tag))) +let stats _ opt_socket name = jump opt_socket (`Statistics name) -let event_log _ opt_socket name = - jump opt_socket (`Log name) (fun (hdr, data) -> - let open Rresult.R.Infix in - match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with - | Some Vmm_wire.Log.Broadcast -> - Vmm_wire.Log.decode_log_hdr data >>= fun (loghdr, logdata) -> - Vmm_wire.Log.decode_event logdata >>| fun event -> - Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event)) - | _ -> - Ok (Logs.warn (fun m -> m "unknown operation %lx" hdr.Vmm_wire.tag))) +let event_log _ opt_socket name = jump opt_socket (`Log name) let help _ _ man_format cmds = function | None -> `Help (`Pager, None) diff --git a/pkg/pkg.ml b/pkg/pkg.ml index a8823a6..0b280e7 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -9,7 +9,7 @@ let () = Pkg.bin "app/vmmd" ; Pkg.bin "app/vmm_console" ; Pkg.bin "app/vmm_log" ; - (* Pkg.bin "app/vmm_client" ; *) + Pkg.bin "app/vmm_client" ; Pkg.bin "app/vmm_tls_endpoint" ; Pkg.bin "app/vmmc" ; Pkg.bin "provision/vmm_req_command" ; diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index fb8f7f3..31ab71d 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -16,6 +16,9 @@ type t = [ | `Statistics of id | `Console of id | `Log of id + | `Crl (* TODO *) + | `Create_block of id * int + | `Destroy_block of id ] let handle = function @@ -49,11 +52,9 @@ let handle = function | `Log name -> let cmd = Vmm_wire.Log.subscribe c ver name in `Log, `Read, cmd -(* | `Crl _ -> assert false - (* write_to_file_unless_serial_smaller ; potentially destroy vms *) + | `Crl -> assert false | `Create_block (name, size) -> assert false | `Destroy_block name -> assert false -*) let handle_reply (hdr, data) = if not (Vmm_wire.version_eq hdr.Vmm_wire.version ver) then @@ -69,3 +70,55 @@ let handle_reply (hdr, data) = Ok (hdr, data) else Error (`Msg "received unexpected data") + +let log_pp_reply (hdr, data) = + let open Vmm_wire in + let tag' = Int32.logxor reply_tag hdr.tag in + let open Rresult.R.Infix in + match Vm.int_to_op tag' with + | Some Vm.Info -> + Vm.decode_vms data >>| fun (vms, _) -> + List.iter (fun (id, memory, cmd, pid, taps) -> + Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a" + pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) + vms + | Some Vm.Policy -> + Vm.decode_policies data >>| fun (policies, _) -> + List.iter (fun (id, policy) -> + Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy)) + policies + | Some Vm.Insert_policy -> + Ok (Logs.app (fun m -> m "added policy")) + | Some Vm.Remove_policy -> + Ok (Logs.app (fun m -> m "removed policy")) + | Some Vm.Destroy -> + Ok (Logs.app (fun m -> m "destroyed VM")) + | Some Vm.Create -> + Ok (Logs.app (fun m -> m "successfully started VM")) + | Some Vm.Force_create -> + Ok (Logs.app (fun m -> m "successfully forcefully started VM")) + | None -> match Console.int_to_op tag' with + | Some Console.Data -> + decode_id_ts data >>= fun ((name, ts), off) -> + decode_string (Cstruct.shift data off) >>| fun (msg, _) -> + Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts pp_id name msg) + | Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) + | None -> match Stats.int_to_op tag' with + | Some Stats.Data -> + decode_strings data >>= fun (name', off) -> + Stats.decode_stats (Cstruct.shift data off) >>| fun (ru, vmm, ifs) -> + Logs.app (fun m -> m "stats %a@.%a@.%a@.%a@." + pp_id name' pp_rusage ru + Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm + Fmt.(list ~sep:(unit "@.") pp_ifdata) ifs) + | Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) + | None -> match Log.int_to_op tag' with + | Some Log.Broadcast -> + Log.decode_log_hdr data >>= fun (loghdr, logdata) -> + Log.decode_event logdata >>| fun event -> + Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event)) + | Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) + | None -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) + + + diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index b41d40a..e532841 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -42,14 +42,14 @@ let read_tls t = (* 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) + Ok (hdr, b) else - Lwt.return (Ok (hdr, "")) + Lwt.return (Ok (hdr, Cstruct.empty)) let write_tls s buf = (* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *) Lwt.catch - (fun () -> Tls_lwt.Unix.write s (Cstruct.of_string buf) >|= fun () -> Ok ()) + (fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ()) (function | Tls_lwt.Tls_failure a -> Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ; diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index 0f19478..ea65bb1 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -5,142 +5,7 @@ open Vmm_core let asn_version = `AV1 -(* -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_unix.destroy e) ; - (* also revoke all active sessions!? *) - (* TODO: maybe we need a vmm_resources like structure for sessions as well!? *) - let log_attached, kill = - let pid = string_of_id prefix in - match String.Map.find pid t.log_attached with - | None -> t.log_attached, [] - | Some xs -> - (* those where snd v = serial: drop *) - let drop, keep = List.partition (fun (_, s) -> String.equal s id) xs in - String.Map.add pid keep t.log_attached, drop - in - (* two things: - 1 revoked LEAF certs need to go (k = prefix, snd v = serial) [see above] - 2 revoked CA certs need to wipe subtree (all entries where k starts with prefix @ serial) *) - let log_attached, kill = - String.Map.fold (fun k' v (l, k) -> - if is_sub_id ~super:(prefix@[id]) ~sub:(id_of_string k') then - (l, v @ k) - else - (String.Map.add k' v l, k)) - log_attached - (String.Map.empty, kill) - in - let state, out = - List.fold_left (fun (s, out) (t, _) -> - let s', out' = handle_disconnect s t in - s', out @ out') - ({ t with log_attached }, []) - kill - in - (state, - List.map (fun x -> `Raw x) out, - List.map fst kill) -*) - -(* -let handle_revocation t s leaf chain ca prefix = - Vmm_asn.crl_of_cert leaf >>= fun crl -> - (* verify data (must be signed by the last cert of the chain (or cacert if chain is empty))! *) - let issuer = match chain with - | subca::_ -> subca - | [] -> ca - in - let time = Ptime_clock.now () in - (if X509.CRL.verify crl ~time issuer then Ok () else Error (`Msg "couldn't verify CRL")) >>= fun () -> - (* the this_update must be > now, next_update < now, this_update > .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 _, 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.(dbdir / "crls" / string_of_id prefix) in - Bos.OS.File.delete filename >>= fun () -> - Bos.OS.File.write filename (Cstruct.to_string (X509.Encoding.crl_to_cstruct crl)) >>= fun () -> - (* remove crl with same issuer from crls, and inject this one into state *) - let crls = - match local with - | None -> crl :: t.crls - | Some _ -> crl :: List.filter (fun c -> c <> crl) t.crls - in - (* iterate over revoked serials, find active resources, and kill them *) - let newly_revoked = - let old = match local with - | Some x -> List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates x) - | None -> [] - in - let new_rev = List.map (fun rc -> rc.X509.CRL.serial) (X509.CRL.revoked_certificates crl) in - List.filter (fun n -> not (List.mem n old)) new_rev - in - let t, out, close = - List.fold_left (fun (t, out, close) serial -> - let t', out', close' = handle_single_revocation t prefix serial in - (t', out @ out', close @ close')) - (t, [], []) newly_revoked - in - let tls_out = Vmm_wire.success ~msg:"updated revocation list" 0 t.client_version in - Ok ({ t with crls }, `Tls (s, tls_out) :: out, `Close close) -*) - -let my_command = 1L -let my_version = `WV2 - - -let handle_initial s addr chain ca = - separate_chain chain >>= fun (leaf, chain) -> - let prefix = List.map name chain in - let name = prefix @ [ name leaf ] in - 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 login_hdr, login_ev = Log.hdr name, `Login addr in *) - Ok () -(* Vmm_asn.command_of_cert asn_version leaf >>= function - | `Info -> - let cmd = Vmm_wire.Vm.info my_command my_version name in - Ok (`Vmmd, cmd) - | `Create_vm -> - Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config -> - let cmd = Vmm_wire.Vm.create my_command my_version vm_config in - (* TODO: update acl *) - Ok (`Vmmd, cmd) - | `Force_create_vm -> - Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config -> - let cmd = Vmm_wire.Vm.force_create my_command my_version vm_config in - (* TODO: update acl *) - Ok (`Vmmd, cmd) - | `Destroy_vm -> - let cmd = Vmm_wire.Vm.destroy my_command my_version name in - Ok (`Vmmd, cmd) - | `Statistics -> - let cmd = Vmm_wire.Stats.subscribe my_command my_version name in - Ok (`Stats, cmd) - | `Console -> `Cons, Vmm_wire.Console.attach ; read there and write to tls - | `Log -> `Log, Vmm_wire.Log.subscribe ; read there and write to tls - | `Crl -> write_to_file_unless_serial_smaller ; potentially destroy vms - | `Create_block -> ?? - | `Destroy_block -> ?? - - - (if (List.mem `Create perms || List.mem `Force_create perms) && Vmm_asn.contains_vm leaf then - (* convert certificate to vm_config *) - Vmm_asn.vm_of_cert prefix leaf >>= fun vm_config -> - Logs.debug (fun m -> m "vm %a" pp_vm_config vm_config) ; +(* let check_policy = (* get names and static resources *) List.fold_left (fun acc ca -> acc >>= fun acc -> @@ -151,37 +16,38 @@ let handle_initial s addr chain ca = (* check static policies *) Logs.debug (fun m -> m "now checking static policies") ; check_policies vm_config (List.map snd policies) >>= fun () -> - let t, task = - let force = List.mem `Force_create perms in - if force then - let fid = vm_id vm_config in - match String.Map.find fid t.tasks with - | None -> t, None - | Some task -> - let kill () = - match Vmm_resources.find_vm t.resources (fullname vm_config) with - | None -> - Logs.err (fun m -> m "found a task, but no vm for %a (%s)" - pp_id (fullname vm_config) fid) - | Some vm -> - Logs.debug (fun m -> m "killing %a now" pp_vm vm) ; - Vmm_unix.destroy vm - in - let tasks = String.Map.remove fid t.tasks in - ({ t with tasks }, Some (kill, task)) - else - t, None - in - let next t sleeper = - handle_create t vm_config policies >>= fun cont -> - let id = vm_id vm_config in - let cons = Vmm_wire.Console.add t.console_counter t.console_version id in - let tasks = String.Map.add id sleeper t.tasks in - Ok ({ t with console_counter = succ t.console_counter ; tasks }, - [ `Raw (t.console_socket, cons) ], - cont) - in - Ok (t, [], `Create (task, next)) -(* else if List.mem `Crl perms && Vmm_asn.contains_crl leaf then - handle_revocation t s leaf chain ca prefix *) - *) +*) + +let handle addr chain = + separate_chain chain >>= fun (leaf, chain) -> + let prefix = List.map name chain in + let name = prefix @ [ name leaf ] in + 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 login_hdr, login_ev = Log.hdr name, `Login addr in *) + Vmm_asn.command_of_cert asn_version leaf >>= function + | `Info -> Ok (`Info name) + | `Create_vm -> + (* TODO: update acl *) + Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config -> + `Create_vm vm_config + | `Force_create_vm -> + (* TODO: update acl *) + Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config -> + `Force_create_vm vm_config + | `Destroy_vm -> Ok (`Destroy_vm name) + | `Statistics -> Ok (`Statistics name) + | `Console -> Ok (`Console name) + | `Log -> Ok (`Log name) + | `Crl -> Ok `Crl + | `Create_block -> + Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name -> + Vmm_asn.block_size_of_cert asn_version leaf >>| fun block_size -> + `Create_block (block_name, block_size) + | `Destroy_block -> + Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name -> + `Destroy_block block_name From 51a034447776709596e909ad9ad832ca8166e97b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 21 Oct 2018 00:29:25 +0200 Subject: [PATCH 26/73] fix warnings --- app/vmm_client.ml | 13 ++----------- app/vmm_log.ml | 2 -- src/vmm_commands.ml | 4 ++-- src/vmm_wire.ml | 2 +- src/vmm_x509.ml | 3 +-- 5 files changed, 6 insertions(+), 18 deletions(-) diff --git a/app/vmm_client.ml b/app/vmm_client.ml index 4599ad6..51e6681 100644 --- a/app/vmm_client.ml +++ b/app/vmm_client.ml @@ -2,8 +2,6 @@ open Lwt.Infix -open Vmm_core - let rec read_tls_write_cons t = Vmm_tls.read_tls t >>= function | Error (`Msg msg) -> @@ -28,9 +26,6 @@ let client cas host port cert priv_key = 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 -> @@ -40,7 +35,7 @@ let client cas host port cert priv_key = (Printexc.to_string exn)) ; Lwt.return_unit) -let run_client _ cas cert key (host, port) db = +let run_client _ cas cert key (host, port) = Printexc.register_printer (function | Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x) | Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f) @@ -92,17 +87,13 @@ 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.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination), Term.info "vmm_client" ~version:"%%VERSION_NUM%%" ~doc ~man let () = diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 649a548..5d2969d 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -12,8 +12,6 @@ open Lwt.Infix -open Astring - let my_version = `WV2 let broadcast prefix data t = diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index 31ab71d..f8bedc3 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -53,8 +53,8 @@ let handle = function let cmd = Vmm_wire.Log.subscribe c ver name in `Log, `Read, cmd | `Crl -> assert false - | `Create_block (name, size) -> assert false - | `Destroy_block name -> assert false + | `Create_block (_name, _size) -> assert false + | `Destroy_block _name -> assert false let handle_reply (hdr, data) = if not (Vmm_wire.version_eq hdr.Vmm_wire.version ver) then diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml index 9153fbc..d06ff00 100644 --- a/src/vmm_wire.ml +++ b/src/vmm_wire.ml @@ -538,7 +538,7 @@ module Log = struct let log id version hdr event = let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) in - encode ~name:hdr.name ~body version id (op_to_int Log) + encode ~name:hdr.Log.name ~body version id (op_to_int Log) end module Vm = struct diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index ea65bb1..fbef56d 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -1,4 +1,3 @@ -open Astring open Rresult.R.Infix open Vmm_core @@ -18,7 +17,7 @@ let asn_version = `AV1 check_policies vm_config (List.map snd policies) >>= fun () -> *) -let handle addr chain = +let handle _addr chain = separate_chain chain >>= fun (leaf, chain) -> let prefix = List.map name chain in let name = prefix @ [ name leaf ] in From 1d4d7509dcc7bd7786f28298b95f30d2ad1cd648 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 22 Oct 2018 23:20:00 +0200 Subject: [PATCH 27/73] remove vmm_wire, use asn.1 --- .ocamlinit | 3 + app/vmm_console.ml | 37 +-- app/vmm_log.ml | 105 ++++--- app/vmmc.ml | 74 +++-- app/vmmd.ml | 67 ++--- pkg/pkg.ml | 13 +- src/albatross.mllib | 11 + src/vmm_asn.ml | 447 +++++++++++++++++++++++++++- src/vmm_asn.mli | 65 ++++- src/vmm_commands.ml | 124 +------- src/vmm_commands.mli | 7 + src/vmm_compress.mli | 2 + src/vmm_core.ml | 18 +- src/vmm_core.mli | 304 +++++++++++++++++++ src/vmm_engine.ml | 195 +++++++------ src/vmm_engine.mli | 26 ++ src/vmm_lwt.ml | 38 +-- src/vmm_lwt.mli | 14 + src/vmm_tls.ml | 35 ++- src/vmm_tls.mli | 5 + src/vmm_wire.ml | 681 ------------------------------------------- stats/vmm_stats.ml | 1 + 22 files changed, 1170 insertions(+), 1102 deletions(-) create mode 100644 .ocamlinit create mode 100644 src/albatross.mllib create mode 100644 src/vmm_commands.mli create mode 100644 src/vmm_compress.mli create mode 100644 src/vmm_core.mli create mode 100644 src/vmm_engine.mli create mode 100644 src/vmm_lwt.mli create mode 100644 src/vmm_tls.mli delete mode 100644 src/vmm_wire.ml diff --git a/.ocamlinit b/.ocamlinit new file mode 100644 index 0000000..6702b21 --- /dev/null +++ b/.ocamlinit @@ -0,0 +1,3 @@ +#require "cstruct, asn1-combinators, astring, fmt, ipaddr, rresult, lwt, x509, tls, hex, bos, decompress, tls.lwt" +#directory "_build/src" +#load "albatross.cma" diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 3ec0cc6..81f7572 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -14,7 +14,7 @@ open Lwt.Infix open Astring -let my_version = `WV2 +let my_version = `AV2 let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e) @@ -31,7 +31,8 @@ let read_console name ring channel () = (match String.Map.find name !active with | None -> Lwt.return_unit | Some fd -> - Vmm_lwt.write_wire fd (Vmm_wire.Console.data my_version id t line) >>= function + let header = Vmm_asn.{ version = my_version ; sequence = 0L ; id } in + Vmm_lwt.write_wire fd (header, `Command (`Console_cmd (`Console_data (t, line)))) >>= function | Error _ -> Vmm_lwt.safe_close fd >|= fun () -> active := String.Map.remove name !active @@ -79,7 +80,7 @@ let add_fifo id = | None -> Error (`Msg "opening") -let attach s id = +let subscribe s id = let name = Vmm_core.string_of_id id in Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ; match String.Map.find name !t with @@ -90,8 +91,8 @@ let attach s id = let entries = Vmm_ring.read r in Logs.debug (fun m -> m "found %d history" (List.length entries)) ; Lwt_list.iter_s (fun (i, v) -> - let msg = Vmm_wire.Console.data my_version id i v in - Vmm_lwt.write_wire s msg >|= fun _ -> ()) + let header = Vmm_asn.{ version = my_version ; sequence = 0L ; id } in + Vmm_lwt.write_wire s (header, `Command (`Console_cmd (`Console_data (i, v)))) >|= fun _ -> ()) entries >>= fun () -> (match String.Map.find name !active with | None -> Lwt.return_unit @@ -109,24 +110,24 @@ let handle s addr () = | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (hdr, _) when Vmm_wire.is_reply hdr -> - Logs.err (fun m -> m "unexpected reply") ; + | Ok (_, `Success _) -> + Logs.err (fun m -> m "unexpected success reply") ; loop () - | Ok (hdr, data) -> - (if not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) then + | Ok (_, `Failure _) -> + Logs.err (fun m -> m "unexpected failure reply") ; + loop () + | Ok (header, `Command cmd) -> + (if not (Vmm_asn.version_eq header.Vmm_asn.version my_version) then Lwt.return (Error (`Msg "ignoring data with bad version")) else - match Vmm_wire.decode_strings data with - | Error e -> Lwt.return (Error e) - | Ok (id, _) -> match Vmm_wire.Console.int_to_op hdr.Vmm_wire.tag with - | Some Vmm_wire.Console.Add_console -> add_fifo id - | Some Vmm_wire.Console.Attach_console -> attach s id - | Some Vmm_wire.Console.Data -> Lwt.return (Error (`Msg "unexpected Data")) - | None -> Lwt.return (Error (`Msg "unknown command"))) >>= (function - | Ok msg -> Vmm_lwt.write_wire s (Vmm_wire.success ~msg my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag) + match cmd with + | `Console_cmd `Console_add -> add_fifo header.Vmm_asn.id + | `Console_cmd `Console_subscribe -> subscribe s header.Vmm_asn.id + | _ -> Lwt.return (Error (`Msg "unexpected command"))) >>= (function + | Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg)) | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; - Vmm_lwt.write_wire s (Vmm_wire.fail ~msg my_version hdr.Vmm_wire.id)) >>= function + Vmm_lwt.write_wire s (header, `Failure msg)) >>= function | Ok () -> loop () | Error _ -> Logs.err (fun m -> m "exception while writing to socket") ; diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 5d2969d..26b488c 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -12,7 +12,7 @@ open Lwt.Infix -let my_version = `WV2 +let my_version = `AV2 let broadcast prefix data t = Lwt_list.fold_left_s (fun t (id, s) -> @@ -64,25 +64,24 @@ let tree = ref Vmm_trie.empty let bcast = ref 0L -let send_history s ring id cmd_id = +let send_history s ring id = let elements = Vmm_ring.read ring in let res = List.fold_left (fun acc (_, x) -> let cs = Cstruct.of_string x in - match Vmm_wire.Log.decode_log_hdr cs with - | Ok (hdr, _) -> - begin match Vmm_core.drop_super ~super:id ~sub:hdr.Vmm_core.Log.name with - | Some [] -> cs :: acc - | _ -> acc - end + match Vmm_asn.log_entry_of_cstruct cs with + | Ok (header, ts, event) -> + if Vmm_core.is_sub_id ~super:id ~sub:header.Vmm_asn.id + then (header, ts, event) :: acc + else acc | _ -> acc) [] elements in (* just need a wrapper in tag = Log.Data, id = reqid *) - Lwt_list.fold_left_s (fun r body -> + Lwt_list.fold_left_s (fun r (header, ts, event) -> match r with | Ok () -> - let data = Vmm_wire.encode ~body my_version cmd_id (Vmm_wire.Log.op_to_int Vmm_wire.Log.Broadcast) in + let data = header, `Command (`Log_cmd (`Log_data (ts, event))) in Vmm_lwt.write_wire s data | Error e -> Lwt.return (Error e)) (Ok ()) res @@ -99,53 +98,51 @@ let handle mvar ring s addr () = | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (hdr, _) when Vmm_wire.is_reply hdr -> - Logs.warn (fun m -> m "ignoring reply") ; + | Ok (_, `Failure _) -> + Logs.warn (fun m -> m "ignoring failure") ; loop () - | Ok (hdr, _) when not (Vmm_wire.version_eq hdr.Vmm_wire.version my_version) -> - Logs.warn (fun m -> m "unsupported version") ; - Lwt.return_unit - | Ok (hdr, data) -> match Vmm_wire.Log.int_to_op hdr.Vmm_wire.tag with - | Some Vmm_wire.Log.Log -> - begin match Vmm_wire.Log.decode_log_hdr data with - | Error (`Msg err) -> - Logs.warn (fun m -> m "ignoring error %s while decoding log" err) ; - loop () - | Ok (hdr, _) -> - Vmm_ring.write ring (hdr.Vmm_core.Log.ts, Cstruct.to_string data) ; - Lwt_mvar.put mvar data >>= fun () -> - let data' = Vmm_wire.encode ~body:data my_version !bcast (Vmm_wire.Log.op_to_int Vmm_wire.Log.Broadcast) in - bcast := Int64.succ !bcast ; - broadcast hdr.Vmm_core.Log.name data' !tree >>= fun tree' -> - tree := tree' ; - loop () - end - | Some Vmm_wire.Log.Subscribe -> - begin match Vmm_wire.decode_strings data with - | Error (`Msg err) -> - Logs.warn (fun m -> m "ignoring error %s while decoding subscribe" err) ; - loop () - | Ok (id, _) -> - let tree', ret = Vmm_trie.insert id s !tree in - tree := tree' ; - (match ret with - | None -> Lwt.return_unit - | Some s' -> Vmm_lwt.safe_close s') >>= fun () -> - let out = Vmm_wire.success my_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in - Vmm_lwt.write_wire s out >>= function + | Ok (_, `Success _) -> + Logs.warn (fun m -> m "ignoring success") ; + loop () + | Ok (hdr, `Command (`Log_cmd lc)) -> + if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin + Logs.warn (fun m -> m "unsupported version") ; + Lwt.return_unit + end else begin + match lc with + | `Log_data (ts, event) -> + let data = Vmm_asn.log_entry_to_cstruct (hdr, ts, event) in + Vmm_ring.write ring (ts, Cstruct.to_string data) ; + Lwt_mvar.put mvar data >>= fun () -> + let data' = + let header = Vmm_asn.{ version = my_version ; sequence = !bcast ; id = hdr.Vmm_asn.id } in + (header, `Command (`Log_cmd (`Log_data (ts, event)))) + in + bcast := Int64.succ !bcast ; + broadcast hdr.Vmm_asn.id data' !tree >>= fun tree' -> + tree := tree' ; + loop () + | `Log_subscribe -> + let tree', ret = Vmm_trie.insert hdr.Vmm_asn.id s !tree in + tree := tree' ; + (match ret with + | None -> Lwt.return_unit + | Some s' -> Vmm_lwt.safe_close s') >>= fun () -> + let out = `Success `Empty in + Vmm_lwt.write_wire s (hdr, out) >>= function + | Error _ -> + Logs.err (fun m -> m "error while sending reply for subscribe") ; + Lwt.return_unit + | Ok () -> + send_history s ring hdr.Vmm_asn.id >>= function | Error _ -> - Logs.err (fun m -> m "error while sending reply for subscribe") ; + Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit - | Ok () -> - send_history s ring id hdr.Vmm_wire.id >>= function - | Error _ -> - Logs.err (fun m -> m "error while sending history") ; - Lwt.return_unit - | Ok () -> loop () (* TODO no need to loop ;) *) - end - | _ -> - Logs.err (fun m -> m "unknown command") ; - loop () + | Ok () -> loop () (* TODO no need to loop ;) *) + end + | _ -> + Logs.err (fun m -> m "unknown command") ; + loop () in loop () >>= fun () -> Vmm_lwt.safe_close s diff --git a/app/vmmc.ml b/app/vmmc.ml index 1ce632c..d66ee7a 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -6,11 +6,20 @@ open Astring open Vmm_core +let version = `AV2 + let process fd = Vmm_lwt.read_wire fd >|= function - | Error (`Msg m) -> Error (`Msg m) - | Error _ -> Error (`Msg "read error") - | Ok data -> Vmm_commands.handle_reply data + | Error _ -> + Error (`Msg "read or parse error") + | Ok (header, reply) -> + if Vmm_asn.version_eq header.Vmm_asn.version version then begin + Logs.app (fun m -> m "%a" Vmm_asn.pp_wire (header, reply)) ; + Ok () + end else begin + Logs.err (fun m -> m "version not equal") ; + Error (`Msg "version not equal") + end let socket t = function | Some x -> x @@ -25,53 +34,38 @@ let connect socket_path = let read fd = (* now we busy read and process output *) let rec loop () = - Vmm_lwt.read_wire fd >>= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () - | Error _ -> Lwt.return (Error (`Msg "exception while reading")) - | Ok data -> match Vmm_commands.handle_reply data with - | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) - | Ok (hdr, data) -> - if Vmm_wire.is_reply hdr then - let msg = match Vmm_wire.decode_string data with - | Error _ -> None - | Ok (m, _) -> Some m - in - Logs.app (fun m -> m "operation succeeded: %a" Fmt.(option ~none:(unit "") string) msg) ; - loop () - else - match Vmm_commands.log_pp_reply (hdr, data) with - | Ok () -> loop () - | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) + process fd >>= function + | Error e -> Lwt.return (Error e) + | Ok () -> loop () in loop () -let handle opt_socket (cmd : Vmm_commands.t) = - let sock, next, cmd = Vmm_commands.handle cmd in +let handle opt_socket id (cmd : Vmm_asn.wire_command) = + let sock, next = Vmm_commands.handle cmd in connect (socket sock opt_socket) >>= fun fd -> - Vmm_lwt.write_wire fd cmd >>= function + let header = Vmm_asn.{ version ; sequence = 0L ; id } in + Vmm_lwt.write_wire fd (header, `Command cmd) >>= function | Error `Exception -> Lwt.return (Error (`Msg "couldn't write")) | Ok () -> (match next with | `Read -> read fd - | `End -> - process fd >|= function - | Error e -> Error e - | Ok data -> Vmm_commands.log_pp_reply data) >>= fun res -> + | `End -> process fd) >>= fun res -> Vmm_lwt.safe_close fd >|= fun () -> res -let jump opt_socket cmd = +let jump opt_socket name cmd = match - Lwt_main.run (handle opt_socket cmd) + Lwt_main.run (handle opt_socket name cmd) with | Ok () -> `Ok () | Error (`Msg m) -> `Error (false, m) -let info_ _ opt_socket name = jump opt_socket (`Info name) +let info_ _ opt_socket name = jump opt_socket name (`Vm_cmd `Vm_info) -let policy _ opt_socket name = jump opt_socket (`Policy name) +let policy _ opt_socket name = jump opt_socket name (`Policy_cmd `Policy_info) -let remove_policy _ opt_socket name = jump opt_socket (`Remove_policy name) +let remove_policy _ opt_socket name = + jump opt_socket name (`Policy_cmd `Policy_remove) let add_policy _ opt_socket name vms memory cpus block bridges = let bridges = match bridges with @@ -84,10 +78,10 @@ let add_policy _ opt_socket name vms memory cpus block bridges = and cpuids = IS.of_list cpus in let policy = { vms ; cpuids ; memory ; block ; bridges } in - jump opt_socket (`Add_policy (name, policy)) + jump opt_socket name (`Policy_cmd (`Policy_add policy)) let destroy _ opt_socket name = - jump opt_socket (`Destroy_vm name) + jump opt_socket name (`Vm_cmd `Vm_destroy) let create _ opt_socket force name image cpuid requested_memory boot_params block_device network = let image' = match Bos.OS.File.read (Fpath.v image) with @@ -106,17 +100,17 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc } in let cmd = if force then - `Force_create_vm vm_config + `Vm_force_create vm_config else - `Create_vm vm_config + `Vm_create vm_config in - jump opt_socket cmd + jump opt_socket name (`Vm_cmd cmd) -let console _ opt_socket name = jump opt_socket (`Console name) +let console _ opt_socket name = jump opt_socket name (`Console_cmd `Console_subscribe) -let stats _ opt_socket name = jump opt_socket (`Statistics name) +let stats _ opt_socket name = jump opt_socket name (`Stats_cmd `Stats_subscribe) -let event_log _ opt_socket name = jump opt_socket (`Log name) +let event_log _ opt_socket name = jump opt_socket name (`Log_cmd `Log_subscribe) let help _ _ man_format cmds = function | None -> `Help (`Pager, None) diff --git a/app/vmmd.ml b/app/vmmd.ml index fe5380e..1f89fba 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -16,24 +16,34 @@ let pp_stats ppf s = open Lwt.Infix -type out = [ - | `Cons of Cstruct.t - | `Stat of Cstruct.t - | `Log of Cstruct.t -] +let version = `AV2 -let state = ref (Vmm_engine.init ()) +let state = ref (Vmm_engine.init version) let create c_fd process cont = Vmm_lwt.read_wire c_fd >>= function - | Ok (hdr, data) -> - if Vmm_wire.is_fail hdr then begin - Logs.err (fun m -> m "console failed with %s" (Cstruct.to_string data)) ; + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while reading from console" msg) ; + Lwt.return_unit + | Error _ -> + Logs.err (fun m -> m "error while reading from console") ; + Lwt.return_unit + | Ok (header, wire) -> + if not (Vmm_asn.version_eq version header.Vmm_asn.version) then begin + Logs.err (fun m -> m "invalid version while reading from console") ; Lwt.return_unit - end else if Vmm_wire.is_reply hdr then begin - (* assert hdr.id = id! *) - let await, wakeme = Lwt.wait () in - begin match cont !state await with + end else + match wire with + | `Command _ -> + Logs.err (fun m -> m "console returned a command") ; + Lwt.return_unit + | `Failure f -> + Logs.err (fun m -> m "console failed with %s" f) ; + Lwt.return_unit + | `Success _msg -> + (* assert hdr.id = id! *) + let await, wakeme = Lwt.wait () in + match cont !state await with | Error (`Msg msg) -> Logs.err (fun m -> m "create continuation failed %s" msg) ; Lwt.return_unit @@ -48,25 +58,9 @@ let create c_fd process cont = process out' >|= fun () -> Lwt.wakeup wakeme ()) ; process out >>= fun () -> - begin match Vmm_engine.setup_stats !state vm with - | Ok (state', out) -> - state := state' ; - process out (* TODO: need to read from stats socket! *) - | Error (`Msg e) -> - Logs.warn (fun m -> m "(ignored) error %s while setting up statistics" e) ; - Lwt.return_unit - end - end - end else begin - Logs.err (fun m -> m "reading from console %lx, %a" hdr.Vmm_wire.tag Cstruct.hexdump_pp data) ; - Lwt.return_unit - end - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while reading from console" msg) ; - Lwt.return_unit - | Error _ -> - Logs.err (fun m -> m "error while reading from console") ; - Lwt.return_unit + let state', out = Vmm_engine.setup_stats !state vm in + state := state' ; + process out (* TODO: need to read from stats socket! *) let handle out c_fd fd addr = (* out is for `Log | `Stat | `Cons (including reconnect semantics) *) @@ -86,7 +80,7 @@ let handle out c_fd fd addr = *) let process xs = Lwt_list.iter_p (function - | #out as o -> out o + | #Vmm_engine.service_out as o -> out o | `Data cs -> (* rather: terminate connection *) Vmm_lwt.write_wire fd cs >|= fun _ -> ()) xs @@ -96,16 +90,15 @@ let handle out c_fd fd addr = | Error _ -> Logs.err (fun m -> m "error while reading") ; Lwt.return_unit - | Ok (hdr, buf) -> + | Ok wire -> Logs.debug (fun m -> m "read sth") ; - let state', data, next = Vmm_engine.handle_command !state hdr buf in + let state', data, next = Vmm_engine.handle_command !state wire in state := state' ; process data >>= fun () -> match next with | `End -> Lwt.return_unit | `Wait (task, out) -> task >>= fun () -> process out - | `Wait_and_create (state', task, next) -> - state := state' ; + | `Wait_and_create (task, next) -> task >>= fun () -> let state', data, n = next !state in state := state' ; diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 0b280e7..ae465e3 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -6,20 +6,21 @@ open Topkg let () = Pkg.describe "albatross" @@ fun _ -> Ok [ + Pkg.mllib "src/albatross.mllib" ; Pkg.bin "app/vmmd" ; Pkg.bin "app/vmm_console" ; Pkg.bin "app/vmm_log" ; - Pkg.bin "app/vmm_client" ; - Pkg.bin "app/vmm_tls_endpoint" ; +(* Pkg.bin "app/vmm_client" ; + Pkg.bin "app/vmm_tls_endpoint" ; *) Pkg.bin "app/vmmc" ; - Pkg.bin "provision/vmm_req_command" ; +(* Pkg.bin "provision/vmm_req_command" ; 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.bin "provision/vmm_gen_ca" ; *) (* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *) - Pkg.bin "stats/vmm_stats_lwt" ; +(* Pkg.bin "stats/vmm_stats_lwt" ; (* Pkg.bin "app/vmm_prometheus_stats" ; *) - Pkg.bin "app/vmm_influxdb_stats" ; + Pkg.bin "app/vmm_influxdb_stats" ; *) ] diff --git a/src/albatross.mllib b/src/albatross.mllib new file mode 100644 index 0000000..5aebb70 --- /dev/null +++ b/src/albatross.mllib @@ -0,0 +1,11 @@ +Vmm_asn +Vmm_lwt +Vmm_tls +Vmm_engine +Vmm_commands +Vmm_core +Vmm_engine +Vmm_resources +Vmm_trie +Vmm_unix +Vmm_compress \ No newline at end of file diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 46b623e..bd421f5 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -134,7 +134,6 @@ let policy_of_cstruct, policy_to_cstruct = | Error (`Parse msg) -> Error (`Msg msg)), Asn.encode c) - let image = let f = function | `C1 x -> `Hvt_amd64, x @@ -165,27 +164,31 @@ let opt cert oid f = | None -> Ok None | Some (_, data) -> f data >>| fun s -> Some s -type version = [ `AV0 | `AV1 ] +type version = [ `AV0 | `AV1 | `AV2 ] let version_of_int = function | 0 -> Ok `AV0 | 1 -> Ok `AV1 + | 2 -> Ok `AV2 | _ -> Error (`Msg "couldn't parse version") let version_to_int = function | `AV0 -> 0 | `AV1 -> 1 + | `AV2 -> 2 let pp_version ppf v = Fmt.int ppf (match v with | `AV0 -> 0 - | `AV1 -> 1) + | `AV1 -> 1 + | `AV2 -> 2) let version_eq a b = match a, b with | `AV0, `AV0 -> true | `AV1, `AV1 -> true + | `AV2, `AV2 -> true | _ -> false let version_to_cstruct v = int_to_cstruct (version_to_int v) @@ -260,3 +263,441 @@ let block_device_of_cert version cert = let block_size_of_cert version cert = version_of_cert version cert >>= fun () -> req "block-size" cert Oid.memory int_of_cstruct + +(* communication protocol *) +type console_cmd = [ + | `Console_add + | `Console_subscribe + | `Console_data of Ptime.t * string +] + +let pp_console_cmd ppf = function + | `Console_add -> Fmt.string ppf "console add" + | `Console_subscribe -> Fmt.string ppf "console subscribe" + | `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s" + (Ptime.pp_rfc3339 ()) ts line + +let console_cmd = + let f = function + | `C1 () -> `Console_add + | `C2 () -> `Console_subscribe + | `C3 (timestamp, data) -> `Console_data (timestamp, data) + and g = function + | `Console_add -> `C1 () + | `Console_subscribe -> `C2 () + | `Console_data (timestamp, data) -> `C3 (timestamp, data) + in + Asn.S.map f g @@ + Asn.S.(choice3 + (explicit 0 null) + (explicit 1 null) + (explicit 2 (sequence2 + (required ~label:"timestamp" utc_time) + (required ~label:"data" utf8_string)))) + +(* TODO is this good? *) +let int64 = + let f cs = Cstruct.BE.get_uint64 cs 0 + and g data = + let buf = Cstruct.create 8 in + Cstruct.BE.set_uint64 buf 0 data ; + buf + in + Asn.S.map f g Asn.S.octet_string + +let timeval = + Asn.S.(sequence2 + (required ~label:"seconds" int64) + (required ~label:"microseconds" int)) + +let ru = + let f (utime, (stime, (maxrss, (ixrss, (idrss, (isrss, (minflt, (majflt, (nswap, (inblock, (outblock, (msgsnd, (msgrcv, (nsignals, (nvcsw, nivcsw))))))))))))))) = + { utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ; nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw } + and g ru = + (ru.utime, (ru.stime, (ru.maxrss, (ru.ixrss, (ru.idrss, (ru.isrss, (ru.minflt, (ru.majflt, (ru.nswap, (ru.inblock, (ru.outblock, (ru.msgsnd, (ru.msgrcv, (ru.nsignals, (ru.nvcsw, ru.nivcsw))))))))))))))) + in + Asn.S.map f g @@ + Asn.S.(sequence @@ + (required ~label:"utime" timeval) + @ (required ~label:"stime" timeval) + @ (required ~label:"maxrss" int64) + @ (required ~label:"ixrss" int64) + @ (required ~label:"idrss" int64) + @ (required ~label:"isrss" int64) + @ (required ~label:"minflt" int64) + @ (required ~label:"majflt" int64) + @ (required ~label:"nswap" int64) + @ (required ~label:"inblock" int64) + @ (required ~label:"outblock" int64) + @ (required ~label:"msgsnd" int64) + @ (required ~label:"msgrcv" int64) + @ (required ~label:"nsignals" int64) + @ (required ~label:"nvcsw" int64) + -@ (required ~label:"nivcsw" int64)) + +(* TODO is this good? *) +let int32 = + let f i = Int32.of_int i + and g i = Int32.to_int i + in + Asn.S.map f g Asn.S.int + +let ifdata = + let f (name, (flags, (send_length, (max_send_length, (send_drops, (mtu, (baudrate, (input_packets, (input_errors, (output_packets, (output_errors, (collisions, (input_bytes, (output_bytes, (input_mcast, (output_mcast, (input_dropped, output_dropped))))))))))))))))) = + { name; flags; send_length; max_send_length; send_drops; mtu; baudrate; input_packets; input_errors; output_packets; output_errors; collisions; input_bytes; output_bytes; input_mcast; output_mcast; input_dropped; output_dropped } + and g i = + (i.name, (i.flags, (i.send_length, (i.max_send_length, (i.send_drops, (i.mtu, (i.baudrate, (i.input_packets, (i.input_errors, (i.output_packets, (i.output_errors, (i.collisions, (i.input_bytes, (i.output_bytes, (i.input_mcast, (i.output_mcast, (i.input_dropped, i.output_dropped))))))))))))))))) + in + Asn.S.map f g @@ + Asn.S.(sequence @@ + (required ~label:"name" utf8_string) + @ (required ~label:"flags" int32) + @ (required ~label:"send_length" int32) + @ (required ~label:"max_send_length" int32) + @ (required ~label:"send_drops" int32) + @ (required ~label:"mtu" int32) + @ (required ~label:"baudrate" int64) + @ (required ~label:"input_packets" int64) + @ (required ~label:"input_errors" int64) + @ (required ~label:"output_packets" int64) + @ (required ~label:"output_errors" int64) + @ (required ~label:"collisions" int64) + @ (required ~label:"input_bytes" int64) + @ (required ~label:"output_bytes" int64) + @ (required ~label:"input_mcast" int64) + @ (required ~label:"output_mcast" int64) + @ (required ~label:"input_dropped" int64) + -@ (required ~label:"output_dropped" int64)) + +type stats_cmd = [ + | `Stats_add of int * string list + | `Stats_remove + | `Stats_subscribe + | `Stats_data of rusage * (string * int64) list * ifdata list +] + +let pp_stats_cmd ppf = function + | `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps + | `Stats_remove -> Fmt.string ppf "stat remove" + | `Stats_subscribe -> Fmt.string ppf "stat subscribe" + | `Stats_data (ru, vmm, ifs) -> Fmt.pf ppf "stats data: %a %a %a" + pp_rusage ru + pp_vmm vmm + Fmt.(list ~sep:(unit "@.@.") pp_ifdata) ifs + +let stats_cmd = + let f = function + | `C1 (pid, taps) -> `Stats_add (pid, taps) + | `C2 () -> `Stats_remove + | `C3 () -> `Stats_subscribe + | `C4 (ru, vmm, ifdata) -> + let vmm = match vmm with None -> [] | Some vmm -> vmm + and ifdata = match ifdata with None -> [] | Some ifs -> ifs + in + `Stats_data (ru, vmm, ifdata) + and g = function + | `Stats_add (pid, taps) -> `C1 (pid, taps) + | `Stats_remove -> `C2 () + | `Stats_subscribe -> `C3 () + | `Stats_data (ru, vmm, ifdata) -> + let vmm = match vmm with [] -> None | xs -> Some xs + and ifs = match ifdata with [] -> None | xs -> Some xs + in + `C4 (ru, vmm, ifs) + in + Asn.S.map f g @@ + Asn.S.(choice4 + (explicit 0 (sequence2 + (required ~label:"pid" int) + (required ~label:"taps" (sequence_of utf8_string)))) + (explicit 1 null) + (explicit 2 null) + (explicit 3 (sequence3 + (required ~label:"resource_usage" ru) + (optional ~label:"vmm_stats" @@ explicit 0 + (sequence_of (sequence2 + (required ~label:"key" utf8_string) + (required ~label:"value" int64)))) + (optional ~label:"ifdata" @@ explicit 1 + (sequence_of ifdata))))) + +let addr = + Asn.S.(sequence2 + (required ~label:"ip" ipv4) + (required ~label:"port" int)) + +let log_event = + let f = function + | `C1 () -> `Startup + | `C2 (ip, port) -> `Login (ip, port) + | `C3 (ip, port) -> `Logout (ip, port) + | `C4 (pid, taps, block) -> `VM_start (pid, taps, block) + | `C5 (pid, status) -> + let status' = match status with + | `C1 n -> `Exit n + | `C2 n -> `Signal n + | `C3 n -> `Stop n + in + `VM_stop (pid, status') + and g = function + | `Startup -> `C1 () + | `Login (ip, port) -> `C2 (ip, port) + | `Logout (ip, port) -> `C3 (ip, port) + | `VM_start (pid, taps, block) -> `C4 (pid, taps, block) + | `VM_stop (pid, status) -> + let status' = match status with + | `Exit n -> `C1 n + | `Signal n -> `C2 n + | `Stop n -> `C3 n + in + `C5 (pid, status') + in + Asn.S.map f g @@ + Asn.S.(choice5 + (explicit 0 null) + (explicit 1 addr) + (explicit 2 addr) + (explicit 3 (sequence3 + (required ~label:"pid" int) + (required ~label:"taps" (sequence_of utf8_string)) + (optional ~label:"block" utf8_string))) + (explicit 4 (sequence2 + (required ~label:"pid" int) + (required ~label:"status" (choice3 + (explicit 0 int) + (explicit 1 int) + (explicit 2 int)))))) + +type log_cmd = [ + | `Log_data of Ptime.t * Log.event + | `Log_subscribe +] + +let pp_log_cmd ppf = function + | `Log_data (ts, event) -> Fmt.pf ppf "log data: %a %a" (Ptime.pp_rfc3339 ()) ts Log.pp_event event + | `Log_subscribe -> Fmt.string ppf "log subscribe" + +let log_cmd = + let f = function + | `C1 (timestamp, event) -> `Log_data (timestamp, event) + | `C2 () -> `Log_subscribe + and g = function + | `Log_data (timestamp, event) -> `C1 (timestamp, event) + | `Log_subscribe -> `C2 () + in + Asn.S.map f g @@ + Asn.S.(choice2 + (explicit 0 (sequence2 + (required ~label:"timestamp" utc_time) + (required ~label:"event" log_event))) + (explicit 1 null)) + +type vm_cmd = [ + | `Vm_info + | `Vm_create of vm_config + | `Vm_force_create of vm_config + | `Vm_destroy +] + +let pp_vm_cmd ppf = function + | `Vm_info -> Fmt.string ppf "vm info" + | `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config + | `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config + | `Vm_destroy -> Fmt.string ppf "vm destroy" + +let vm_config = + let f (cpuid, requested_memory, block_device, network, vmimage, argv) = + let network = match network with None -> [] | Some xs -> xs in + { vname = [] ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } + and g vm = + let network = match vm.network with [] -> None | xs -> Some xs in + (vm.cpuid, vm.requested_memory, vm.block_device, network, vm.vmimage, vm.argv) + in + Asn.S.map f g @@ + Asn.S.(sequence6 + (required ~label:"cpu" int) + (required ~label:"memory" int) + (optional ~label:"block" utf8_string) + (optional ~label:"bridges" (sequence_of utf8_string)) + (required ~label:"vmimage" image) + (optional ~label:"arguments" (sequence_of utf8_string))) + +let vm_cmd = + let f = function + | `C1 () -> `Vm_info + | `C2 vm -> `Vm_create vm + | `C3 vm -> `Vm_force_create vm + | `C4 () -> `Vm_destroy + and g = function + | `Vm_info -> `C1 () + | `Vm_create vm -> `C2 vm + | `Vm_force_create vm -> `C3 vm + | `Vm_destroy -> `C4 () + in + Asn.S.map f g @@ + Asn.S.(choice4 + (explicit 0 null) + (explicit 1 vm_config) + (explicit 2 vm_config) + (explicit 3 null)) + +type policy_cmd = [ + | `Policy_info + | `Policy_add of policy + | `Policy_remove +] + +let pp_policy_cmd ppf = function + | `Policy_info -> Fmt.string ppf "policy info" + | `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy + | `Policy_remove -> Fmt.string ppf "policy remove" + +let policy_cmd = + let f = function + | `C1 () -> `Policy_info + | `C2 policy -> `Policy_add policy + | `C3 () -> `Policy_remove + and g = function + | `Policy_info -> `C1 () + | `Policy_add policy -> `C2 policy + | `Policy_remove -> `C3 () + in + Asn.S.map f g @@ + Asn.S.(choice3 + (explicit 0 null) + (explicit 1 policy_obj) + (explicit 2 null)) + +let version = + let f data = match version_of_int data with + | Ok v -> v + | Error (`Msg m) -> Asn.S.error (`Parse m) + and g = version_to_int + in + Asn.S.map f g Asn.S.int + +type wire_command = [ + | `Console_cmd of console_cmd + | `Stats_cmd of stats_cmd + | `Log_cmd of log_cmd + | `Vm_cmd of vm_cmd + | `Policy_cmd of policy_cmd + ] + +let pp_wire_command ppf = function + | `Console_cmd c -> pp_console_cmd ppf c + | `Stats_cmd s -> pp_stats_cmd ppf s + | `Log_cmd l -> pp_log_cmd ppf l + | `Vm_cmd v -> pp_vm_cmd ppf v + | `Policy_cmd p -> pp_policy_cmd ppf p + +let wire_command : wire_command Asn.S.t = + let f = function + | `C1 console -> `Console_cmd console + | `C2 stats -> `Stats_cmd stats + | `C3 log -> `Log_cmd log + | `C4 vm -> `Vm_cmd vm + | `C5 policy -> `Policy_cmd policy + and g = function + | `Console_cmd c -> `C1 c + | `Stats_cmd c -> `C2 c + | `Log_cmd c -> `C3 c + | `Vm_cmd c -> `C4 c + | `Policy_cmd c -> `C5 c + in + Asn.S.map f g @@ + Asn.S.(choice5 + (explicit 0 console_cmd) + (explicit 1 stats_cmd) + (explicit 2 log_cmd) + (explicit 3 vm_cmd) + (explicit 4 policy_cmd)) + +type header = { + version : version ; + sequence : int64 ; + id : id ; +} + +let header = + let f (version, sequence, id) = { version ; sequence ; id } + and g h = h.version, h.sequence, h.id + in + Asn.S.map f g @@ + Asn.S.(sequence3 + (required ~label:"version" version) + (required ~label:"sequence" int64) + (required ~label:"id" (sequence_of utf8_string))) + +type success = [ `Empty | `String of string | `Policies of policy list | `Vms of vm_config list ] + +let pp_success ppf = function + | `Empty -> Fmt.string ppf "success" + | `String data -> Fmt.pf ppf "success: %s" data + | `Policies ps -> Fmt.(list ~sep:(unit "@.") pp_policy) ppf ps + | `Vms vms -> Fmt.(list ~sep:(unit "@.") pp_vm_config) ppf vms + +type wire = header * [ + | `Command of wire_command + | `Success of success + | `Failure of string ] + +let pp_wire ppf (header, data) = + let id = header.id in + match data with + | `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp_wire_command c + | `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f + | `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s + +let wire = + let f (header, payload) = + header, + match payload with + | `C1 cmd -> `Command cmd + | `C2 data -> + let p = match data with + | `C1 () -> `Empty + | `C2 str -> `String str + | `C3 policies -> `Policies policies + | `C4 vms -> `Vms vms + in + `Success p + | `C3 str -> `Failure str + and g (header, payload) = + header, + match payload with + | `Command cmd -> `C1 cmd + | `Success data -> + let p = match data with + | `Empty -> `C1 () + | `String s -> `C2 s + | `Policies ps -> `C3 ps + | `Vms vms -> `C4 vms + in + `C2 p + | `Failure str -> `C3 str + in + Asn.S.map f g @@ + Asn.S.(sequence2 + (required ~label:"header" header) + (required ~label:"payload" + (choice3 + (explicit 0 wire_command) + (explicit 1 (choice4 + (explicit 0 null) + (explicit 1 utf8_string) + (explicit 2 (sequence_of policy_obj)) + (explicit 3 (sequence_of vm_config)))) + (explicit 2 utf8_string)))) + +let wire_of_cstruct, wire_to_cstruct = projections_of wire + +type log_entry = header * Ptime.t * Log.event + +let log_entry = + Asn.S.(sequence3 + (required ~label:"headet" header) + (required ~label:"timestamp" utc_time) + (required ~label:"event" log_event)) + +let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index f44b3e1..9094932 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -75,7 +75,7 @@ end (** {1 Encoding and decoding functions} *) (** The type of versions of the ASN.1 grammar defined above. *) -type version = [ `AV0 | `AV1 ] +type version = [ `AV0 | `AV1 | `AV2 ] (** [version_eq a b] is true if [a] and [b] are equal. *) val version_eq : version -> version -> bool @@ -171,3 +171,66 @@ val block_device_of_cert : version -> X509.t -> (string, [> `Msg of string ]) re (** [block_size_of_cert version cert] is either the decoded block size, or an error. *) val block_size_of_cert : version -> X509.t -> (int, [> `Msg of string ]) result + +open Vmm_core +type console_cmd = [ + | `Console_add + | `Console_subscribe + | `Console_data of Ptime.t * string +] + +type stats_cmd = [ + | `Stats_add of int * string list + | `Stats_remove + | `Stats_subscribe + | `Stats_data of rusage * (string * int64) list * ifdata list +] + +type log_cmd = [ + | `Log_data of Ptime.t * Log.event + | `Log_subscribe +] + +type vm_cmd = [ + | `Vm_info + | `Vm_create of vm_config + | `Vm_force_create of vm_config + | `Vm_destroy +] + +type policy_cmd = [ + | `Policy_info + | `Policy_add of policy + | `Policy_remove +] + +type wire_command = [ + | `Console_cmd of console_cmd + | `Stats_cmd of stats_cmd + | `Log_cmd of log_cmd + | `Vm_cmd of vm_cmd + | `Policy_cmd of policy_cmd ] + +type header = { + version : version ; + sequence : int64 ; + id : id ; +} + +type wire = header * [ + | `Command of wire_command + | `Success of [ `Empty | `String of string | `Policies of policy list | `Vms of vm_config list ] + | `Failure of string ] + +val pp_wire : wire Fmt.t + +val wire_to_cstruct : wire -> Cstruct.t + +val wire_of_cstruct : Cstruct.t -> (wire, [> `Msg of string ]) result + +type log_entry = header * Ptime.t * Log.event + +val log_entry_to_cstruct : log_entry -> Cstruct.t + +val log_entry_of_cstruct : Cstruct.t -> (log_entry, [> `Msg of string ]) result + diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index f8bedc3..f10f4c9 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -2,123 +2,9 @@ open Vmm_core -let c = 0L -let ver = `WV2 - -type t = [ - | `Info of id - | `Policy of id - | `Add_policy of id * policy - | `Remove_policy of id - | `Create_vm of vm_config - | `Force_create_vm of vm_config - | `Destroy_vm of id - | `Statistics of id - | `Console of id - | `Log of id - | `Crl (* TODO *) - | `Create_block of id * int - | `Destroy_block of id -] - let handle = function - | `Info name -> - let cmd = Vmm_wire.Vm.info c ver name in - `Vmmd, `End, cmd - | `Policy name -> - let cmd = Vmm_wire.Vm.policy c ver name in - `Vmmd, `End, cmd - | `Remove_policy name -> - let cmd = Vmm_wire.Vm.remove_policy c ver name in - `Vmmd, `End, cmd - | `Add_policy (name, policy) -> - let cmd = Vmm_wire.Vm.insert_policy c ver name policy in - `Vmmd, `End, cmd - | `Create_vm vm -> - let cmd = Vmm_wire.Vm.create c ver vm in - `Vmmd, `End, cmd - | `Force_create_vm vm -> - let cmd = Vmm_wire.Vm.force_create c ver vm in - `Vmmd, `End, cmd - | `Destroy_vm name -> - let cmd = Vmm_wire.Vm.destroy c ver name in - `Vmmd, `End, cmd - | `Statistics name -> - let cmd = Vmm_wire.Stats.subscribe c ver name in - `Stats, `Read, cmd - | `Console name -> - let cmd = Vmm_wire.Console.attach c ver name in - `Console, `Read, cmd - | `Log name -> - let cmd = Vmm_wire.Log.subscribe c ver name in - `Log, `Read, cmd - | `Crl -> assert false - | `Create_block (_name, _size) -> assert false - | `Destroy_block _name -> assert false - -let handle_reply (hdr, data) = - if not (Vmm_wire.version_eq hdr.Vmm_wire.version ver) then - Error (`Msg "unknown wire protocol version") - else - if Vmm_wire.is_fail hdr then - let msg = match Vmm_wire.decode_string data with - | Ok (msg, _) -> msg - | Error _ -> "" - in - Error (`Msg ("command failed " ^ msg)) - else if Vmm_wire.is_reply hdr && hdr.Vmm_wire.id = c then - Ok (hdr, data) - else - Error (`Msg "received unexpected data") - -let log_pp_reply (hdr, data) = - let open Vmm_wire in - let tag' = Int32.logxor reply_tag hdr.tag in - let open Rresult.R.Infix in - match Vm.int_to_op tag' with - | Some Vm.Info -> - Vm.decode_vms data >>| fun (vms, _) -> - List.iter (fun (id, memory, cmd, pid, taps) -> - Logs.app (fun m -> m "VM %a %dMB command %s pid %d taps %a" - pp_id id memory cmd pid Fmt.(list ~sep:(unit ", ") string) taps)) - vms - | Some Vm.Policy -> - Vm.decode_policies data >>| fun (policies, _) -> - List.iter (fun (id, policy) -> - Logs.app (fun m -> m "policy %a: %a" pp_id id pp_policy policy)) - policies - | Some Vm.Insert_policy -> - Ok (Logs.app (fun m -> m "added policy")) - | Some Vm.Remove_policy -> - Ok (Logs.app (fun m -> m "removed policy")) - | Some Vm.Destroy -> - Ok (Logs.app (fun m -> m "destroyed VM")) - | Some Vm.Create -> - Ok (Logs.app (fun m -> m "successfully started VM")) - | Some Vm.Force_create -> - Ok (Logs.app (fun m -> m "successfully forcefully started VM")) - | None -> match Console.int_to_op tag' with - | Some Console.Data -> - decode_id_ts data >>= fun ((name, ts), off) -> - decode_string (Cstruct.shift data off) >>| fun (msg, _) -> - Logs.app (fun m -> m "%a %a: %s" Ptime.pp ts pp_id name msg) - | Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) - | None -> match Stats.int_to_op tag' with - | Some Stats.Data -> - decode_strings data >>= fun (name', off) -> - Stats.decode_stats (Cstruct.shift data off) >>| fun (ru, vmm, ifs) -> - Logs.app (fun m -> m "stats %a@.%a@.%a@.%a@." - pp_id name' pp_rusage ru - Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) vmm - Fmt.(list ~sep:(unit "@.") pp_ifdata) ifs) - | Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) - | None -> match Log.int_to_op tag' with - | Some Log.Broadcast -> - Log.decode_log_hdr data >>= fun (loghdr, logdata) -> - Log.decode_event logdata >>| fun event -> - Logs.app (fun m -> m "%a" Vmm_core.Log.pp (loghdr, event)) - | Some _ -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) - | None -> Error (`Msg (Printf.sprintf "unknown operation %lx" hdr.tag)) - - - + | `Vm_cmd _ -> `Vmmd, `End + | `Policy_cmd _ -> `Vmmd, `End + | `Stats_cmd _ -> `Stats, `Read + | `Console_cmd _ -> `Console, `Read + | `Log_cmd _ -> `Log, `Read diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli new file mode 100644 index 0000000..f242239 --- /dev/null +++ b/src/vmm_commands.mli @@ -0,0 +1,7 @@ +val handle : + [< `Console_cmd of 'a + | `Log_cmd of 'b + | `Policy_cmd of 'c + | `Stats_cmd of 'd + | `Vm_cmd of 'e ] -> + [> `Console | `Log | `Stats | `Vmmd ] * [> `End | `Read ] diff --git a/src/vmm_compress.mli b/src/vmm_compress.mli new file mode 100644 index 0000000..cfceea6 --- /dev/null +++ b/src/vmm_compress.mli @@ -0,0 +1,2 @@ +val compress : ?level:int -> string -> string +val uncompress : string -> (string, unit) result diff --git a/src/vmm_core.ml b/src/vmm_core.ml index c4d2ae4..e58e95f 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -295,6 +295,9 @@ let pp_rusage ppf r = Fmt.pf ppf "utime %Lu.%d stime %Lu.%d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu" (fst r.utime) (snd r.utime) (fst r.stime) (snd r.stime) r.maxrss r.ixrss r.idrss r.isrss r.minflt r.majflt r.nswap r.inblock r.outblock r.msgsnd r.msgrcv r.nsignals r.nvcsw r.nivcsw +let pp_vmm ppf vmm = + Fmt.(list ~sep:(unit "@,") (pair ~sep:(unit ": ") string int64)) ppf vmm + type ifdata = { name : string ; flags : int32 ; @@ -321,16 +324,6 @@ let pp_ifdata ppf i = i.name i.flags i.send_length i.max_send_length i.send_drops i.mtu i.baudrate i.input_packets i.input_errors i.output_packets i.output_errors i.collisions i.input_bytes i.output_bytes i.input_mcast i.output_mcast i.input_dropped i.output_dropped module Log = struct - type hdr = { - ts : Ptime.t ; - name : id ; - } - - let pp_hdr ppf (hdr : hdr) = - Fmt.pf ppf "%a: %a" (Ptime.pp_rfc3339 ()) hdr.ts pp_id hdr.name - - let hdr name = { ts = Ptime_clock.now () ; name } - type event = [ `Startup | `Login of Ipaddr.V4.t * int @@ -354,9 +347,4 @@ module Log = struct | `Stop n -> "stop", n in Fmt.pf ppf "STOPPED %d with %s %a" pid s Fmt.Dump.signal c - - type msg = hdr * event - - let pp ppf (hdr, event) = - Fmt.pf ppf "%a %a" pp_hdr hdr pp_event event end diff --git a/src/vmm_core.mli b/src/vmm_core.mli new file mode 100644 index 0000000..6c0bd83 --- /dev/null +++ b/src/vmm_core.mli @@ -0,0 +1,304 @@ +val tmpdir : Fpath.t +val dbdir : Fpath.t +val socket_path : [< `Console | `Log | `Stats | `Vmmd ] -> string +val pp_socket : + Format.formatter -> [< `Console | `Log | `Stats | `Vmmd ] -> unit +module I : sig type t = int val compare : int -> int -> int end +module IS : + sig + type elt = I.t + type t = Set.Make(I).t + val empty : t + val is_empty : t -> bool + val mem : elt -> t -> bool + val add : elt -> t -> t + val singleton : elt -> t + val remove : elt -> t -> t + val union : t -> t -> t + val inter : t -> t -> t + val diff : t -> t -> t + val compare : t -> t -> int + val equal : t -> t -> bool + val subset : t -> t -> bool + val iter : (elt -> unit) -> t -> unit + val map : (elt -> elt) -> t -> t + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (elt -> bool) -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t + val partition : (elt -> bool) -> t -> t * t + val cardinal : t -> int + val elements : t -> elt list + val min_elt : t -> elt + val min_elt_opt : t -> elt option + val max_elt : t -> elt + val max_elt_opt : t -> elt option + val choose : t -> elt + val choose_opt : t -> elt option + val split : elt -> t -> t * bool * t + val find : elt -> t -> elt + val find_opt : elt -> t -> elt option + val find_first : (elt -> bool) -> t -> elt + val find_first_opt : (elt -> bool) -> t -> elt option + val find_last : (elt -> bool) -> t -> elt + val find_last_opt : (elt -> bool) -> t -> elt option + val of_list : elt list -> t + end +module IM : + sig + type key = I.t + type 'a t = 'a Map.Make(I).t + val empty : 'a t + val is_empty : 'a t -> bool + val mem : key -> 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + val singleton : key -> 'a -> 'a t + val remove : key -> 'a t -> 'a t + val merge : + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all : (key -> 'a -> bool) -> 'a t -> bool + val exists : (key -> 'a -> bool) -> 'a t -> bool + val filter : (key -> 'a -> bool) -> 'a t -> 'a t + val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal : 'a t -> int + val bindings : 'a t -> (key * 'a) list + val min_binding : 'a t -> key * 'a + val min_binding_opt : 'a t -> (key * 'a) option + val max_binding : 'a t -> key * 'a + val max_binding_opt : 'a t -> (key * 'a) option + val choose : 'a t -> key * 'a + val choose_opt : 'a t -> (key * 'a) option + val split : key -> 'a t -> 'a t * 'a option * 'a t + val find : key -> 'a t -> 'a + val find_opt : key -> 'a t -> 'a option + val find_first : (key -> bool) -> 'a t -> key * 'a + val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option + val find_last : (key -> bool) -> 'a t -> key * 'a + val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option + val map : ('a -> 'b) -> 'a t -> 'b t + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t + end +module IM64 : + sig + type key = Int64.t + type 'a t = 'a Map.Make(Int64).t + val empty : 'a t + val is_empty : 'a t -> bool + val mem : key -> 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + val singleton : key -> 'a -> 'a t + val remove : key -> 'a t -> 'a t + val merge : + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all : (key -> 'a -> bool) -> 'a t -> bool + val exists : (key -> 'a -> bool) -> 'a t -> bool + val filter : (key -> 'a -> bool) -> 'a t -> 'a t + val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal : 'a t -> int + val bindings : 'a t -> (key * 'a) list + val min_binding : 'a t -> key * 'a + val min_binding_opt : 'a t -> (key * 'a) option + val max_binding : 'a t -> key * 'a + val max_binding_opt : 'a t -> (key * 'a) option + val choose : 'a t -> key * 'a + val choose_opt : 'a t -> (key * 'a) option + val split : key -> 'a t -> 'a t * 'a option * 'a t + val find : key -> 'a t -> 'a + val find_opt : key -> 'a t -> 'a option + val find_first : (key -> bool) -> 'a t -> key * 'a + val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option + val find_last : (key -> bool) -> 'a t -> key * 'a + val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option + val map : ('a -> 'b) -> 'a t -> 'b t + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t + end +type command = + [ `Console + | `Create_block + | `Create_vm + | `Crl + | `Destroy_block + | `Destroy_vm + | `Force_create_vm + | `Info + | `Log + | `Statistics ] +val pp_command : + Format.formatter -> + [< `Console + | `Create_block + | `Create_vm + | `Crl + | `Destroy_block + | `Destroy_vm + | `Force_create_vm + | `Info + | `Log + | `Statistics ] -> + unit +val command_of_string : + string -> + [> `Console + | `Create_block + | `Create_vm + | `Crl + | `Destroy_block + | `Destroy_vm + | `Force_create_vm + | `Info + | `Log + | `Statistics ] + option +type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] +val vmtype_to_int : + [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -> int +val int_to_vmtype : + int -> [> `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] option +val pp_vmtype : + Format.formatter -> + [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -> unit +type id = string list +val string_of_id : string list -> string +val id_of_string : string -> string list +val drop_super : super:string list -> sub:string list -> string list option +val is_sub_id : super:string list -> sub:string list -> bool +val domain : 'a list -> 'a list +val pp_id : Format.formatter -> string list -> unit +val pp_is : Format.formatter -> IS.t -> unit +type bridge = + [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int + | `Internal of string ] +val pp_bridge : + Format.formatter -> + [< `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int + | `Internal of string ] -> + unit +type policy = { + vms : int; + cpuids : IS.t; + memory : int; + block : int option; + bridges : bridge Astring.String.Map.t; +} +val pp_policy : Format.formatter -> policy -> unit +val sub_bridges : + [> `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * 'a + | `Internal of string ] + Astring.String.map -> + [> `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * 'a + | `Internal of string ] + Astring.String.map -> bool +val sub_block : 'a option -> 'a option -> bool +val sub_cpu : IS.t -> IS.t -> bool +val is_sub : super:policy -> sub:policy -> bool +type vm_config = { + vname : id; + cpuid : int; + requested_memory : int; + block_device : string option; + network : string list; + vmimage : vmtype * Cstruct.t; + argv : string list option; +} +val location : vm_config -> string * string +val pp_image : + Format.formatter -> + [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] * Cstruct.t -> unit +val pp_vm_config : Format.formatter -> vm_config -> unit +val good_bridge : string list -> 'a Astring.String.map -> bool +val vm_matches_res : policy -> vm_config -> bool +val check_policies : + vm_config -> policy list -> (unit, [> `Msg of string ]) Result.result +type vm = { + config : vm_config; + cmd : Bos.Cmd.t; + pid : int; + taps : string list; + stdout : Unix.file_descr; +} +val pp_vm : Format.formatter -> vm -> unit +val translate_tap : vm -> string -> string option +val identifier : Nocrypto.Numeric.Z.t -> string +val id : X509.t -> string +val name : X509.t -> string +val parse_db : + string list -> ((Z.t * string) list, [> Rresult.R.msg ]) Result.result +val find_in_db : + string -> 'a list -> ('a -> bool) -> ('a, [> Rresult.R.msg ]) Result.result +val find_name : + ('a * string) list -> string -> ('a, [> Rresult.R.msg ]) Result.result +val translate_serial : + (Nocrypto.Numeric.Z.t * string) list -> string -> string +val translate_name : (Nocrypto.Numeric.Z.t * string) list -> string -> string +val separate_chain : 'a list -> ('a * 'a list, [> `Msg of string ]) result +type rusage = { + utime : int64 * int; + stime : int64 * int; + maxrss : int64; + ixrss : int64; + idrss : int64; + isrss : int64; + minflt : int64; + majflt : int64; + nswap : int64; + inblock : int64; + outblock : int64; + msgsnd : int64; + msgrcv : int64; + nsignals : int64; + nvcsw : int64; + nivcsw : int64; +} +val pp_rusage : Format.formatter -> rusage -> unit +val pp_vmm : (string * int64) list Fmt.t + +type ifdata = { + name : string; + flags : int32; + send_length : int32; + max_send_length : int32; + send_drops : int32; + mtu : int32; + baudrate : int64; + input_packets : int64; + input_errors : int64; + output_packets : int64; + output_errors : int64; + collisions : int64; + input_bytes : int64; + output_bytes : int64; + input_mcast : int64; + output_mcast : int64; + input_dropped : int64; + output_dropped : int64; +} +val pp_ifdata : Format.formatter -> ifdata -> unit +module Log : + sig + type event = + [ `Login of Ipaddr.V4.t * int + | `Logout of Ipaddr.V4.t * int + | `Startup + | `VM_start of int * string list * string option + | `VM_stop of int * [ `Exit of int | `Signal of int | `Stop of int ] ] + val pp_event : + Format.formatter -> + [< `Login of Ipaddr.V4.t * int + | `Logout of Ipaddr.V4.t * int + | `Startup + | `VM_start of int * string list * string option + | `VM_stop of int * [< `Exit of int | `Signal of int | `Stop of int ] ] -> + unit + end diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index cf52778..af9c47b 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -8,13 +8,10 @@ open Rresult open R.Infix type 'a t = { + wire_version : Vmm_asn.version ; console_counter : int64 ; - console_version : Vmm_wire.version ; stats_counter : int64 ; - stats_version : Vmm_wire.version ; log_counter : int64 ; - log_version : Vmm_wire.version ; - client_version : Vmm_wire.version ; (* TODO: refine, maybe: bridges : (Macaddr.t String.Map.t * String.Set.t) String.Map.t ; *) used_bridges : String.Set.t String.Map.t ; @@ -23,23 +20,34 @@ type 'a t = { tasks : 'a String.Map.t ; } -let init () = { - console_counter = 1L ; console_version = `WV2 ; - stats_counter = 1L ; stats_version = `WV2 ; - log_counter = 1L ; log_version = `WV2 ; - client_version = `WV2 ; +let init wire_version = { + wire_version ; + console_counter = 1L ; + stats_counter = 1L ; + log_counter = 1L ; used_bridges = String.Map.empty ; resources = Vmm_resources.empty ; tasks = String.Map.empty ; } -let log state (hdr, event) = - let data = Vmm_wire.Log.log state.log_counter state.log_version hdr event in - let log_counter = Int64.succ state.log_counter in - Logs.debug (fun m -> m "LOG %a" Log.pp (hdr, event)) ; - ({ state with log_counter }, `Log data) +type service_out = [ + | `Stat of Vmm_asn.wire + | `Log of Vmm_asn.wire + | `Cons of Vmm_asn.wire +] + +type out = [ service_out | `Data of Vmm_asn.wire ] + +let log t id event = + let data = `Log_data (Ptime_clock.now (), event) in + let header = Vmm_asn.{ version = t.wire_version ; sequence = t.log_counter ; id } in + let log_counter = Int64.succ t.log_counter in + Logs.debug (fun m -> m "LOG %a" Log.pp_event event) ; + ({ t with log_counter }, `Log (header, `Command (`Log_cmd data))) let handle_create t hdr vm_config = + (* TODO fix (remove field?) *) + let vm_config = { vm_config with vname = hdr.Vmm_asn.id } in (match Vmm_resources.find_vm t.resources vm_config.vname with | Some _ -> Error (`Msg "VM with same name is already running") | None -> Ok ()) >>= fun () -> @@ -52,8 +60,9 @@ let handle_create t hdr vm_config = Vmm_unix.prepare vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; (* TODO should we pre-reserve sth in t? *) - let cons = Vmm_wire.Console.add t.console_counter t.console_version vm_config.vname in - Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons ], + let cons = `Console_add in + let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = vm_config.vname } in + Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons (header, `Command (`Console_cmd cons)) ], `Create (fun t task -> (* actually execute the vm *) Vmm_unix.exec vm_config taps >>= fun vm -> @@ -70,14 +79,15 @@ let handle_create t hdr vm_config = t.used_bridges vm_config.network taps in let t = { t with resources ; tasks ; used_bridges } in - let t, out = log t (Log.hdr vm_config.vname, `VM_start (vm.pid, vm.taps, None)) in - let data = Vmm_wire.success t.client_version hdr.Vmm_wire.id Vmm_wire.Vm.(op_to_int Create) in - Ok (t, [ `Data data ; out ], vm))) + let t, out = log t vm_config.vname (`VM_start (vm.pid, vm.taps, None)) in + let data = `Success (`String "created VM") in + Ok (t, [ `Data (hdr, data) ; out ], vm))) let setup_stats t vm = - let stat_out = Vmm_wire.Stats.add t.stats_counter t.stats_version vm.config.vname vm.pid vm.taps in + let stat_out = `Stats_add (vm.pid, vm.taps) in + let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = vm.config.vname } in let t = { t with stats_counter = Int64.succ t.stats_counter } in - Ok (t, [ `Stat stat_out ]) + t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ] let handle_shutdown t vm r = (match Vmm_unix.shutdown vm with @@ -93,61 +103,56 @@ let handle_shutdown t vm r = String.Map.add br (String.Set.remove ta old) b) t.used_bridges vm.config.network vm.taps in - let stat_out = Vmm_wire.Stats.remove t.stats_counter t.stats_version vm.config.vname in + let stat_out = `Stats_remove in + let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = vm.config.vname } in let tasks = String.Map.remove (string_of_id vm.config.vname) t.tasks in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in - let t, logout = log t (Log.hdr vm.config.vname, `VM_stop (vm.pid, r)) + let t, logout = log t vm.config.vname (`VM_stop (vm.pid, r)) in - (t, [ `Stat stat_out ; logout ]) + (t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ; logout ]) -let handle_command t hdr buf = +let handle_command t (header, payload) = let msg_to_err = function | Ok x -> x | Error (`Msg msg) -> Logs.debug (fun m -> m "error while processing command: %s" msg) ; - let out = Vmm_wire.fail ~msg t.client_version hdr.Vmm_wire.id in - (t, [ `Data out ], `End) + let out = `Failure msg in + (t, [ `Data (header, out) ], `End) in msg_to_err ( - if Vmm_wire.is_reply hdr then begin - Logs.warn (fun m -> m "ignoring reply") ; + let id = header.Vmm_asn.id in + match payload with + | `Failure f -> + Logs.warn (fun m -> m "ignoring failure %s" f) ; Ok (t, [], `End) - end else if not (Vmm_wire.version_eq hdr.Vmm_wire.version t.client_version) then - Error (`Msg "unknown client version") - else Vmm_wire.decode_strings buf >>= fun (id, off) -> - match Vmm_wire.Vm.int_to_op hdr.Vmm_wire.tag with - | None -> Error (`Msg "unknown command") - | Some Vmm_wire.Vm.Remove_policy -> - Logs.debug (fun m -> m "remove policy %a" pp_id id) ; - let resources = Vmm_resources.remove t.resources id in - let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in - Ok ({ t with resources }, [ `Data success ], `End) - | Some Vmm_wire.Vm.Insert_policy -> - begin - Logs.debug (fun m -> m "insert policy %a" pp_id id) ; - Vmm_asn.policy_of_cstruct (Cstruct.shift buf off) >>= fun (policy, _) -> - Vmm_resources.insert_policy t.resources id policy >>= fun resources -> - let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in - Ok ({ t with resources }, [ `Data success ], `End) - end - | Some Vmm_wire.Vm.Policy -> - begin - Logs.debug (fun m -> m "policy %a" pp_id id) ; - let policies = - Vmm_resources.fold t.resources id - (fun _ policies -> policies) - (fun prefix policy policies-> (prefix, policy) :: policies) - [] - in - match policies with - | [] -> - Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ; - Error (`Msg "policy: not found") - | _ -> - let out = Vmm_wire.Vm.policy_reply hdr.Vmm_wire.id t.client_version policies in - Ok (t, [ `Data out ], `End) - end - | Some Vmm_wire.Vm.Info -> + | `Success _ -> + Logs.warn (fun m -> m "ignoring success") ; + Ok (t, [], `End) + | `Command (`Policy_cmd `Policy_remove) -> + Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_asn.id) ; + let resources = Vmm_resources.remove t.resources id in + Ok ({ t with resources }, [ `Data (header, `Success (`String "removed policy")) ], `End) + | `Command (`Policy_cmd (`Policy_add policy)) -> + Logs.debug (fun m -> m "insert policy %a" pp_id id) ; + Vmm_resources.insert_policy t.resources id policy >>= fun resources -> + Ok ({ t with resources }, [ `Data (header, `Success (`String "added policy")) ], `End) + | `Command (`Policy_cmd `Policy_info) -> + begin + Logs.debug (fun m -> m "policy %a" pp_id id) ; + let policies = + Vmm_resources.fold t.resources id + (fun _ policies -> policies) + (fun prefix policy policies-> (prefix, policy) :: policies) + [] + in + match policies with + | [] -> + Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ; + Error (`Msg "policy: not found") + | _ -> + Ok (t, [ `Data (header, `Success (`Policies policies)) ], `End) + end + | `Command (`Vm_cmd `Vm_info) -> begin Logs.debug (fun m -> m "info %a" pp_id id) ; let vms = @@ -161,44 +166,42 @@ let handle_command t hdr buf = Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ; Error (`Msg "info: not found") | _ -> - let out = Vmm_wire.Vm.info_reply hdr.Vmm_wire.id t.client_version vms in - Ok (t, [ `Data out ], `End) + let vm_configs = List.map (fun vm -> vm.config) vms in + Ok (t, [ `Data (header, `Success (`Vms vm_configs)) ], `End) end - | Some Vmm_wire.Vm.Create -> - Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config -> - handle_create t hdr vm_config - | Some Vmm_wire.Vm.Force_create -> - Vmm_wire.Vm.decode_vm_config buf >>= fun vm_config -> - let resources = Vmm_resources.remove t.resources vm_config.vname in - if Vmm_resources.check_vm_policy resources vm_config then - begin match Vmm_resources.find_vm t.resources id with - | None -> handle_create t hdr vm_config - | Some vm -> - Vmm_unix.destroy vm ; - let id_str = string_of_id id in - match String.Map.find_opt id_str t.tasks with - | None -> handle_create t hdr vm_config - | Some task -> - let tasks = String.Map.remove id_str t.tasks in - let t = { t with tasks } in - Ok (t, [], `Wait_and_create - (t, task, fun t -> - msg_to_err @@ handle_create t hdr vm_config)) - end - else - Error (`Msg "wouldn't match policy") - | Some Vmm_wire.Vm.Destroy -> - match Vmm_resources.find_vm t.resources id with + | `Command (`Vm_cmd (`Vm_create vm_config)) -> + handle_create t header vm_config + | `Command (`Vm_cmd (`Vm_force_create vm_config)) -> + let resources = Vmm_resources.remove t.resources vm_config.vname in + if Vmm_resources.check_vm_policy resources vm_config then + begin match Vmm_resources.find_vm t.resources id with + | None -> handle_create t header vm_config + | Some vm -> + Vmm_unix.destroy vm ; + let id_str = string_of_id id in + match String.Map.find_opt id_str t.tasks with + | None -> handle_create t header vm_config + | Some task -> + let tasks = String.Map.remove id_str t.tasks in + let t = { t with tasks } in + Ok (t, [], `Wait_and_create + (task, fun t -> msg_to_err @@ handle_create t header vm_config)) + end + else + Error (`Msg "wouldn't match policy") + | `Command (`Vm_cmd `Vm_destroy) -> + begin match Vmm_resources.find_vm t.resources id with | Some vm -> Vmm_unix.destroy vm ; let id_str = string_of_id id in let out, next = - let success = Vmm_wire.success t.client_version hdr.Vmm_wire.id hdr.Vmm_wire.tag in - let s = [ `Data success ] in + let s = [ `Data (header, `Success (`String "destroyed vm")) ] in match String.Map.find_opt id_str t.tasks with | None -> s, `End - | Some t -> [], `Wait (t, s) + | Some t -> [], `Wait (t, s) in let tasks = String.Map.remove id_str t.tasks in Ok ({ t with tasks }, out, next) - | None -> Error (`Msg "destroy: not found")) + | None -> Error (`Msg "destroy: not found") + end + | _ -> Error (`Msg "unknown command")) diff --git a/src/vmm_engine.mli b/src/vmm_engine.mli new file mode 100644 index 0000000..af6d787 --- /dev/null +++ b/src/vmm_engine.mli @@ -0,0 +1,26 @@ + +type 'a t + +val init : Vmm_asn.version -> 'a t + +type service_out = [ + | `Stat of Vmm_asn.wire + | `Log of Vmm_asn.wire + | `Cons of Vmm_asn.wire +] + +type out = [ service_out | `Data of Vmm_asn.wire ] + +val handle_shutdown : 'a t -> Vmm_core.vm -> + [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list + +val handle_command : 'a t -> Vmm_asn.wire -> + 'a t * out list * + [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.vm, [> Rresult.R.msg ]) result + | `End + | `Wait of 'a * out list + | `Wait_and_create of 'a * ('a t -> 'a t * out list * + [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.vm, [> Rresult.R.msg ]) result + | `End ]) ] + +val setup_stats : 'a t -> Vmm_core.vm -> 'a t * out list diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml index bfe0382..9017109 100644 --- a/src/vmm_lwt.ml +++ b/src/vmm_lwt.ml @@ -42,7 +42,7 @@ let wait_and_clear pid stdout = ret s let read_wire s = - let buf = Bytes.create (Int32.to_int Vmm_wire.header_size) in + let buf = Bytes.create 4 in let rec r b i l = Lwt.catch (fun () -> Lwt_unix.read s b i l >>= function @@ -59,27 +59,31 @@ let read_wire s = Logs.err (fun m -> m "exception %s while reading" err) ; Lwt.return (Error `Exception)) in - r buf 0 (Int32.to_int Vmm_wire.header_size) >>= function + r buf 0 4 >>= function | Error e -> Lwt.return (Error e) | Ok () -> - match Vmm_wire.decode_header (Cstruct.of_bytes buf) with - | Error (`Msg m) -> Lwt.return (Error (`Msg m)) - | Ok hdr -> - let l = Int32.to_int hdr.Vmm_wire.length in - if l > 0 then - let b = Bytes.create l in - r b 0 l >|= function - | Error e -> Error e - | Ok () -> -(* Logs.debug (fun m -> m "read hdr %a, body %a" + let len = Cstruct.BE.get_uint32 (Cstruct.of_bytes buf) 0 in + if len > 0l then + let b = Bytes.create (Int32.to_int len) in + r b 0 (Int32.to_int len) >|= function + | Error e -> Error e + | Ok () -> + (* Logs.debug (fun m -> m "read hdr %a, body %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf) Cstruct.hexdump_pp (Cstruct.of_bytes b)) ; *) - Ok (hdr, Cstruct.of_bytes b) - else - Lwt.return (Ok (hdr, Cstruct.empty)) + match Vmm_asn.wire_of_cstruct (Cstruct.of_bytes b) with + | Ok w -> Ok w + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while parsing data" msg) ; + Error `Exception + else + Lwt.return (Error `Eof) -let write_wire s buf = - let buf = Cstruct.to_bytes buf in +let write_wire s wire = + let data = Vmm_asn.wire_to_cstruct wire in + let dlen = Cstruct.create 4 in + Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ; + let buf = Cstruct.(to_bytes (append dlen data)) in let rec w off l = Lwt.catch (fun () -> Lwt_unix.send s buf off l [] >>= fun n -> diff --git a/src/vmm_lwt.mli b/src/vmm_lwt.mli new file mode 100644 index 0000000..ea11a6d --- /dev/null +++ b/src/vmm_lwt.mli @@ -0,0 +1,14 @@ +val pp_sockaddr : Format.formatter -> Lwt_unix.sockaddr -> unit +val pp_process_status : Format.formatter -> Unix.process_status -> unit +val ret : + Unix.process_status -> [> `Exit of int | `Signal of int | `Stop of int ] +val waitpid : int -> (int * Lwt_unix.process_status, unit) result Lwt.t +val wait_and_clear : + int -> + Unix.file_descr -> [> `Exit of int | `Signal of int | `Stop of int ] Lwt.t +val read_wire : + Lwt_unix.file_descr -> + (Vmm_asn.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t +val write_wire : + Lwt_unix.file_descr -> Vmm_asn.wire -> (unit, [> `Exception ]) result Lwt.t +val safe_close : Lwt_unix.file_descr -> unit Lwt.t diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index e532841..4bd3daf 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -26,27 +26,32 @@ let read_tls t = Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ; Lwt.return (Error `Exception)) in - let buf = Cstruct.create (Int32.to_int Vmm_wire.header_size) in - r_n buf 0 (Int32.to_int Vmm_wire.header_size) >>= function + let buf = Cstruct.create 4 in + r_n buf 0 4 >>= function | Error e -> Lwt.return (Error e) | Ok () -> - match Vmm_wire.decode_header buf with - | Error (`Msg m) -> Lwt.return (Error (`Msg m)) - | Ok hdr -> - let l = Int32.to_int hdr.Vmm_wire.length in - if l > 0 then - let b = Cstruct.create l in - r_n b 0 l >|= function - | Error e -> Error e - | Ok () -> -(* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a" + let len = Cstruct.BE.get_uint32 buf 0 in + if len > 0l then + let b = Cstruct.create (Int32.to_int len) in + r_n b 0 (Int32.to_int len) >|= function + | Error e -> Error e + | Ok () -> + (* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a" hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag Cstruct.hexdump_pp b) ; *) - Ok (hdr, b) + match Vmm_asn.wire_of_cstruct b with + | Ok w -> Ok w + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while parsing data" msg) ; + Error `Exception else - Lwt.return (Ok (hdr, Cstruct.empty)) + Lwt.return (Error `Eof) -let write_tls s buf = +let write_tls s wire = + let data = Vmm_asn.wire_to_cstruct wire in + let dlen = Cstruct.create 4 in + Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ; + let buf = Cstruct.(append dlen data) in (* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *) Lwt.catch (fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ()) diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli new file mode 100644 index 0000000..c5e6967 --- /dev/null +++ b/src/vmm_tls.mli @@ -0,0 +1,5 @@ +val read_tls : + Tls_lwt.Unix.t -> + (Vmm_asn.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t +val write_tls : + Tls_lwt.Unix.t -> Vmm_asn.wire -> (unit, [> `Exception ]) result Lwt.t diff --git a/src/vmm_wire.ml b/src/vmm_wire.ml deleted file mode 100644 index d06ff00..0000000 --- a/src/vmm_wire.ml +++ /dev/null @@ -1,681 +0,0 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -(* the wire protocol - length prepended binary data *) - -(* each message (on all channels) is prefixed by a common header: - - tag (32 bit) the type of message - it is only 31 bit, the highest (leftmost) bit indicates query (0) or reply (1) - a failure is reported with the special tag 0xFFFFFFFF (all bits set) - data is a string - every request leads to a reply - WV0 and WV1 used 16 bit only - - version (16 bit) the version used on this channel (used to be byte 4-6) - - padding (16 bit) - - id (64 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) - - length (32 bit) spanning the message (excluding the 20 bytes header) - - full VM name (i.e. foo.bar.baz) encoded as size of list followed by list of strings - - replies do not contain the VM name - - 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. - - every command issued is replied to with success or failure. broadcast - communication (console data, log events) are not acknowledged by the - recipient. - *) - - -(* TODO unlikely that this is 32bit clean *) - -open Astring - -open Vmm_core - -type version = [ `WV0 | `WV1 | `WV2 ] - -let version_to_int = function - | `WV0 -> 0 - | `WV1 -> 1 - | `WV2 -> 2 - -let version_of_int = function - | 0 -> Ok `WV0 - | 1 -> Ok `WV1 - | 2 -> Ok `WV2 - | _ -> Error (`Msg "unknown wire version") - -let version_eq a b = match a, b with - | `WV0, `WV0 -> true - | `WV1, `WV1 -> true - | `WV2, `WV2 -> true - | _ -> false - -let pp_version ppf v = - Fmt.string ppf (match v with - | `WV0 -> "wire version 0" - | `WV1 -> "wire version 1" - | `WV2 -> "wire version 2") - -type header = { - version : version ; - tag : int32 ; - length : int32 ; - id : int64 ; -} - -let header_size = 20l - -let max_size = 0x7FFFFFFFl - -(* Throughout this module, we don't expect any cstruct bigger than the above - max_size (encode checks this!) *) - -open Rresult -open R.Infix - - -let cs_create len = Cstruct.create (Int32.to_int len) - -let cs_len cs = - let l = Cstruct.len cs in - assert (l lsr 31 = 0) ; - Int32.of_int l - -let check_len cs l = - if Int32.compare (cs_len cs) l = -1 then - Error (`Msg "underflow") - else - Ok () - -let cs_shift cs num = - check_len cs (Int32.of_int num) >>= fun () -> - Ok (Cstruct.shift cs num) - -let check_exact cs l = - if cs_len cs = l then - Ok () - else - Error (`Msg "bad length") - -let null cs = if Cstruct.len cs = 0 then Ok () else Error (`Msg "trailing bytes") - -let decode_header cs = - check_len cs 8l >>= fun () -> - let version = Cstruct.BE.get_uint16 cs 4 in - version_of_int version >>= function - | `WV0 | `WV1 -> Error (`Msg "unsupported version") - | `WV2 as version -> - check_len cs header_size >>= fun () -> - let tag = Cstruct.BE.get_uint32 cs 0 - and id = Cstruct.BE.get_uint64 cs 8 - and length = Cstruct.BE.get_uint32 cs 16 - in - Ok { length ; id ; version ; tag } - -let encode_header { length ; id ; version ; tag } = - match version with - | `WV0 | `WV1 -> invalid_arg "version no longer supported" - | `WV2 -> - let hdr = cs_create header_size in - Cstruct.BE.set_uint32 hdr 0 tag ; - Cstruct.BE.set_uint16 hdr 4 (version_to_int version) ; - Cstruct.BE.set_uint64 hdr 8 id ; - Cstruct.BE.set_uint32 hdr 16 length ; - hdr - -let max_str_len = 0xFFFF - -let decode_string cs = - check_len cs 2l >>= fun () -> - let l = Cstruct.BE.get_uint16 cs 0 in - check_len cs (Int32.add 2l (Int32.of_int l)) >>= fun () -> - let str = Cstruct.(to_string (sub cs 2 l)) in - Ok (str, l + 2) - -let encode_string str = - let l = String.length str in - assert (l < max_str_len) ; - let cs = Cstruct.create (2 + l) in - Cstruct.BE.set_uint16 cs 0 l ; - Cstruct.blit_from_string str 0 cs 2 l ; - cs - -let max = Int64.of_int max_int -let min = Int64.of_int min_int - -let decode_int ?(off = 0) cs = - check_len cs Int32.(add (of_int off) 8l) >>= fun () -> - 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 - -let decode_list inner buf = - decode_int buf >>= fun len -> - let rec go acc idx = function - | 0 -> Ok (List.rev acc, idx) - | n -> - cs_shift buf idx >>= fun cs' -> - inner cs' >>= fun (data, len) -> - go (data :: acc) (idx + len) (pred n) - in - go [] 8 len - -let encode_list inner data = - let cs = encode_int (List.length data) in - Cstruct.concat (cs :: (List.map inner data)) - -let decode_strings = decode_list decode_string - -let encode_strings = encode_list encode_string - -let encode ?name ?body version id tag = - let vm = match name with None -> Cstruct.empty | Some id -> encode_strings id in - let payload = match body with None -> Cstruct.empty | Some x -> x in - let header = - let length = Int32.(add (cs_len payload) (cs_len vm)) in - { length ; id ; version ; tag } - in - Cstruct.concat [ encode_header header ; vm ; payload ] - -let maybe_str = function - | None -> Cstruct.empty - | Some c -> encode_string c - -let fail_tag = 0xFFFFFFFFl - -let reply_tag = 0x80000000l - -let is_tag v tag = Int32.logand v tag = v - -let is_reply { tag ; _ } = is_tag reply_tag tag - -let is_fail { tag ; _ } = is_tag fail_tag tag - -let reply ?body version id tag = - encode ?body version id (Int32.logor reply_tag tag) - -let fail ?msg version id = - encode ~body:(maybe_str msg) version id fail_tag - -let success ?msg version id tag = - reply ~body:(maybe_str msg) version id tag - -let decode_ptime ?(off = 0) cs = - cs_shift cs off >>= fun cs' -> - check_len cs' 16l >>= fun () -> - decode_int cs' >>= fun d -> - let ps = Cstruct.BE.get_uint64 cs' 8 in - Ok (Ptime.v (d, ps)) - -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 - -module Console = struct - type op = - | Add_console - | Attach_console - | Data (* is a reply, never acked *) - - let op_to_int = function - | Add_console -> 0x0100l - | Attach_console -> 0x0101l - | Data -> 0x0102l - - let int_to_op = function - | 0x0100l -> Some Add_console - | 0x0101l -> Some Attach_console - | 0x0102l -> Some Data - | _ -> None - - let data version name ts msg = - let body = - let ts = encode_ptime ts - and data = encode_string msg - in - Cstruct.append ts data - in - encode version ~name ~body 0L (op_to_int Data) - - let add id version name = - encode ~name version id (op_to_int Add_console) - - let attach id version name = - encode ~name version id (op_to_int Attach_console) -end - -module Stats = struct - type op = - | Add - | Remove - | Subscribe - | Data - - let op_to_int = function - | Add -> 0x0200l - | Remove -> 0x0201l - | Subscribe -> 0x0202l - | Data -> 0x0203l - - let int_to_op = function - | 0x0200l -> Some Add - | 0x0201l -> Some Remove - | 0x0202l -> Some Subscribe - | 0x0203l -> Some Data - | _ -> None - - let rusage_len = 144l - - let encode_rusage ru = - let cs = cs_create rusage_len 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 rusage_len >>= 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 ifdata_len = 116l - - let encode_ifdata i = - let name = encode_string i.name in - let cs = cs_create ifdata_len 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) -> - cs_shift buf l >>= fun cs -> - check_len cs ifdata_len >>= fun () -> - 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 }, - Int32.(to_int ifdata_len) + l) - - let add id version name pid taps = - let body = Cstruct.append (encode_int pid) (encode_strings taps) in - encode ~name ~body version id (op_to_int Add) - - let remove id version name = encode ~name version id (op_to_int Remove) - - let subscribe id version name = encode ~name version id (op_to_int Subscribe) - - let data id version vm body = - let name = Vmm_core.id_of_string vm in - encode ~name ~body version id (op_to_int Data) - - let encode_int64 i = - let cs = Cstruct.create 8 in - Cstruct.BE.set_uint64 cs 0 i ; - cs - - let decode_int64 ?(off = 0) cs = - check_len cs (Int32.add 8l (Int32.of_int off)) >>= fun () -> - Ok (Cstruct.BE.get_uint64 cs off) - - let encode_vmm_stats = - encode_list - (fun (k, v) -> Cstruct.append (encode_string k) (encode_int64 v)) - - let decode_vmm_stats = - decode_list (fun buf -> - decode_string buf >>= fun (str, off) -> - decode_int64 ~off buf >>= fun v -> - Ok ((str, v), off + 8)) - - let encode_stats (ru, vmm, ifd) = - Cstruct.concat - [ encode_rusage ru ; - encode_vmm_stats vmm ; - encode_list encode_ifdata ifd ] - - let decode_stats cs = - check_len cs rusage_len >>= fun () -> - let ru, rest = Cstruct.split cs (Int32.to_int rusage_len) in - decode_rusage ru >>= fun ru -> - decode_vmm_stats rest >>= fun (vmm, off) -> - cs_shift rest off >>= fun rest' -> - decode_list decode_ifdata rest' >>= fun (ifs, _) -> - Ok (ru, vmm, ifs) - - let decode_pid_taps data = - decode_int data >>= fun pid -> - decode_strings (Cstruct.shift data 8) >>= fun (taps, _off) -> - Ok (pid, taps) -end - -let decode_id_ts cs = - decode_strings cs >>= fun (id, off) -> - decode_ptime ~off cs >>= fun ts -> - Ok ((id, ts), off + 16) - -let split_id id = match List.rev id with - | [] -> Error (`Msg "bad header") - | name::rest -> Ok (name, List.rev rest) - -module Log = struct - type op = - | Log - | Broadcast - | Subscribe - - let op_to_int = function - | Log -> 0x0300l - | Subscribe -> 0x0301l - | Broadcast -> 0x0302l - - let int_to_op = function - | 0x0300l -> Some Log - | 0x0301l -> Some Subscribe - | 0x0302l -> Some Broadcast - | _ -> None - - let subscribe id version name = - encode ~name version id (op_to_int Subscribe) - - let decode_log_hdr cs = - decode_id_ts cs >>= fun ((name, ts), off) -> - Ok ({ Log.ts ; name }, Cstruct.shift cs off) - - 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 6l >>= 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_int 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_int cs >>= fun pid -> - let r = Cstruct.shift cs 8 in - decode_string r >>= fun (block, l) -> - let block = if block = "" then None else Some block in - cs_shift r l >>= fun r' -> - decode_strings r' >>= 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 r_cs = encode_int r - and pid_cs = encode_int pid - and c_cs = encode_int c - in - Cstruct.concat [ pid_cs ; r_cs ; c_cs ] - - let decode_pid_exit cs = - check_len cs 24l >>= fun () -> - decode_int cs >>= fun pid -> - decode_int ~off:8 cs >>= fun r -> - decode_int ~off:16 cs >>= 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_event ev = - let tag, data = match ev with - | `Startup -> 0, Cstruct.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 - 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 2l >>= 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) - | x -> R.error_msgf "couldn't parse event type %d" x - - let log id version hdr event = - let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) in - encode ~name:hdr.Log.name ~body version id (op_to_int Log) -end - -module Vm = struct - type op = - | Create - | Destroy - | Info - | Policy - | Insert_policy - | Remove_policy - | Force_create - - let op_to_int = function - | Create -> 0x0400l - | Destroy -> 0x0401l - | Info -> 0x0402l - | Policy -> 0x0403l - | Insert_policy -> 0x0404l - | Remove_policy -> 0x0405l - | Force_create -> 0x0406l - - let int_to_op = function - | 0x0400l -> Some Create - | 0x0401l -> Some Destroy - | 0x0402l -> Some Info - | 0x0403l -> Some Policy - | 0x0404l -> Some Insert_policy - | 0x0405l -> Some Remove_policy - | 0x0406l -> Some Force_create - | _ -> None - - let policy id version name = - encode ~name version id (op_to_int Policy) - - let insert_policy id version name policy = - let body = Vmm_asn.policy_to_cstruct policy in - encode ~name ~body version id (op_to_int Insert_policy) - - let remove_policy id version name = - encode ~name version id (op_to_int Remove_policy) - - let info id version name = - encode ~name version id (op_to_int Info) - - let encode_vm vm = - let name = encode_strings vm.config.vname - and memory = encode_int vm.config.requested_memory - and cs = encode_string (Bos.Cmd.to_string vm.cmd) - and pid = encode_int vm.pid - and taps = encode_strings vm.taps - in - Cstruct.concat [ name ; memory ; cs ; pid ; taps ] - - let info_reply id version vms = - let body = encode_list encode_vm vms in - reply ~body version id (op_to_int Info) - - let policy_reply id version policies = - let body = encode_list - (fun (prefix, policy) -> - let name_cs = encode_strings prefix - and pol_cs = Vmm_asn.policy_to_cstruct policy in - Cstruct.append name_cs pol_cs) - policies - in - reply ~body version id (op_to_int Policy) - - let decode_policies buf = - decode_list (fun cs -> - decode_strings cs >>= fun (id, l) -> - cs_shift cs l >>= fun cs' -> - Vmm_asn.policy_of_cstruct cs' >>= fun (policy, cs'') -> - let off = Cstruct.len cs - Cstruct.len cs'' in - Ok ((id, policy), off)) - buf - - let decode_vm cs = - decode_strings cs >>= fun (id, l) -> - cs_shift cs l >>= fun cs' -> - decode_int cs' >>= fun memory -> - cs_shift cs' 8 >>= fun cs'' -> - decode_string cs'' >>= fun (cmd, l') -> - cs_shift cs'' l' >>= fun cs''' -> - decode_int cs''' >>= fun pid -> - cs_shift cs''' 8 >>= fun cs'''' -> - decode_strings cs'''' >>= fun (taps, l'') -> - Ok ((id, memory, cmd, pid, taps), l + 8 + l' + 8 + l'') - - let decode_vms buf = decode_list decode_vm buf - - let encode_vm_config vm = - let cpu = encode_int vm.cpuid - and mem = encode_int vm.requested_memory - and block = encode_string (match vm.block_device with None -> "" | Some x -> x) - and network = encode_strings vm.network - and vmimage = Cstruct.concat [ encode_int (vmtype_to_int (fst vm.vmimage)) ; - encode_int (Cstruct.len (snd vm.vmimage)) ; - snd vm.vmimage ] - and args = encode_strings (match vm.argv with None -> [] | Some args -> args) - in - Cstruct.concat [ cpu ; mem ; block ; network ; vmimage ; args ] - - let decode_vm_config buf = - decode_strings buf >>= fun (vname, off) -> - Logs.debug (fun m -> m "vm_config name %a" pp_id vname) ; - cs_shift buf off >>= fun buf' -> - decode_int buf' >>= fun cpuid -> - Logs.debug (fun m -> m "cpuid %d" cpuid) ; - decode_int ~off:8 buf' >>= fun requested_memory -> - Logs.debug (fun m -> m "mem %d" requested_memory) ; - cs_shift buf' 16 >>= fun buf'' -> - decode_string buf'' >>= fun (block, off) -> - Logs.debug (fun m -> m "block %s" block) ; - cs_shift buf'' off >>= fun buf''' -> - let block_device = if block = "" then None else Some block in - decode_strings buf''' >>= fun (network, off') -> - cs_shift buf''' off' >>= fun buf'''' -> - decode_int buf'''' >>= fun vmtype -> - (match int_to_vmtype vmtype with - | Some x -> Ok x - | None -> Error (`Msg "unknown vmtype")) >>= fun vmtype -> - decode_int ~off:8 buf'''' >>= fun size -> - check_len buf'''' (Int32.of_int size) >>= fun () -> - let vmimage = (vmtype, Cstruct.sub buf'''' 16 size) in - cs_shift buf'''' (16 + size) >>= fun buf''''' -> - decode_strings buf''''' >>= fun (argv, _) -> - let argv = match argv with [] -> None | xs -> Some xs in - Ok { vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } - - let create id version vm = - let body = encode_vm_config vm in - encode ~name:vm.vname ~body version id (op_to_int Create) - - let force_create id version vm = - let body = encode_vm_config vm in - encode ~name:vm.vname ~body version id (op_to_int Force_create) - - let destroy id version name = - encode ~name version id (op_to_int Destroy) -end diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index 9571eee..9b34541 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -118,6 +118,7 @@ let tick t = | None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.pp_id id Vmm_core.pp_id vmid) ; out | Some real_id -> let name = Vmm_core.string_of_id real_id in + let stats_encoded = Vmm_wire.Stats.(data 0L my_version name (encode_stats stats)) in (socket, vmid, stats_encoded) :: out) out xs) From 467debe3033e62715a37f9cc2f9b0ee18aa82e1c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 22 Oct 2018 23:21:05 +0200 Subject: [PATCH 28/73] rip prometheus reporter --- app/vmm_prometheus_stats.ml | 356 ------------------------------------ pkg/pkg.ml | 1 - 2 files changed, 357 deletions(-) delete mode 100644 app/vmm_prometheus_stats.ml diff --git a/app/vmm_prometheus_stats.ml b/app/vmm_prometheus_stats.ml deleted file mode 100644 index 1759eb1..0000000 --- a/app/vmm_prometheus_stats.ml +++ /dev/null @@ -1,356 +0,0 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -open Lwt.Infix - -open Astring - -open Vmm_core - -let my_version = `WV0 - -let command = ref 1 - -let t : (Lwt_unix.file_descr * Lwt_unix.sockaddr * string) IM.t ref = ref IM.empty - -module S = struct - type t = Lwt_unix.sockaddr - let compare : Lwt_unix.sockaddr -> Lwt_unix.sockaddr -> int = compare -end - -module SM = Map.Make(S) - -let count : int SM.t ref = ref SM.empty - -let dec s = - match SM.find s !count with - | exception Not_found -> `Not_found - | 1 -> count := SM.remove s !count ; `Close - | x -> count := SM.add s (pred x) !count ; `Continue - -let known_vms : string list ref = ref [] - -module P = struct - let p vm ?(typ = `Counter) name help value = - let t_s = function `Counter -> "counter" | `Gauge -> "gauge" in - let name = vm ^ "_" ^ name in - let p a v = String.concat ~sep:" " [ "#" ; a ; name ; v ] in - String.concat ~sep:"\n" - [ p "HELP" help ; p "TYPE" (t_s typ) ; name ^ " " ^ value ] - - let tv (sec, usec) = Printf.sprintf "%Lu.%06d" sec usec - let i64 i = Printf.sprintf "%Lu" i - - let encode_ru vm ru = - let p = p vm in - String.concat ~sep:"\n" - [ p "utime" "user time used" (tv ru.utime) ; - p "stime" "system time used" (tv ru.stime) ; - p "maxrss" "maximum resident set" (i64 ru.maxrss) ; - p ~typ:`Gauge "ixrss" "shared memory" (i64 ru.ixrss) ; - p ~typ:`Gauge "idrss" "unshared data" (i64 ru.idrss) ; - p ~typ:`Gauge "isrss" "unshared stack" (i64 ru.isrss) ; - p "minflt" "page reclaims" (i64 ru.minflt) ; - p "maxflt" "page faults" (i64 ru.majflt) ; - p "nswap" "swaps" (i64 ru.nswap) ; - p "inblock" "block input ops" (i64 ru.inblock) ; - p "outblock" "block output ops" (i64 ru.outblock) ; - p "msgsnd" "messages send" (i64 ru.msgsnd) ; - p "msgrcv" "messages received" (i64 ru.msgrcv) ; - p "nsignals" "signals received" (i64 ru.nsignals) ; - p "nvcsw" "voluntary context switches" (i64 ru.nvcsw) ; - p "nivcsw" "involuntary context switches" (i64 ru.nivcsw) - ] - - let encode_vmm vm xs = - let p = p vm in - let massage s = - let cutted = match String.cut ~sep:"umber of " s with - | Some (_, r) -> r - | None -> s - in - let cutted = match String.cut ~sep:"[" cutted with - | None -> cutted - | Some (l, r) -> match String.cut ~sep:"]" r with - | None -> cutted - | Some (l', r) when r = "" -> l ^ "_" ^ l' - | Some (l', r') -> l ^ "_" ^ l' ^ "_" ^ r' - in - let cutted = - List.fold_left (fun str sep -> - match String.cut ~sep str with - | None -> str - | Some (l, r) -> l ^ r) - cutted [ "%" ; "/" ; "-" ] - in - String.concat ~sep:"_" (String.cuts ~sep:" " cutted) - in - String.concat ~sep:"\n" - (List.map (fun (k, v) -> p (massage k) k (i64 v)) xs) - - let i32 i = Printf.sprintf "%lu" i - - let encode_if vm ifd = - let p = p (vm ^ "_" ^ ifd.name) in - String.concat ~sep:"\n" - (* TODO: flags *) - [ p ~typ:`Gauge "send_length" "length of send queue" (i32 ifd.send_length) ; - p "max_send_length" "maximum length of send queue" (i32 ifd.max_send_length) ; - p "send_drops" "drops in send queue" (i32 ifd.send_drops) ; - p ~typ:`Gauge "mtu" "maximum transmission unit" (i32 ifd.mtu) ; - p ~typ:`Gauge "baudrate" "linespeed" (i64 ifd.baudrate) ; - p "vm_to_host_packets" "packets from vm" (i64 ifd.input_packets) ; - p "vm_to_host_errors" "packet errors from vm" (i64 ifd.input_errors) ; - p "vm_to_host_bytes" "bytes from vm" (i64 ifd.input_bytes) ; - p "vm_to_host_mcast" "packets from vm via multicast" (i64 ifd.input_mcast) ; - p "vm_to_host_dropped" "packets dropped from vm" (i64 ifd.input_dropped) ; - p "collisions" "collisions on csma interface" (i64 ifd.collisions) ; - p "host_to_vm_packets" "packets to vm" (i64 ifd.output_packets) ; - p "host_to_vm_errors" "packet errors to vm" (i64 ifd.output_errors) ; - p "host_to_vm_bytes" "bytes to vm" (i64 ifd.output_bytes) ; - p "host_to_vm_mcast" "packets to vm via multicast" (i64 ifd.output_mcast) ; - p "host_to_vm_dropped" "packets dropped to vm" (i64 ifd.output_dropped) - ] -end - -(* just a reminder whether we already sent the initial "info" or not *) -let f_done = ref false - -let process db tls hdr data = - let open Vmm_wire in - let open Rresult.R.Infix in - if not (version_eq hdr.version my_version) then begin - Logs.err (fun m -> m "unknown wire protocol version") ; Lwt.return_unit - end else - match hdr.tag with - | x when x = Client.log_msg_tag && not !f_done -> - f_done := true ; - (* issue initial "info" to get all the vm names *) - let out = Vmm_wire.Client.cmd Info !command my_version in - command := succ !command ; - Logs.debug (fun m -> m "writing %a over TLS" Cstruct.hexdump_pp (Cstruct.of_string out)) ; - (Vmm_tls.write_tls tls out >|= function - | Ok () -> () - | Error _ -> Logs.err (fun m -> m "error while writing") ; ()) - | _ -> - let r = - match hdr.tag with - | x when x = Client.log_msg_tag -> - Client.decode_log data >>= fun (hdr, event) -> - let nam = translate_serial db hdr.Vmm_core.Log.name in - begin match event with - | `VM_start _ -> known_vms := nam :: !known_vms - | `VM_stop _ -> known_vms := List.filter (fun m -> m <> nam) !known_vms - | _ -> () - end ; - Ok `None - | x when x = Client.info_msg_tag -> - Client.decode_info data >>= fun vms -> - let vms = List.map (fun (name, _, _, _) -> translate_serial db name) vms in - known_vms := vms ; - Ok `None - | x when x = Client.stat_msg_tag -> - Client.decode_stat data >>= fun (ru, vmm, ifd) -> - begin match IM.find hdr.id !t with - | exception Not_found -> Logs.err (fun m -> m "unexpected reply") ; Ok `None - | (fd, s, vm) -> - t := IM.remove hdr.id !t ; - let out = String.concat ~sep:"\n" (P.encode_ru vm ru :: P.encode_vmm vm vmm :: List.map (P.encode_if vm) ifd @ [""]) in - Ok (`Stat (fd, s, out)) - end - | x when x = fail_tag -> - let res = - match IM.find hdr.id !t with - | exception Not_found -> `None - | (fd, s, _) -> `Sockaddr (fd, s) - in - t := IM.remove hdr.id !t ; - decode_str data >>= fun (msg, _) -> - Logs.err (fun m -> m "failed %s" msg) ; - Ok res - | x -> Rresult.R.error_msgf "ignoring header tag %02X" x - in - let d (fd, s) = match dec s with - | `Continue -> Lwt.return_unit - | `Close -> Lwt_unix.close fd - | `Not_found -> Logs.err (fun m -> m "sockaddr not found") ; Lwt.return_unit - in - let open Lwt.Infix in - match r with - | Ok `None -> Lwt.return_unit - | Ok (`Sockaddr s) -> d s - | Ok (`Stat (fd, s, out)) -> - (Vmm_lwt.write_raw fd out >>= function - | Ok () -> d (fd, s) - | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return_unit) - | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing: %s" msg) ; Lwt.return_unit - -let rec tls_listener db tls = - (Vmm_tls.read_tls tls >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while reading %s" msg) ; - Lwt.return (Ok ()) - | Error _ -> - Logs.err (fun m -> m "received exception in read_tls") ; - Lwt.return (Error ()) - | Ok (hdr, data) -> - process db tls hdr data >>= fun () -> - Lwt.return (Ok ())) >>= function - | Ok () -> tls_listener db tls - | Error () -> Lwt.return_unit - -let hdr = - String.concat ~sep:"\r\n" - [ "HTTP/1.1 200 OK" ; - "Content-Type: text/plain; version=0.0.4" ; - "\r\n" ] - -(* wait for TCP connection, once received request stats from vmmd, and loop *) -let rec tcp_listener db tcp tls = - Lwt_unix.accept tcp >>= fun (cs, sockaddr) -> - Vmm_lwt.write_raw cs hdr >>= function - | Error _ -> Logs.err (fun m -> m "exception while accepting") ; Lwt.return_unit - | Ok () -> - let l = List.length !known_vms in - let ip, port = match sockaddr with Lwt_unix.ADDR_INET (ip, port) -> ip, port | _ -> invalid_arg "unexpected" in - Logs.info (fun m -> m "connection from %s:%d with %d known" (Unix.string_of_inet_addr ip) port l) ; - (if l = 0 then - Lwt_unix.close cs >|= fun () -> Error () - else begin - count := SM.add sockaddr (List.length !known_vms) !count ; - Lwt_list.fold_left_s - (fun r vm -> - match r with - | Error () -> Lwt.return (Error ()) - | Ok () -> - let vm_id = translate_name db vm in - let out = Vmm_wire.Client.cmd Statistics ~arg:vm_id !command my_version in - t := IM.add !command (cs, sockaddr, vm) !t ; - command := succ !command ; - Vmm_tls.write_tls tls out >|= function - | Ok () -> Ok () - | Error _ -> Logs.err (fun m -> m "exception while writing") ; Error ()) - (Ok ()) !known_vms - end) >>= function - | Ok () -> tcp_listener db tcp tls - | Error () -> Lwt.return_unit - -let client cas host port cert priv_key db listen_ip listen_port = - Nocrypto_entropy_lwt.initialize () >>= fun () -> - let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in - X509_lwt.authenticator auth >>= fun authenticator -> - Lwt.catch (fun () -> - (* start TCP listening socket *) - let tcp = Lwt_unix.(socket PF_INET SOCK_STREAM 0) in - Lwt_unix.(setsockopt tcp SO_REUSEADDR true) ; - let addr = Lwt_unix.ADDR_INET (Ipaddr_unix.V4.to_inet_addr listen_ip, listen_port) in - Lwt_unix.bind tcp addr >>= fun () -> - Lwt_unix.listen tcp 1 ; - - (* setup remote connection to VMMD *) - Lwt_unix.gethostbyname host >>= fun host_entry -> - let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in - let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in - - Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ -> - X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert -> - let certificates = `Single cert in - let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in - Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun tls -> - - (* loop on both tcp and tls connections *) - Lwt.join [ tcp_listener db tcp tls ; tls_listener db tls ]) - (fun exn -> - Logs.err (fun m -> m "failed to establish TLS connection: %s" - (Printexc.to_string exn)) ; - Lwt.return_unit) - -let run_client _ cas cert key (host, port) db listen_ip listen_port = - Printexc.register_printer (function - | Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x) - | Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f) - | _ -> None) ; - Sys.(set_signal sigpipe Signal_ignore) ; - let db = - let open Rresult.R.Infix in - match db with - | None -> [] - | Some db -> - match Bos.OS.File.read_lines (Fpath.v db) >>= parse_db with - | Ok db -> db - | Error (`Msg m) -> Logs.warn (fun f -> f "couldn't parse database %s" m) ; [] - in - Lwt_main.run (client cas host port cert key db listen_ip listen_port) - -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) - -open Cmdliner - -let setup_log = - Term.(const setup_log - $ Fmt_cli.style_renderer () - $ Logs_cli.level ()) - -let host_port : (string * int) Arg.converter = - let parse s = - match String.cut ~sep:":" s with - | None -> `Error "broken: no port specified" - | Some (hostname, port) -> - try - `Ok (hostname, int_of_string port) - with - Not_found -> `Error "failed to parse port" - in - parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p - -let cas = - let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in - Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc) - -let client_cert = - let doc = "Use a client certificate chain" in - Arg.(required & pos 1 (some file) None & info [] ~doc) - -let client_key = - let doc = "Use a client key" in - Arg.(required & pos 2 (some file) None & info [] ~doc) - -let destination = - Arg.(required & pos 3 (some host_port) None & info [] ~docv:"destination" - ~doc:"the destination hostname:port to connect to") - -let ip : Ipaddr.V4.t Arg.converter = - let parse s = - try - `Ok (Ipaddr.V4.of_string_exn s) - with - Not_found -> `Error "broken" - in - parse, Ipaddr.V4.pp_hum - -let address = - let doc = "Address to listen on" in - Arg.(value & opt ip (Ipaddr.V4.of_string_exn "127.0.0.1") & info [ "address" ] ~doc) - -let port = - let doc = "TCP port to listen on" in - Arg.(value & opt int 9080 & info [ "port" ] ~doc) - -let db = - let doc = "Certificate database" in - Arg.(value & opt (some file) None & info [ "db" ] ~doc) - -let cmd = - let doc = "VMM Prometheus connector" in - let man = [ - `S "DESCRIPTION" ; - `P "$(tname) connects to a VMMD to gather statistics and serves them for Prometheus via HTTP" ] - in - Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination $ db $ address $ port), - Term.info "vmm_prometheus_stats" ~version:"%%VERSION_NUM%%" ~doc ~man - -let () = - match Term.eval cmd - with `Error _ -> exit 1 | _ -> exit 0 diff --git a/pkg/pkg.ml b/pkg/pkg.ml index ae465e3..bd35027 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -21,6 +21,5 @@ let () = Pkg.bin "provision/vmm_gen_ca" ; *) (* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *) (* Pkg.bin "stats/vmm_stats_lwt" ; - (* Pkg.bin "app/vmm_prometheus_stats" ; *) Pkg.bin "app/vmm_influxdb_stats" ; *) ] From f939ff5a588d1faa7660247ce233444c98133e1b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 00:02:05 +0200 Subject: [PATCH 29/73] influx stats --- app/vmm_console.ml | 44 ++++++++++----------- app/vmm_influxdb_stats.ml | 81 +++++++++++++++------------------------ app/vmm_log.ml | 10 +---- pkg/pkg.ml | 4 +- src/vmm_lwt.ml | 13 ++++--- src/vmm_lwt.mli | 2 + stats/vmm_stats.ml | 59 ++++++++++++++++------------ stats/vmm_stats_lwt.ml | 13 ++++--- 8 files changed, 107 insertions(+), 119 deletions(-) diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 81f7572..10475c9 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -104,34 +104,30 @@ let handle s addr () = Logs.info (fun m -> m "handling connection %a" Vmm_lwt.pp_sockaddr addr) ; let rec loop () = Vmm_lwt.read_wire s >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while reading %s" msg) ; - loop () | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (_, `Success _) -> - Logs.err (fun m -> m "unexpected success reply") ; + | Ok (header, `Command (`Console_cmd cmd)) -> + begin + (if not (Vmm_asn.version_eq header.Vmm_asn.version my_version) then + Lwt.return (Error (`Msg "ignoring data with bad version")) + else + match cmd with + | `Console_add -> add_fifo header.Vmm_asn.id + | `Console_subscribe -> subscribe s header.Vmm_asn.id + | `Console_data _ -> Lwt.return (Error (`Msg "unexpected command"))) >>= (function + | Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg)) + | Error (`Msg msg) -> + Logs.err (fun m -> m "error while processing command: %s" msg) ; + Vmm_lwt.write_wire s (header, `Failure msg)) >>= function + | Ok () -> loop () + | Error _ -> + Logs.err (fun m -> m "exception while writing to socket") ; + Lwt.return_unit + end + | Ok wire -> + Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire wire) ; loop () - | Ok (_, `Failure _) -> - Logs.err (fun m -> m "unexpected failure reply") ; - loop () - | Ok (header, `Command cmd) -> - (if not (Vmm_asn.version_eq header.Vmm_asn.version my_version) then - Lwt.return (Error (`Msg "ignoring data with bad version")) - else - match cmd with - | `Console_cmd `Console_add -> add_fifo header.Vmm_asn.id - | `Console_cmd `Console_subscribe -> subscribe s header.Vmm_asn.id - | _ -> Lwt.return (Error (`Msg "unexpected command"))) >>= (function - | Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg)) - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while processing command: %s" msg) ; - Vmm_lwt.write_wire s (header, `Failure msg)) >>= function - | Ok () -> loop () - | Error _ -> - Logs.err (fun m -> m "exception while writing to socket") ; - Lwt.return_unit in loop () >>= fun () -> Vmm_lwt.safe_close s >|= fun () -> diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index 61b6cbd..f2780e7 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -140,7 +140,7 @@ module P = struct vm ifd.name (String.concat ~sep:"," fields) end -let my_version = `WV2 +let my_version = `AV2 let command = ref 1L @@ -181,7 +181,6 @@ let rec read_sock_write_tcp c ?fd addr addrtype = None) >>= fun fd -> read_sock_write_tcp c ?fd addr addrtype | Some fd -> - let open Vmm_wire in Logs.debug (fun m -> m "reading from unix socket") ; Vmm_lwt.read_wire c >>= function | Error e -> @@ -190,60 +189,40 @@ let rec read_sock_write_tcp c ?fd addr addrtype = safe_close fd >>= fun () -> safe_close c >|= fun () -> true - | Ok (hdr, data) -> - if not (version_eq hdr.version my_version) then begin - Logs.err (fun m -> m "unknown wire protocol version") ; - safe_close fd >>= fun () -> - safe_close c >|= fun () -> - false - end else if Vmm_wire.is_fail hdr then begin - Logs.err (fun m -> m "failed to retrieve statistics") ; - safe_close fd >>= fun () -> - safe_close c >|= fun () -> - false - end else if Vmm_wire.is_reply hdr then begin - Logs.info (fun m -> m "received reply, continuing") ; - read_sock_write_tcp c ~fd addr addrtype - end else - (match Vmm_wire.Stats.int_to_op hdr.Vmm_wire.tag with - | Some Vmm_wire.Stats.Data -> - begin - let r = - let open Rresult.R.Infix in - Vmm_wire.decode_strings data >>= fun (id, off) -> - Vmm_wire.Stats.decode_stats (Cstruct.shift data off) >>| fun stats -> - (Vmm_core.string_of_id id, stats) - in - match r with - | Error (`Msg msg) -> - Logs.warn (fun m -> m "error %s while decoding stats, ignoring" msg) ; - Lwt.return (Some fd) - | Ok (name, (ru, vmm, ifs)) -> - let ru = P.encode_ru name ru in - let vmm = match vmm with [] -> [] | _ -> [ P.encode_vmm name vmm ] in - let taps = List.map (P.encode_if name) ifs in - let out = (String.concat ~sep:"\n" (ru :: vmm @ taps)) ^ "\n" in - Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ; - Vmm_lwt.write_wire fd (Cstruct.of_string out) >>= function - | Ok () -> - Logs.debug (fun m -> m "wrote successfully") ; - Lwt.return (Some fd) - | Error e -> - Logs.err (fun m -> m "error %s while writing to tcp (%s)" - (str_of_e e) name) ; - safe_close fd >|= fun () -> - None - end - | _ -> - Logs.err (fun m -> m "unhandled tag %lu" hdr.tag) ; - Lwt.return (Some fd)) >>= fun fd -> + | Ok (hdr, `Command (`Stats_cmd (`Stats_data (ru, vmm, ifs)))) -> + begin + if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin + Logs.err (fun m -> m "unknown wire protocol version") ; + safe_close fd >>= fun () -> + safe_close c >|= fun () -> + false + end else + let name = string_of_id hdr.Vmm_asn.id in + let ru = P.encode_ru name ru in + let vmm = match vmm with [] -> [] | _ -> [ P.encode_vmm name vmm ] in + let taps = List.map (P.encode_if name) ifs in + let out = (String.concat ~sep:"\n" (ru :: vmm @ taps)) ^ "\n" in + Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ; + Vmm_lwt.write_raw fd (Bytes.unsafe_of_string out) >>= function + | Ok () -> + Logs.debug (fun m -> m "wrote successfully") ; + read_sock_write_tcp c ~fd addr addrtype + | Error e -> + Logs.err (fun m -> m "error %s while writing to tcp (%s)" + (str_of_e e) name) ; + safe_close fd >|= fun () -> + false + end + | Ok wire -> + Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire wire) ; + Lwt.return (Some fd) >>= fun fd -> read_sock_write_tcp c ?fd addr addrtype let query_sock vm c = - let request = Vmm_wire.Stats.subscribe !command my_version vm in + let header = Vmm_asn.{ version = my_version ; sequence = !command ; id = vm } in command := Int64.succ !command ; Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id vm) ; - Vmm_lwt.write_wire c request + Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe)) let rec maybe_connect stat_socket = let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 26b488c..a0fe782 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -98,12 +98,6 @@ let handle mvar ring s addr () = | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (_, `Failure _) -> - Logs.warn (fun m -> m "ignoring failure") ; - loop () - | Ok (_, `Success _) -> - Logs.warn (fun m -> m "ignoring success") ; - loop () | Ok (hdr, `Command (`Log_cmd lc)) -> if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin Logs.warn (fun m -> m "unsupported version") ; @@ -140,8 +134,8 @@ let handle mvar ring s addr () = Lwt.return_unit | Ok () -> loop () (* TODO no need to loop ;) *) end - | _ -> - Logs.err (fun m -> m "unknown command") ; + | Ok wire -> + Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire wire) ; loop () in loop () >>= fun () -> diff --git a/pkg/pkg.ml b/pkg/pkg.ml index bd35027..e558c46 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -20,6 +20,6 @@ let () = Pkg.bin "provision/vmm_revoke" ; Pkg.bin "provision/vmm_gen_ca" ; *) (* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *) -(* Pkg.bin "stats/vmm_stats_lwt" ; - Pkg.bin "app/vmm_influxdb_stats" ; *) + Pkg.bin "stats/vmm_stats_lwt" ; + Pkg.bin "app/vmm_influxdb_stats" ; ] diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml index 9017109..fc59ec8 100644 --- a/src/vmm_lwt.ml +++ b/src/vmm_lwt.ml @@ -79,11 +79,7 @@ let read_wire s = else Lwt.return (Error `Eof) -let write_wire s wire = - let data = Vmm_asn.wire_to_cstruct wire in - let dlen = Cstruct.create 4 in - Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ; - let buf = Cstruct.(to_bytes (append dlen data)) in +let write_raw s buf = let rec w off l = Lwt.catch (fun () -> Lwt_unix.send s buf off l [] >>= fun n -> @@ -98,6 +94,13 @@ let write_wire s wire = (* Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *) w 0 (Bytes.length buf) +let write_wire s wire = + let data = Vmm_asn.wire_to_cstruct wire in + let dlen = Cstruct.create 4 in + Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ; + let buf = Cstruct.(to_bytes (append dlen data)) in + write_raw s buf + let safe_close fd = Lwt.catch (fun () -> Lwt_unix.close fd) diff --git a/src/vmm_lwt.mli b/src/vmm_lwt.mli index ea11a6d..c111b45 100644 --- a/src/vmm_lwt.mli +++ b/src/vmm_lwt.mli @@ -9,6 +9,8 @@ val wait_and_clear : val read_wire : Lwt_unix.file_descr -> (Vmm_asn.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t +val write_raw : + Lwt_unix.file_descr -> bytes -> (unit, [> `Exception ]) result Lwt.t val write_wire : Lwt_unix.file_descr -> Vmm_asn.wire -> (unit, [> `Exception ]) result Lwt.t val safe_close : Lwt_unix.file_descr -> unit Lwt.t diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index 9b34541..4c8e752 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -16,7 +16,9 @@ external vmmapi_close : vmctx -> unit = "vmmanage_vmmapi_close" external vmmapi_statnames : vmctx -> string list = "vmmanage_vmmapi_statnames" external vmmapi_stats : vmctx -> int64 list = "vmmanage_vmmapi_stats" -let my_version = `WV2 +let my_version = `AV2 + +let bcast = ref 0L let descr = ref [] @@ -117,10 +119,10 @@ let tick t = match Vmm_core.drop_super ~super:id ~sub:vmid with | None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.pp_id id Vmm_core.pp_id vmid) ; out | Some real_id -> - let name = Vmm_core.string_of_id real_id in - - let stats_encoded = Vmm_wire.Stats.(data 0L my_version name (encode_stats stats)) in - (socket, vmid, stats_encoded) :: out) + let header = Vmm_asn.{ version = my_version ; sequence = !bcast ; id = real_id } in + bcast := Int64.succ !bcast ; + let data = `Stats_data stats in + ((socket, vmid, (header, `Command (`Stats_cmd data))) :: out)) out xs) [] (Vmm_trie.all t'.vmid_pid) in @@ -171,29 +173,38 @@ let remove_vmid t vmid = let remove_vmids t vmids = List.fold_left remove_vmid t vmids -let handle t socket hdr cs = - let open Vmm_wire in - let open Vmm_wire.Stats in +let handle t socket (header, wire) = let r = - if not (version_eq my_version hdr.version) then + if not (Vmm_asn.version_eq my_version header.Vmm_asn.version) then Error (`Msg "cannot handle version") else - decode_strings cs >>= fun (id, off) -> - match int_to_op hdr.tag with - | Some Add -> - decode_pid_taps (Cstruct.shift cs off) >>= fun (pid, taps) -> - add_pid t id pid taps >>= fun t -> - Ok (t, `Add id, None, success ~msg:"added" my_version hdr.id (op_to_int Add)) - | Some Remove -> - let t = remove_vmid t id in - Ok (t, `Remove id, None, success ~msg:"removed" my_version hdr.id (op_to_int Remove)) - | Some Subscribe -> - let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in - Ok ({ t with name_sockets }, `None, close, success ~msg:"subscribed" my_version hdr.id (op_to_int Subscribe)) - | _ -> Error (`Msg "unknown command") + match wire with + | `Command (`Stats_cmd cmd) -> + begin + let id = header.Vmm_asn.id in + match cmd with + | `Stats_add (pid, taps) -> + add_pid t id pid taps >>= fun t -> + Ok (t, `Add id, None, Some "added") + | `Stats_remove -> + let t = remove_vmid t id in + Ok (t, `Remove id, None, Some "removed") + | `Stats_subscribe -> + let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in + Ok ({ t with name_sockets }, `None, close, Some "subscribed") + | _ -> Error (`Msg "unknown command") + end + | _ -> + Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire (header, wire)) ; + Ok (t, `None, None, None) in match r with - | Ok (t, action, close, out) -> t, action, close, out + | Ok (t, action, close, out) -> + let out = match out with + | None -> None + | Some str -> Some (header, `Success (`String str)) + in + t, action, close, out | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing %s" msg) ; - t, `None, None, fail ~msg my_version hdr.id + t, `None, None, Some (header, `Failure msg) diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml index 0300e4d..532bb11 100644 --- a/stats/vmm_stats_lwt.ml +++ b/stats/vmm_stats_lwt.ml @@ -27,8 +27,8 @@ let handle s addr () = Vmm_lwt.read_wire s >>= function | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop acc | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return acc - | Ok (hdr, data) -> - let t', action, close, out = Vmm_stats.handle !t s hdr data in + | Ok wire -> + let t', action, close, out = Vmm_stats.handle !t s wire in let acc = match action with | `Add pid -> pid :: acc | `Remove pid -> List.filter (fun m -> m <> pid) acc @@ -36,9 +36,12 @@ let handle s addr () = in t := t' ; (match close with None -> Lwt.return_unit | Some s' -> Vmm_lwt.safe_close s') >>= fun () -> - Vmm_lwt.write_wire s out >>= function - | Ok () -> loop acc - | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc + match out with + | None -> loop acc + | Some out -> + Vmm_lwt.write_wire s out >>= function + | Ok () -> loop acc + | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc in loop [] >>= fun vmids -> Vmm_lwt.safe_close s >|= fun () -> From 0441b8ab25590d102bf9493f5ee451c9d0c4918c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 00:12:06 +0200 Subject: [PATCH 30/73] tls endpoint --- app/vmm_tls_endpoint.ml | 29 ++++++++++++++++++----------- pkg/pkg.ml | 10 +++++----- src/vmm_x509.ml | 27 ++++++++++++++------------- 3 files changed, 37 insertions(+), 29 deletions(-) diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 087f3e2..633e66e 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -2,6 +2,10 @@ open Lwt.Infix +let my_version = `AV2 + +let command = ref 0L + let pp_sockaddr ppf = function | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str | Lwt_unix.ADDR_INET (addr, port) -> Fmt.pf ppf "TCP %s:%d" @@ -38,11 +42,10 @@ let read fd tls = (* now we busy read and process output *) let rec loop () = Vmm_lwt.read_wire fd >>= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop () | Error _ -> Lwt.return (Error (`Msg "exception while reading")) - | Ok (hdr, data) -> - let full = Cstruct.append (Vmm_wire.encode_header hdr) data in - Vmm_tls.write_tls tls full >>= function + | Ok wire -> + Logs.debug (fun m -> m "read proxying %a" Vmm_asn.pp_wire wire) ; + Vmm_tls.write_tls tls wire >>= function | Ok () -> loop () | Error `Exception -> Lwt.return (Error (`Msg "exception")) in @@ -50,11 +53,10 @@ let read fd tls = let process fd tls = Vmm_lwt.read_wire fd >>= function - | Error (`Msg m) -> Lwt.return (Error (`Msg m)) | Error _ -> Lwt.return (Error (`Msg "read error")) - | Ok (hdr, data) -> - let full = Cstruct.append (Vmm_wire.encode_header hdr) data in - Vmm_tls.write_tls tls full >|= function + | Ok wire -> + Logs.debug (fun m -> m "proxying %a" Vmm_asn.pp_wire wire) ; + Vmm_tls.write_tls tls wire >|= function | Ok () -> Ok () | Error `Exception -> Error (`Msg "exception on write") @@ -62,10 +64,15 @@ let handle ca (tls, addr) = client_auth ca tls addr >>= fun chain -> match Vmm_x509.handle addr chain with | Error (`Msg m) -> Lwt.fail_with m - | Ok cmd -> - let sock, next, cmd = Vmm_commands.handle cmd in + | Ok (name, cmd) -> + let sock, next = Vmm_commands.handle cmd in connect (Vmm_core.socket_path sock) >>= fun fd -> - Vmm_lwt.write_wire fd cmd >>= function + let wire = + let header = Vmm_asn.{version = my_version ; sequence = !command ; id = name } in + command := Int64.succ !command ; + (header, `Command cmd) + in + Vmm_lwt.write_wire fd wire >>= function | Error `Exception -> Lwt.return (Error (`Msg "couldn't write")) | Ok () -> (match next with diff --git a/pkg/pkg.ml b/pkg/pkg.ml index e558c46..07b8ee9 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -10,16 +10,16 @@ let () = Pkg.bin "app/vmmd" ; Pkg.bin "app/vmm_console" ; Pkg.bin "app/vmm_log" ; -(* Pkg.bin "app/vmm_client" ; - Pkg.bin "app/vmm_tls_endpoint" ; *) + (* Pkg.bin "app/vmm_client" ; *) + Pkg.bin "app/vmm_tls_endpoint" ; Pkg.bin "app/vmmc" ; -(* Pkg.bin "provision/vmm_req_command" ; + Pkg.bin "provision/vmm_req_command" ; 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.bin "provision/vmm_gen_ca" ; (* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *) Pkg.bin "stats/vmm_stats_lwt" ; - Pkg.bin "app/vmm_influxdb_stats" ; + Pkg.bin "app/vmm_influxdb_stats" ; ] diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index fbef56d..74b2e8a 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -29,24 +29,25 @@ let handle _addr chain = may need to create bridges and/or block device subdirectory (zfs create) *) (* let login_hdr, login_ev = Log.hdr name, `Login addr in *) Vmm_asn.command_of_cert asn_version leaf >>= function - | `Info -> Ok (`Info name) + | `Info -> Ok (name, `Vm_cmd `Vm_info) | `Create_vm -> (* TODO: update acl *) Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config -> - `Create_vm vm_config + (name, `Vm_cmd (`Vm_create vm_config)) | `Force_create_vm -> (* TODO: update acl *) Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config -> - `Force_create_vm vm_config - | `Destroy_vm -> Ok (`Destroy_vm name) - | `Statistics -> Ok (`Statistics name) - | `Console -> Ok (`Console name) - | `Log -> Ok (`Log name) - | `Crl -> Ok `Crl - | `Create_block -> - Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name -> + (name, `Vm_cmd (`Vm_force_create vm_config)) + | `Destroy_vm -> Ok (name, `Vm_cmd `Vm_destroy) + | `Statistics -> Ok (name, `Stats_cmd `Stats_subscribe) + | `Console -> Ok (name, `Console_cmd `Console_subscribe) + | `Log -> Ok (name, `Log_cmd `Log_subscribe) + | `Crl -> assert false + | `Create_block -> assert false +(* Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name -> Vmm_asn.block_size_of_cert asn_version leaf >>| fun block_size -> - `Create_block (block_name, block_size) - | `Destroy_block -> - Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name -> + `Create_block (block_name, block_size) *) + | `Destroy_block -> assert false +(* Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name -> `Destroy_block block_name +*) From 183d1c9e5815b18c1717b8a2ea8646aa9d776d6d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 00:40:39 +0200 Subject: [PATCH 31/73] toplevel for tls endpoint, client fixes --- app/vmm_client.ml | 12 +++--------- app/vmm_tls_endpoint.ml | 5 +++++ pkg/pkg.ml | 2 +- 3 files changed, 9 insertions(+), 10 deletions(-) diff --git a/app/vmm_client.ml b/app/vmm_client.ml index 51e6681..bebe90f 100644 --- a/app/vmm_client.ml +++ b/app/vmm_client.ml @@ -4,16 +4,10 @@ open Lwt.Infix let rec read_tls_write_cons t = Vmm_tls.read_tls t >>= function - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while reading %s" msg) ; - read_tls_write_cons t | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok data -> - match Vmm_commands.log_pp_reply data with - | Ok () -> read_tls_write_cons t - | Error (`Msg msg) -> - Logs.warn (fun m -> m "error %s while logging message" msg) ; - read_tls_write_cons t + | Ok wire -> + Logs.app (fun m -> m "%a" Vmm_asn.pp_wire wire) ; + read_tls_write_cons t let client cas host port cert priv_key = Nocrypto_entropy_lwt.initialize () >>= fun () -> diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 633e66e..852e090 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -165,3 +165,8 @@ let port = let doc = "TCP listen port" in Arg.(value & opt int 1025 & info [ "port" ] ~doc) +let cmd = + Term.(ret (const jump $ setup_log $ cacert $ cert $ key $ port)), + Term.info "vmm_tls_endpoint" ~version:"%%VERSION_NUM%%" + +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 07b8ee9..42012cc 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -10,7 +10,7 @@ let () = Pkg.bin "app/vmmd" ; Pkg.bin "app/vmm_console" ; Pkg.bin "app/vmm_log" ; - (* Pkg.bin "app/vmm_client" ; *) + Pkg.bin "app/vmm_client" ; Pkg.bin "app/vmm_tls_endpoint" ; Pkg.bin "app/vmmc" ; Pkg.bin "provision/vmm_req_command" ; From c399501a18985c24e36b796e500840eb361bb848 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 00:54:05 +0200 Subject: [PATCH 32/73] get rid of vm_config.vname --- app/vmmc.ml | 5 +---- app/vmmd.ml | 6 +++--- src/vmm_asn.ml | 5 ++--- src/vmm_asn.mli | 1 - src/vmm_core.ml | 10 ++-------- src/vmm_core.mli | 2 -- src/vmm_engine.ml | 40 ++++++++++++++++++++-------------------- src/vmm_engine.mli | 8 ++++---- src/vmm_resources.ml | 10 +++++----- src/vmm_resources.mli | 4 ++-- src/vmm_unix.ml | 33 +++++++++++---------------------- src/vmm_unix.mli | 8 +++----- 12 files changed, 53 insertions(+), 79 deletions(-) diff --git a/app/vmmc.ml b/app/vmmc.ml index d66ee7a..87d7745 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -94,10 +94,7 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc (* TODO we could do the compression btw *) and vmimage = `Hvt_amd64, Cstruct.of_string image' in - let vm_config = { - vname = name ; cpuid ; requested_memory ; block_device ; network ; - vmimage ; argv - } in + let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in let cmd = if force then `Vm_force_create vm_config diff --git a/app/vmmd.ml b/app/vmmd.ml index 1f89fba..fea7f31 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -47,18 +47,18 @@ let create c_fd process cont = | Error (`Msg msg) -> Logs.err (fun m -> m "create continuation failed %s" msg) ; Lwt.return_unit - | Ok (state'', out, vm) -> + | Ok (state'', out, name, vm) -> state := state'' ; s := { !s with vm_created = succ !s.vm_created } ; Lwt.async (fun () -> Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> - let state', out' = Vmm_engine.handle_shutdown !state vm r in + let state', out' = Vmm_engine.handle_shutdown !state name vm r in s := { !s with vm_destroyed = succ !s.vm_destroyed } ; state := state' ; process out' >|= fun () -> Lwt.wakeup wakeme ()) ; process out >>= fun () -> - let state', out = Vmm_engine.setup_stats !state vm in + let state', out = Vmm_engine.setup_stats !state name vm in state := state' ; process out (* TODO: need to read from stats socket! *) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index bd421f5..d7b1854 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -248,9 +248,8 @@ let vm_of_cert prefix cert = 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 = prefix @ [ id cert ] in let network = match network with None -> [] | Some x -> x in - Ok { vname ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } + Ok { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } let command_of_cert version cert = version_of_cert version cert >>= fun () -> @@ -508,7 +507,7 @@ let pp_vm_cmd ppf = function let vm_config = let f (cpuid, requested_memory, block_device, network, vmimage, argv) = let network = match network with None -> [] | Some xs -> xs in - { vname = [] ; cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } + { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } and g vm = let network = match vm.network with [] -> None | xs -> Some xs in (vm.cpuid, vm.requested_memory, vm.block_device, network, vm.vmimage, vm.argv) diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 9094932..80c60ee 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -233,4 +233,3 @@ type log_entry = header * Ptime.t * Log.event val log_entry_to_cstruct : log_entry -> Cstruct.t val log_entry_of_cstruct : Cstruct.t -> (log_entry, [> `Msg of string ]) result - diff --git a/src/vmm_core.ml b/src/vmm_core.ml index e58e95f..cc03fc6 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -160,7 +160,6 @@ let is_sub ~super ~sub = sub_bridges super.bridges sub.bridges && sub_block super.block sub.block type vm_config = { - vname : id ; cpuid : int ; requested_memory : int ; block_device : string option ; @@ -169,18 +168,13 @@ type vm_config = { argv : string list option ; } -(* used for block devices *) -let location vm = match vm.vname with - | tld::rest -> tld, String.concat ~sep:"." rest - | [] -> invalid_arg "dunno how this happened" - let pp_image ppf (typ, blob) = let l = Cstruct.len blob in Fmt.pf ppf "%a: %d bytes" pp_vmtype typ l let pp_vm_config ppf (vm : vm_config) = - Fmt.pf ppf "%a cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a" - pp_id vm.vname vm.cpuid vm.requested_memory + Fmt.pf ppf "cpu %d, %d MB memory, block device %a@ bridge %a, image %a, argv %a" + vm.cpuid vm.requested_memory Fmt.(option ~none:(unit "no") string) vm.block_device Fmt.(list ~sep:(unit ", ") string) vm.network pp_image vm.vmimage diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 6c0bd83..979605b 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -204,7 +204,6 @@ val sub_block : 'a option -> 'a option -> bool val sub_cpu : IS.t -> IS.t -> bool val is_sub : super:policy -> sub:policy -> bool type vm_config = { - vname : id; cpuid : int; requested_memory : int; block_device : string option; @@ -212,7 +211,6 @@ type vm_config = { vmimage : vmtype * Cstruct.t; argv : string list option; } -val location : vm_config -> string * string val pp_image : Format.formatter -> [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] * Cstruct.t -> unit diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index af9c47b..8fdc605 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -47,28 +47,28 @@ let log t id event = let handle_create t hdr vm_config = (* TODO fix (remove field?) *) - let vm_config = { vm_config with vname = hdr.Vmm_asn.id } in - (match Vmm_resources.find_vm t.resources vm_config.vname with + let name = hdr.Vmm_asn.id in + (match Vmm_resources.find_vm t.resources name with | Some _ -> Error (`Msg "VM with same name is already running") | None -> Ok ()) >>= fun () -> Logs.debug (fun m -> m "now checking resource policies") ; - (if Vmm_resources.check_vm_policy t.resources vm_config then + (if Vmm_resources.check_vm_policy t.resources name vm_config then Ok () else Error (`Msg "resource policies don't allow this")) >>= fun () -> (* prepare VM: save VM image to disk, create fifo, ... *) - Vmm_unix.prepare vm_config >>= fun taps -> + Vmm_unix.prepare name vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; (* TODO should we pre-reserve sth in t? *) let cons = `Console_add in - let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = vm_config.vname } in + let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons (header, `Command (`Console_cmd cons)) ], `Create (fun t task -> (* actually execute the vm *) - Vmm_unix.exec vm_config taps >>= fun vm -> + Vmm_unix.exec name vm_config taps >>= fun vm -> Logs.debug (fun m -> m "exec()ed vm") ; - Vmm_resources.insert_vm t.resources vm >>= fun resources -> - let tasks = String.Map.add (string_of_id vm_config.vname) task t.tasks in + Vmm_resources.insert_vm t.resources name vm >>= fun resources -> + let tasks = String.Map.add (string_of_id name) task t.tasks in let used_bridges = List.fold_left2 (fun b br ta -> let old = match String.Map.find br b with @@ -79,21 +79,21 @@ let handle_create t hdr vm_config = t.used_bridges vm_config.network taps in let t = { t with resources ; tasks ; used_bridges } in - let t, out = log t vm_config.vname (`VM_start (vm.pid, vm.taps, None)) in + let t, out = log t name (`VM_start (vm.pid, vm.taps, None)) in let data = `Success (`String "created VM") in - Ok (t, [ `Data (hdr, data) ; out ], vm))) + Ok (t, [ `Data (hdr, data) ; out ], name, vm))) -let setup_stats t vm = +let setup_stats t name vm = let stat_out = `Stats_add (vm.pid, vm.taps) in - let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = vm.config.vname } in + let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let t = { t with stats_counter = Int64.succ t.stats_counter } in t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ] -let handle_shutdown t vm r = - (match Vmm_unix.shutdown vm with +let handle_shutdown t name vm r = + (match Vmm_unix.shutdown name vm with | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; - let resources = Vmm_resources.remove t.resources vm.config.vname in + let resources = Vmm_resources.remove t.resources name in let used_bridges = List.fold_left2 (fun b br ta -> let old = match String.Map.find br b with @@ -104,10 +104,10 @@ let handle_shutdown t vm r = t.used_bridges vm.config.network vm.taps in let stat_out = `Stats_remove in - let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = vm.config.vname } in - let tasks = String.Map.remove (string_of_id vm.config.vname) t.tasks in + let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in + let tasks = String.Map.remove (string_of_id name) t.tasks in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in - let t, logout = log t vm.config.vname (`VM_stop (vm.pid, r)) + let t, logout = log t name (`VM_stop (vm.pid, r)) in (t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ; logout ]) @@ -172,8 +172,8 @@ let handle_command t (header, payload) = | `Command (`Vm_cmd (`Vm_create vm_config)) -> handle_create t header vm_config | `Command (`Vm_cmd (`Vm_force_create vm_config)) -> - let resources = Vmm_resources.remove t.resources vm_config.vname in - if Vmm_resources.check_vm_policy resources vm_config then + let resources = Vmm_resources.remove t.resources id in + if Vmm_resources.check_vm_policy resources id vm_config then begin match Vmm_resources.find_vm t.resources id with | None -> handle_create t header vm_config | Some vm -> diff --git a/src/vmm_engine.mli b/src/vmm_engine.mli index af6d787..bf119a5 100644 --- a/src/vmm_engine.mli +++ b/src/vmm_engine.mli @@ -11,16 +11,16 @@ type service_out = [ type out = [ service_out | `Data of Vmm_asn.wire ] -val handle_shutdown : 'a t -> Vmm_core.vm -> +val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm -> [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list val handle_command : 'a t -> Vmm_asn.wire -> 'a t * out list * - [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.vm, [> Rresult.R.msg ]) result + [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result | `End | `Wait of 'a * out list | `Wait_and_create of 'a * ('a t -> 'a t * out list * - [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.vm, [> Rresult.R.msg ]) result + [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result | `End ]) ] -val setup_stats : 'a t -> Vmm_core.vm -> 'a t * out list +val setup_stats : 'a t -> Vmm_core.id -> Vmm_core.vm -> 'a t * out list diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index a3be201..55d2932 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -50,17 +50,17 @@ let find_vm t name = match Vmm_trie.find name t with | Some (Vm vm) -> Some vm | _ -> None -let check_vm_policy t vm = - let dom = domain vm.vname in +let check_vm_policy t name vm = + let dom = domain name in let res = resource_usage t dom in match Vmm_trie.find dom t with | None -> true | Some (Vm _) -> assert false | Some (Policy p) -> check_resource p vm res -let insert_vm t vm = - if check_vm_policy t vm.config then - match Vmm_trie.insert vm.config.vname (Vm vm) t with +let insert_vm t name vm = + if check_vm_policy t name vm.config then + match Vmm_trie.insert name (Vm vm) t with | t', None -> Ok t' | _, Some _ -> Error (`Msg "vm already exists") else diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index 9878c65..ced6a6b 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -22,11 +22,11 @@ val find_vm : t -> Vmm_core.id -> Vmm_core.vm option (** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be allowed under the current policies. *) -val check_vm_policy : t -> Vmm_core.vm_config -> bool +val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> bool (** [insert_vm t vm] inserts [vm] under [id] in [t], and returns the new [t] or an error. *) -val insert_vm : t -> Vmm_core.vm -> (t, [> `Msg of string]) result +val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) result (** [insert_policy t id policy] inserts [policy] under [id] in [t], and returns the new [t] or an error. *) diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index 3b17165..b6cb824 100644 --- a/src/vmm_unix.ml +++ b/src/vmm_unix.ml @@ -58,8 +58,8 @@ let rec mkfifo name = | Unix.Unix_error (Unix.EINTR, _, _) -> mkfifo name let image_file, fifo_file = - ((fun vm -> Fpath.(tmpdir / (string_of_id vm.vname) + "img")), - (fun vm -> Fpath.(tmpdir / "fifo" / (string_of_id vm.vname)))) + ((fun name -> Fpath.(tmpdir / (string_of_id name) + "img")), + (fun name -> Fpath.(tmpdir / "fifo" / (string_of_id name)))) let rec fifo_exists file = try Ok (Unix.((stat @@ Fpath.to_string file).st_kind = S_FIFO)) with @@ -103,18 +103,7 @@ let destroy_tap tapname = 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 prepare name vm = (match vm.vmimage with | `Hvt_amd64, blob -> Ok blob | `Hvt_amd64_compressed, blob -> @@ -123,7 +112,7 @@ let prepare vm = | Error () -> Error (`Msg "failed to uncompress") end | `Hvt_arm64, _ -> Error (`Msg "no amd64 hvt image found")) >>= fun image -> - let fifo = fifo_file vm in + let fifo = fifo_file name in (match fifo_exists fifo with | Ok true -> Ok () | Ok false -> Error (`Msg ("file " ^ Fpath.to_string fifo ^ " exists and is not a fifo")) @@ -137,13 +126,13 @@ let prepare vm = create_tap b >>= fun tap -> Ok (tap :: acc)) (Ok []) vm.network >>= fun taps -> - Bos.OS.File.write (image_file vm) (Cstruct.to_string image) >>= fun () -> + Bos.OS.File.write (image_file name) (Cstruct.to_string image) >>= fun () -> Ok (List.rev taps) -let shutdown vm = +let shutdown name vm = (* same order as prepare! *) - Bos.OS.File.delete (image_file vm.config) >>= fun () -> - Bos.OS.File.delete (fifo_file vm.config) >>= fun () -> + Bos.OS.File.delete (image_file name) >>= fun () -> + Bos.OS.File.delete (fifo_file name) >>= fun () -> List.fold_left (fun r n -> r >>= fun () -> destroy_tap n) (Ok ()) vm.taps let cpuset cpu = @@ -156,7 +145,7 @@ let cpuset cpu = Ok ([ "taskset" ; "-c" ; cpustring ]) | x -> Error (`Msg ("unsupported operating system " ^ x)) -let exec vm taps = +let exec name vm taps = (* TODO: --net-mac=xx *) let net = List.map (fun t -> "--net=" ^ t) taps in let argv = match vm.argv with None -> [] | Some xs -> xs in @@ -168,12 +157,12 @@ let exec vm taps = let mem = "--mem=" ^ string_of_int vm.requested_memory in let cmd = Bos.Cmd.(of_list cpuset % p bin % mem %% of_list net % - "--" % p (image_file vm) %% of_list argv) + "--" % p (image_file name) %% of_list argv) in let line = Bos.Cmd.to_list cmd in let prog = try List.hd line with Failure _ -> failwith err_empty_line in let line = Array.of_list line in - let fifo = fifo_file vm in + let fifo = fifo_file name in Logs.debug (fun m -> m "write fd for fifo %a" Fpath.pp fifo); write_fd_for_file fifo >>= fun stdout -> Logs.debug (fun m -> m "opened file descriptor!"); diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli index 5c79b2f..8a4d9d3 100644 --- a/src/vmm_unix.mli +++ b/src/vmm_unix.mli @@ -4,16 +4,14 @@ open Rresult open Vmm_core -val prepare : vm_config -> (string list, [> R.msg ]) result +val prepare : id -> vm_config -> (string list, [> R.msg ]) result -val shutdown : vm -> (unit, [> R.msg ]) result +val shutdown : id -> vm -> (unit, [> R.msg ]) result -val exec : vm_config -> string list -> (vm, [> R.msg ]) result +val exec : id -> vm_config -> string list -> (vm, [> R.msg ]) result val destroy : vm -> unit val close_no_err : Unix.file_descr -> unit val create_tap : string -> (string, [> R.msg ]) result - -val create_bridge : string -> (unit, [> R.msg ]) result From 811f3abc50ddc6b78a70efcd384602b08cdc87c4 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 01:02:14 +0200 Subject: [PATCH 33/73] adjustments --- app/vmmc.ml | 2 +- src/vmm_asn.ml | 16 +++-- src/vmm_asn.mli | 2 +- src/vmm_engine.ml | 148 +++++++++++++++++++++--------------------- src/vmm_resources.ml | 2 +- src/vmm_resources.mli | 3 +- 6 files changed, 90 insertions(+), 83 deletions(-) diff --git a/app/vmmc.ml b/app/vmmc.ml index 87d7745..04ca11f 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -167,7 +167,7 @@ let remove_policy_cmd = `P "Removes a policy."] in Term.(ret (const remove_policy $ setup_log $ socket $ opt_vmname)), - Term.info "remove" ~doc ~man + Term.info "remove_policy" ~doc ~man let info_cmd = let doc = "information about VMs" in diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index d7b1854..d0e4ed7 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -628,13 +628,13 @@ let header = (required ~label:"sequence" int64) (required ~label:"id" (sequence_of utf8_string))) -type success = [ `Empty | `String of string | `Policies of policy list | `Vms of vm_config list ] +type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ] let pp_success ppf = function | `Empty -> Fmt.string ppf "success" | `String data -> Fmt.pf ppf "success: %s" data - | `Policies ps -> Fmt.(list ~sep:(unit "@.") pp_policy) ppf ps - | `Vms vms -> Fmt.(list ~sep:(unit "@.") pp_vm_config) ppf vms + | `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps + | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms type wire = header * [ | `Command of wire_command @@ -685,8 +685,14 @@ let wire = (explicit 1 (choice4 (explicit 0 null) (explicit 1 utf8_string) - (explicit 2 (sequence_of policy_obj)) - (explicit 3 (sequence_of vm_config)))) + (explicit 2 (sequence_of + (sequence2 + (required ~label:"name" (sequence_of utf8_string)) + (required ~label:"policy" policy_obj)))) + (explicit 3 (sequence_of + (sequence2 + (required ~label:"name" (sequence_of utf8_string)) + (required ~label:"vm_config" vm_config)))))) (explicit 2 utf8_string)))) let wire_of_cstruct, wire_to_cstruct = projections_of wire diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 80c60ee..fa4de53 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -219,7 +219,7 @@ type header = { type wire = header * [ | `Command of wire_command - | `Success of [ `Empty | `String of string | `Policies of policy list | `Vms of vm_config list ] + | `Success of [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ] | `Failure of string ] val pp_wire : wire Fmt.t diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 8fdc605..7fd35c5 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -122,86 +122,86 @@ let handle_command t (header, payload) = msg_to_err ( let id = header.Vmm_asn.id in match payload with - | `Failure f -> - Logs.warn (fun m -> m "ignoring failure %s" f) ; - Ok (t, [], `End) - | `Success _ -> - Logs.warn (fun m -> m "ignoring success") ; - Ok (t, [], `End) - | `Command (`Policy_cmd `Policy_remove) -> - Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_asn.id) ; - let resources = Vmm_resources.remove t.resources id in - Ok ({ t with resources }, [ `Data (header, `Success (`String "removed policy")) ], `End) - | `Command (`Policy_cmd (`Policy_add policy)) -> - Logs.debug (fun m -> m "insert policy %a" pp_id id) ; - Vmm_resources.insert_policy t.resources id policy >>= fun resources -> - Ok ({ t with resources }, [ `Data (header, `Success (`String "added policy")) ], `End) - | `Command (`Policy_cmd `Policy_info) -> - begin - Logs.debug (fun m -> m "policy %a" pp_id id) ; - let policies = - Vmm_resources.fold t.resources id - (fun _ policies -> policies) - (fun prefix policy policies-> (prefix, policy) :: policies) - [] - in - match policies with - | [] -> - Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ; - Error (`Msg "policy: not found") - | _ -> - Ok (t, [ `Data (header, `Success (`Policies policies)) ], `End) + | `Command (`Policy_cmd pc) -> + begin match pc with + | `Policy_remove -> + Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_asn.id) ; + let resources = Vmm_resources.remove t.resources id in + Ok ({ t with resources }, [ `Data (header, `Success (`String "removed policy")) ], `End) + | `Policy_add policy -> + Logs.debug (fun m -> m "insert policy %a" pp_id id) ; + Vmm_resources.insert_policy t.resources id policy >>= fun resources -> + Ok ({ t with resources }, [ `Data (header, `Success (`String "added policy")) ], `End) + | `Policy_info -> + begin + Logs.debug (fun m -> m "policy %a" pp_id id) ; + let policies = + Vmm_resources.fold t.resources id + (fun _ _ policies -> policies) + (fun prefix policy policies-> (prefix, policy) :: policies) + [] + in + match policies with + | [] -> + Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ; + Error (`Msg "policy: not found") + | _ -> + Ok (t, [ `Data (header, `Success (`Policies policies)) ], `End) + end end - | `Command (`Vm_cmd `Vm_info) -> - begin + | `Command (`Vm_cmd vc) -> + begin match vc with + | `Vm_info -> Logs.debug (fun m -> m "info %a" pp_id id) ; let vms = Vmm_resources.fold t.resources id - (fun vm vms -> vm :: vms) + (fun id vm vms -> (id, vm.config) :: vms) (fun _ _ vms-> vms) [] in - match vms with - | [] -> - Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ; - Error (`Msg "info: not found") - | _ -> - let vm_configs = List.map (fun vm -> vm.config) vms in - Ok (t, [ `Data (header, `Success (`Vms vm_configs)) ], `End) - end - | `Command (`Vm_cmd (`Vm_create vm_config)) -> - handle_create t header vm_config - | `Command (`Vm_cmd (`Vm_force_create vm_config)) -> - let resources = Vmm_resources.remove t.resources id in - if Vmm_resources.check_vm_policy resources id vm_config then - begin match Vmm_resources.find_vm t.resources id with - | None -> handle_create t header vm_config - | Some vm -> - Vmm_unix.destroy vm ; - let id_str = string_of_id id in - match String.Map.find_opt id_str t.tasks with - | None -> handle_create t header vm_config - | Some task -> + begin match vms with + | [] -> + Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ; + Error (`Msg "info: not found") + | _ -> + Ok (t, [ `Data (header, `Success (`Vms vms)) ], `End) + end + | `Vm_create vm_config -> + handle_create t header vm_config + | `Vm_force_create vm_config -> + let resources = Vmm_resources.remove t.resources id in + if Vmm_resources.check_vm_policy resources id vm_config then + begin match Vmm_resources.find_vm t.resources id with + | None -> handle_create t header vm_config + | Some vm -> + Vmm_unix.destroy vm ; + let id_str = string_of_id id in + match String.Map.find_opt id_str t.tasks with + | None -> handle_create t header vm_config + | Some task -> + let tasks = String.Map.remove id_str t.tasks in + let t = { t with tasks } in + Ok (t, [], `Wait_and_create + (task, fun t -> msg_to_err @@ handle_create t header vm_config)) + end + else + Error (`Msg "wouldn't match policy") + | `Vm_destroy -> + begin match Vmm_resources.find_vm t.resources id with + | Some vm -> + Vmm_unix.destroy vm ; + let id_str = string_of_id id in + let out, next = + let s = [ `Data (header, `Success (`String "destroyed vm")) ] in + match String.Map.find_opt id_str t.tasks with + | None -> s, `End + | Some t -> [], `Wait (t, s) + in let tasks = String.Map.remove id_str t.tasks in - let t = { t with tasks } in - Ok (t, [], `Wait_and_create - (task, fun t -> msg_to_err @@ handle_create t header vm_config)) - end - else - Error (`Msg "wouldn't match policy") - | `Command (`Vm_cmd `Vm_destroy) -> - begin match Vmm_resources.find_vm t.resources id with - | Some vm -> - Vmm_unix.destroy vm ; - let id_str = string_of_id id in - let out, next = - let s = [ `Data (header, `Success (`String "destroyed vm")) ] in - match String.Map.find_opt id_str t.tasks with - | None -> s, `End - | Some t -> [], `Wait (t, s) - in - let tasks = String.Map.remove id_str t.tasks in - Ok ({ t with tasks }, out, next) - | None -> Error (`Msg "destroy: not found") + Ok ({ t with tasks }, out, next) + | None -> Error (`Msg "destroy: not found") + end end - | _ -> Error (`Msg "unknown command")) + | _ -> + Logs.err (fun m -> m "ignoring %a" Vmm_asn.pp_wire (header, payload)) ; + Error (`Msg "unknown command")) diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 55d2932..f51799b 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -33,7 +33,7 @@ let remove t name = Vmm_trie.remove name t let fold t name f g acc = Vmm_trie.fold name t (fun prefix entry acc -> match entry with - | Vm vm -> f vm acc + | Vm vm -> f prefix vm acc | Policy p -> g prefix p acc) acc (* we should hide this type and confirm the following invariant: diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index ced6a6b..d41d64a 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -36,5 +36,6 @@ val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string val remove : t -> Vmm_core.id -> t (** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *) -val fold : t -> Vmm_core.id -> (Vmm_core.vm -> 'a -> 'a) -> +val fold : t -> Vmm_core.id -> + (Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) -> (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a From a08f35ee5e9b80e17715f84f4696011e3259a93f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 01:36:44 +0200 Subject: [PATCH 34/73] cleanups --- src/vmm_asn.ml | 13 +++---------- src/vmm_asn.mli | 7 ------- src/vmm_engine.ml | 9 +++++---- src/vmm_unix.mli | 2 -- 4 files changed, 8 insertions(+), 23 deletions(-) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index d0e4ed7..dc53d72 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -103,7 +103,7 @@ let strings_of_cstruct, strings_to_cstruct = let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string -let policy_obj = +let policy = let f (cpuids, vms, memory, block, bridges) = let bridges = match bridges with | xs -> @@ -127,13 +127,6 @@ let policy_obj = (optional ~label:"block" int) (required ~label:"bridges" Asn.S.(sequence_of bridge))) -let policy_of_cstruct, policy_to_cstruct = - let c = Asn.codec Asn.der policy_obj in - ((fun cs -> match Asn.decode c cs with - | Ok x -> Ok x - | Error (`Parse msg) -> Error (`Msg msg)), - Asn.encode c) - let image = let f = function | `C1 x -> `Hvt_amd64, x @@ -564,7 +557,7 @@ let policy_cmd = Asn.S.map f g @@ Asn.S.(choice3 (explicit 0 null) - (explicit 1 policy_obj) + (explicit 1 policy) (explicit 2 null)) let version = @@ -688,7 +681,7 @@ let wire = (explicit 2 (sequence_of (sequence2 (required ~label:"name" (sequence_of utf8_string)) - (required ~label:"policy" policy_obj)))) + (required ~label:"policy" policy)))) (explicit 3 (sequence_of (sequence2 (required ~label:"name" (sequence_of utf8_string)) diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index fa4de53..03f28df 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -139,13 +139,6 @@ val strings_to_cstruct : string list -> Cstruct.t encoded [buffer] or an error. *) val strings_of_cstruct : Cstruct.t -> (string list, [> `Msg of string ]) result -(** [policy_to_cstruct xs] is the DER encoded policy. *) -val policy_to_cstruct : Vmm_core.policy -> Cstruct.t - -(** [policy_of_cstruct buffer] is either a decoded policy of the DER - encoded [buffer] or an error. *) -val policy_of_cstruct : Cstruct.t -> (Vmm_core.policy * Cstruct.t, [> `Msg of string ]) result - (** {1 Decoding functions} *) (** [contains_vm cert] is [true] if the certificate contains a virtual machine image. *) diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 7fd35c5..7145e62 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -46,7 +46,6 @@ let log t id event = ({ t with log_counter }, `Log (header, `Command (`Log_cmd data))) let handle_create t hdr vm_config = - (* TODO fix (remove field?) *) let name = hdr.Vmm_asn.id in (match Vmm_resources.find_vm t.resources name with | Some _ -> Error (`Msg "VM with same name is already running") @@ -60,9 +59,11 @@ let handle_create t hdr vm_config = Vmm_unix.prepare name vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; (* TODO should we pre-reserve sth in t? *) - let cons = `Console_add in - let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in - Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons (header, `Command (`Console_cmd cons)) ], + let cons_out = + let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in + (header, `Command (`Console_cmd `Console_add)) + in + Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons_out ], `Create (fun t task -> (* actually execute the vm *) Vmm_unix.exec name vm_config taps >>= fun vm -> diff --git a/src/vmm_unix.mli b/src/vmm_unix.mli index 8a4d9d3..bc99008 100644 --- a/src/vmm_unix.mli +++ b/src/vmm_unix.mli @@ -13,5 +13,3 @@ val exec : id -> vm_config -> 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 From d6c87bacde2b257ea38fa48dcc41727176de580f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 01:48:24 +0200 Subject: [PATCH 35/73] minor tweaks --- provision/vmm_provision.ml | 22 +--- provision/vmm_revoke.ml | 24 +++- src/vmm_core.ml | 29 ----- src/vmm_core.mli | 232 ++++++++----------------------------- 4 files changed, 73 insertions(+), 234 deletions(-) diff --git a/provision/vmm_provision.ml b/provision/vmm_provision.ml index 0103eda..b8a2e98 100644 --- a/provision/vmm_provision.ml +++ b/provision/vmm_provision.ml @@ -57,19 +57,6 @@ let sign ?dbname ?certname extensions issuer key csr delta = match nam with | `CN name -> Ok name | _ -> Error (`Msg "cannot happen")) >>= fun certname -> - (match dbname with - | None -> Ok None - | Some dbname -> - Bos.OS.File.exists dbname >>= function - | false -> Ok None - | true -> - Bos.OS.File.read_lines dbname >>= fun content -> - Vmm_core.parse_db content >>= fun db -> - match Vmm_core.find_name db certname with - | Ok serial -> - Logs.info (fun m -> m "reusing serial %s" (Z.to_string serial)) ; - Ok (Some serial) - | Error _ -> Ok None) >>= fun serial -> timestamps delta >>= fun (valid_from, valid_until) -> let extensions = match dbname with @@ -80,11 +67,10 @@ let sign ?dbname ?certname extensions issuer key csr delta = let capub = `RSA (Nocrypto.Rsa.pub_of_priv priv) in extensions @ key_ids (X509.CA.info csr).X509.CA.public_key capub in - let cert = X509.CA.sign csr ?serial ~valid_from ~valid_until ~extensions key issuer in - (match serial, dbname with - | Some _, _ -> Ok () (* already in DB! *) - | _, None -> Ok () (* no DB! *) - | None, Some dbname -> + let cert = X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer in + (match dbname with + | None -> Ok () (* no DB! *) + | Some dbname -> append dbname (Printf.sprintf "%s %s\n" (Z.to_string (X509.serial cert)) certname)) >>= fun () -> let enc = X509.Encoding.Pem.Certificate.to_pem_cstruct1 cert in Bos.OS.File.write Fpath.(v certname + "pem") (Cstruct.to_string enc) diff --git a/provision/vmm_revoke.ml b/provision/vmm_revoke.ml index 66239b6..84a8e78 100644 --- a/provision/vmm_revoke.ml +++ b/provision/vmm_revoke.ml @@ -6,6 +6,26 @@ open Astring open Rresult.R.Infix + +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 jump _ db cacert cakey crl cn serial = Nocrypto_entropy_unix.initialize () ; match @@ -14,8 +34,8 @@ let jump _ db cacert cakey crl cn serial = (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 + parse_db entries >>= fun db -> + 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 diff --git a/src/vmm_core.ml b/src/vmm_core.ml index cc03fc6..f27a928 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -229,35 +229,6 @@ let id cert = identifier (X509.serial cert) let name cert = X509.common_name_to_string 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 *) diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 979605b..fa9c71c 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -4,126 +4,20 @@ val socket_path : [< `Console | `Log | `Stats | `Vmmd ] -> string val pp_socket : Format.formatter -> [< `Console | `Log | `Stats | `Vmmd ] -> unit module I : sig type t = int val compare : int -> int -> int end -module IS : - sig - type elt = I.t - type t = Set.Make(I).t - val empty : t - val is_empty : t -> bool - val mem : elt -> t -> bool - val add : elt -> t -> t - val singleton : elt -> t - val remove : elt -> t -> t - val union : t -> t -> t - val inter : t -> t -> t - val diff : t -> t -> t - val compare : t -> t -> int - val equal : t -> t -> bool - val subset : t -> t -> bool - val iter : (elt -> unit) -> t -> unit - val map : (elt -> elt) -> t -> t - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - val for_all : (elt -> bool) -> t -> bool - val exists : (elt -> bool) -> t -> bool - val filter : (elt -> bool) -> t -> t - val partition : (elt -> bool) -> t -> t * t - val cardinal : t -> int - val elements : t -> elt list - val min_elt : t -> elt - val min_elt_opt : t -> elt option - val max_elt : t -> elt - val max_elt_opt : t -> elt option - val choose : t -> elt - val choose_opt : t -> elt option - val split : elt -> t -> t * bool * t - val find : elt -> t -> elt - val find_opt : elt -> t -> elt option - val find_first : (elt -> bool) -> t -> elt - val find_first_opt : (elt -> bool) -> t -> elt option - val find_last : (elt -> bool) -> t -> elt - val find_last_opt : (elt -> bool) -> t -> elt option - val of_list : elt list -> t - end -module IM : - sig - type key = I.t - type 'a t = 'a Map.Make(I).t - val empty : 'a t - val is_empty : 'a t -> bool - val mem : key -> 'a t -> bool - val add : key -> 'a -> 'a t -> 'a t - val update : key -> ('a option -> 'a option) -> 'a t -> 'a t - val singleton : key -> 'a -> 'a t - val remove : key -> 'a t -> 'a t - val merge : - (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t - val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val iter : (key -> 'a -> unit) -> 'a t -> unit - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val for_all : (key -> 'a -> bool) -> 'a t -> bool - val exists : (key -> 'a -> bool) -> 'a t -> bool - val filter : (key -> 'a -> bool) -> 'a t -> 'a t - val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t - val cardinal : 'a t -> int - val bindings : 'a t -> (key * 'a) list - val min_binding : 'a t -> key * 'a - val min_binding_opt : 'a t -> (key * 'a) option - val max_binding : 'a t -> key * 'a - val max_binding_opt : 'a t -> (key * 'a) option - val choose : 'a t -> key * 'a - val choose_opt : 'a t -> (key * 'a) option - val split : key -> 'a t -> 'a t * 'a option * 'a t - val find : key -> 'a t -> 'a - val find_opt : key -> 'a t -> 'a option - val find_first : (key -> bool) -> 'a t -> key * 'a - val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option - val find_last : (key -> bool) -> 'a t -> key * 'a - val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option - val map : ('a -> 'b) -> 'a t -> 'b t - val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t - end -module IM64 : - sig - type key = Int64.t - type 'a t = 'a Map.Make(Int64).t - val empty : 'a t - val is_empty : 'a t -> bool - val mem : key -> 'a t -> bool - val add : key -> 'a -> 'a t -> 'a t - val update : key -> ('a option -> 'a option) -> 'a t -> 'a t - val singleton : key -> 'a -> 'a t - val remove : key -> 'a t -> 'a t - val merge : - (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t - val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val iter : (key -> 'a -> unit) -> 'a t -> unit - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val for_all : (key -> 'a -> bool) -> 'a t -> bool - val exists : (key -> 'a -> bool) -> 'a t -> bool - val filter : (key -> 'a -> bool) -> 'a t -> 'a t - val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t - val cardinal : 'a t -> int - val bindings : 'a t -> (key * 'a) list - val min_binding : 'a t -> key * 'a - val min_binding_opt : 'a t -> (key * 'a) option - val max_binding : 'a t -> key * 'a - val max_binding_opt : 'a t -> (key * 'a) option - val choose : 'a t -> key * 'a - val choose_opt : 'a t -> (key * 'a) option - val split : key -> 'a t -> 'a t * 'a option * 'a t - val find : key -> 'a t -> 'a - val find_opt : key -> 'a t -> 'a option - val find_first : (key -> bool) -> 'a t -> key * 'a - val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option - val find_last : (key -> bool) -> 'a t -> key * 'a - val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option - val map : ('a -> 'b) -> 'a t -> 'b t - val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t - end + +module IS : sig + include Set.S with type elt = I.t +end +val pp_is : IS.t Fmt.t + +module IM : sig + include Map.S with type key = I.t +end + +module IM64 : sig + include Map.S with type key = Int64.t +end + type command = [ `Console | `Create_block @@ -135,56 +29,28 @@ type command = | `Info | `Log | `Statistics ] -val pp_command : - Format.formatter -> - [< `Console - | `Create_block - | `Create_vm - | `Crl - | `Destroy_block - | `Destroy_vm - | `Force_create_vm - | `Info - | `Log - | `Statistics ] -> - unit -val command_of_string : - string -> - [> `Console - | `Create_block - | `Create_vm - | `Crl - | `Destroy_block - | `Destroy_vm - | `Force_create_vm - | `Info - | `Log - | `Statistics ] - option +val pp_command : command Fmt.t + +val command_of_string : string -> command option + type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -val vmtype_to_int : - [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -> int -val int_to_vmtype : - int -> [> `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] option -val pp_vmtype : - Format.formatter -> - [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -> unit +val vmtype_to_int : vmtype -> int +val int_to_vmtype : int -> vmtype option +val pp_vmtype : vmtype Fmt.t + type id = string list val string_of_id : string list -> string val id_of_string : string -> string list val drop_super : super:string list -> sub:string list -> string list option val is_sub_id : super:string list -> sub:string list -> bool val domain : 'a list -> 'a list -val pp_id : Format.formatter -> string list -> unit -val pp_is : Format.formatter -> IS.t -> unit +val pp_id : id Fmt.t + type bridge = [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int | `Internal of string ] -val pp_bridge : - Format.formatter -> - [< `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int - | `Internal of string ] -> - unit +val pp_bridge : bridge Fmt.t + type policy = { vms : int; cpuids : IS.t; @@ -192,17 +58,14 @@ type policy = { block : int option; bridges : bridge Astring.String.Map.t; } -val pp_policy : Format.formatter -> policy -> unit -val sub_bridges : - [> `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * 'a - | `Internal of string ] - Astring.String.map -> - [> `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * 'a - | `Internal of string ] - Astring.String.map -> bool +val pp_policy : policy Fmt.t + +val sub_bridges : bridge Astring.String.map -> bridge Astring.String.map -> bool + val sub_block : 'a option -> 'a option -> bool val sub_cpu : IS.t -> IS.t -> bool val is_sub : super:policy -> sub:policy -> bool + type vm_config = { cpuid : int; requested_memory : int; @@ -211,14 +74,17 @@ type vm_config = { vmimage : vmtype * Cstruct.t; argv : string list option; } -val pp_image : - Format.formatter -> - [< `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] * Cstruct.t -> unit -val pp_vm_config : Format.formatter -> vm_config -> unit -val good_bridge : string list -> 'a Astring.String.map -> bool + +val pp_image : (vmtype * Cstruct.t) Fmt.t + +val pp_vm_config : vm_config Fmt.t +val good_bridge : id -> 'a Astring.String.map -> bool + val vm_matches_res : policy -> vm_config -> bool + val check_policies : vm_config -> policy list -> (unit, [> `Msg of string ]) Result.result + type vm = { config : vm_config; cmd : Bos.Cmd.t; @@ -226,21 +92,16 @@ type vm = { taps : string list; stdout : Unix.file_descr; } -val pp_vm : Format.formatter -> vm -> unit + +val pp_vm : vm Fmt.t val translate_tap : vm -> string -> string option + val identifier : Nocrypto.Numeric.Z.t -> string val id : X509.t -> string val name : X509.t -> string -val parse_db : - string list -> ((Z.t * string) list, [> Rresult.R.msg ]) Result.result -val find_in_db : - string -> 'a list -> ('a -> bool) -> ('a, [> Rresult.R.msg ]) Result.result -val find_name : - ('a * string) list -> string -> ('a, [> Rresult.R.msg ]) Result.result -val translate_serial : - (Nocrypto.Numeric.Z.t * string) list -> string -> string -val translate_name : (Nocrypto.Numeric.Z.t * string) list -> string -> string + val separate_chain : 'a list -> ('a * 'a list, [> `Msg of string ]) result + type rusage = { utime : int64 * int; stime : int64 * int; @@ -259,7 +120,7 @@ type rusage = { nvcsw : int64; nivcsw : int64; } -val pp_rusage : Format.formatter -> rusage -> unit +val pp_rusage : rusage Fmt.t val pp_vmm : (string * int64) list Fmt.t type ifdata = { @@ -282,7 +143,8 @@ type ifdata = { input_dropped : int64; output_dropped : int64; } -val pp_ifdata : Format.formatter -> ifdata -> unit +val pp_ifdata : ifdata Fmt.t + module Log : sig type event = From f5ce2d88263f2ac44ec257edb281beebaf055de9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 20:45:06 +0200 Subject: [PATCH 36/73] reuse commands from Vmm_asn.wire_commands for certificates --- pkg/pkg.ml | 2 - provision/vmm_provision.ml | 2 +- provision/vmm_req_command.ml | 62 -------- provision/vmm_req_delegation.ml | 21 ++- provision/vmm_req_vm.ml | 36 ++--- provision/vmm_revoke.ml | 98 ------------- provision/vmm_sign.ml | 242 +++----------------------------- src/vmm_asn.ml | 165 +++------------------- src/vmm_asn.mli | 165 ++-------------------- src/vmm_core.ml | 31 ---- src/vmm_core.mli | 15 -- src/vmm_x509.ml | 28 +--- 12 files changed, 79 insertions(+), 788 deletions(-) delete mode 100644 provision/vmm_req_command.ml delete mode 100644 provision/vmm_revoke.ml diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 42012cc..0d66ebe 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -13,11 +13,9 @@ let () = Pkg.bin "app/vmm_client" ; Pkg.bin "app/vmm_tls_endpoint" ; Pkg.bin "app/vmmc" ; - Pkg.bin "provision/vmm_req_command" ; 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_provision.ml b/provision/vmm_provision.ml index b8a2e98..100ad6a 100644 --- a/provision/vmm_provision.ml +++ b/provision/vmm_provision.ml @@ -1,6 +1,6 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) -let asn_version = `AV1 +let asn_version = `AV2 let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); diff --git a/provision/vmm_req_command.ml b/provision/vmm_req_command.ml deleted file mode 100644 index a57d3ea..0000000 --- a/provision/vmm_req_command.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -open Vmm_provision - -open Rresult.R.Infix - -open Vmm_asn - -let cmd_csr name key command block_device block_size = - let bd = match block_device with - | None -> [] - | Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ] - in - let bs = match block_size with - | None -> [] - | Some x -> [ (false, `Unsupported (Oid.memory, int_to_cstruct x)) ] - in - let exts = - [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ; - (false, `Unsupported (Oid.command, command_to_cstruct command)) ] @ bd @ bs - and name = [ `CN name ] - in - X509.CA.request name ~extensions:[`Extensions exts] key - -let jump _ name key command block_device block_size = - Nocrypto_entropy_unix.initialize () ; - match - priv_key key name >>= fun key -> - let csr = cmd_csr name key command block_device block_size 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.command_of_string s with - | Some x -> `Ok x - | None -> `Error "invalid command" - in - (parse, Vmm_core.pp_command) - -let command = - let doc = "command" in - Arg.(required & pos 1 (some cmd) None & info [] ~doc) - -let block_device = - let doc = "block device" in - Arg.(value & opt (some string) None & info [ "block-device" ] ~doc) - -let block_size = - let doc = "block size in MB" in - Arg.(value & opt (some int) None & info [ "block-size" ] ~doc) - -let cmd = - Term.(ret (const jump $ setup_log $ nam $ key $ command $ block_device $ block_size)), - Term.info "vmm_req_command" ~version:"%%VERSION_NUM%%" - -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/provision/vmm_req_delegation.ml b/provision/vmm_req_delegation.ml index 0c5eb96..dcdd32e 100644 --- a/provision/vmm_req_delegation.ml +++ b/provision/vmm_req_delegation.ml @@ -7,20 +7,17 @@ open Rresult.R.Infix open Astring -let subca_csr key name cpus mem vms block bridges = - let block = match block with - | None -> [] - | Some x -> [ (false, `Unsupported (Oid.block, int_to_cstruct x)) ] - and bridge = match bridges with - | [] -> [] - | xs -> [ (false, `Unsupported (Oid.bridges, bridges_to_cstruct xs)) ] +let subca_csr key name cpus memory vms block bridges = + let cpuids = Vmm_core.IS.of_list cpus + and bridges = List.fold_left (fun acc b -> match b with + | `Internal name -> String.Map.add name b acc + | `External (name, _, _, _, _) -> String.Map.add name b acc) + String.Map.empty bridges in + let policy = Vmm_core.{ vms ; cpuids ; memory ; block ; bridges } in + let cmd = `Policy_cmd (`Policy_add policy) 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 + [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, cmd))) ] and name = [ `CN name ] in X509.CA.request name ~extensions:[`Extensions exts] key diff --git a/provision/vmm_req_vm.ml b/provision/vmm_req_vm.ml index 5e96c89..f5cde5f 100644 --- a/provision/vmm_req_vm.ml +++ b/provision/vmm_req_vm.ml @@ -6,31 +6,19 @@ open Rresult.R.Infix open Vmm_asn -let vm_csr key name image cpu mem args block net force compression = - let block = match block with - | None -> [] - | Some x -> [ (false, `Unsupported (Oid.block_device, string_to_cstruct x)) ] - and arg = match args with - | [] -> [] - | xs -> [ (false, `Unsupported (Oid.argv, strings_to_cstruct xs)) ] - and net = match net with - | [] -> [] - | xs -> [ (false, `Unsupported (Oid.network, strings_to_cstruct xs)) ] - and cmd = if force then `Force_create_vm else `Create_vm +let vm_csr key name image cpuid requested_memory argv block_device network force compression = + let vm_config = + let vmimage = match compression with + | 0 -> `Hvt_amd64, image + | level -> + let img = Vmm_compress.compress ~level (Cstruct.to_string image) in + `Hvt_amd64_compressed, Cstruct.of_string img + and argv = match argv with [] -> None | xs -> Some xs + in + Vmm_core.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in - let image = match compression with - | 0 -> image_to_cstruct (`Hvt_amd64, image) - | level -> - let img = Vmm_compress.compress ~level (Cstruct.to_string image) in - image_to_cstruct (`Hvt_amd64_compressed, Cstruct.of_string img) - in - let exts = - [ (false, `Unsupported (Oid.version, version_to_cstruct asn_version)) ; - (false, `Unsupported (Oid.cpuid, int_to_cstruct cpu)) ; - (false, `Unsupported (Oid.memory, int_to_cstruct mem)) ; - (false, `Unsupported (Oid.vmimage, image)) ; - (false, `Unsupported (Oid.command, command_to_cstruct cmd)) ; - ] @ block @ arg @ net + let cmd = if force then `Vm_force_create vm_config else `Vm_create vm_config in + let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, `Vm_cmd cmd))) ] and name = [ `CN name ] in X509.CA.request name ~extensions:[`Extensions exts] key diff --git a/provision/vmm_revoke.ml b/provision/vmm_revoke.ml deleted file mode 100644 index 84a8e78..0000000 --- a/provision/vmm_revoke.ml +++ /dev/null @@ -1,98 +0,0 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -open Vmm_provision - -open Astring - -open Rresult.R.Infix - - -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 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 -> - parse_db entries >>= fun db -> - find_name db x - | _ -> Error (`Msg "please provide either common name or serial!")) >>= fun serial -> - Bos.OS.File.read (Fpath.v cakey) >>= fun pk -> - let cakey = X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string pk) in - Bos.OS.File.read (Fpath.v cacert) >>= fun cacert -> - let cacert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 (Cstruct.of_string cacert) in - - let this_update = Ptime_clock.now () in - let revoked = { X509.CRL.serial ; date = this_update ; extensions = [] } in - let crl = Fpath.v crl in - let issuer = X509.subject cacert in - (Bos.OS.File.exists crl >>= function - | true -> - Bos.OS.File.read crl >>= fun crl -> - (match X509.Encoding.crl_of_cstruct (Cstruct.of_string crl) with - | None -> Error (`Msg "couldn't parse CRL") - | Some c -> Ok (X509.CRL.revoke_certificate revoked ~this_update c cakey)) - | false -> - Ok (X509.CRL.revoke - ~issuer - ~this_update - ~extensions:[ (false, `CRL_number 0) ] - [ revoked ] cakey)) >>= fun new_crl -> - let crl_cs = X509.Encoding.crl_to_cstruct new_crl in - Bos.OS.File.write crl (Cstruct.to_string crl_cs) >>= fun () -> - (* create temporary certificate for uploading CRL *) - let name = "revoke" in - priv_key None name >>= fun key -> - let csr = X509.CA.request [ `CN name ] key in - let extensions = [ (false, `Unsupported (Vmm_asn.Oid.version, Vmm_asn.version_to_cstruct asn_version)) ; - (false, `Unsupported (Vmm_asn.Oid.command, Vmm_asn.command_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 index f7bb51a..eb5b605 100644 --- a/provision/vmm_sign.ml +++ b/provision/vmm_sign.ml @@ -31,12 +31,7 @@ let sign dbname cacert key csr days = (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 policy = match Vmm_asn.policy_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_policy) policy) ; + (* TODO: check delegation! *) let req_exts = match List.find (function `Extensions _ -> true | _ -> false) ri.X509.CA.extensions @@ -45,224 +40,23 @@ let sign dbname cacert key csr days = | `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 `Command - | _ -> 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 policy 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 policy 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 policy 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 policy 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 - req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command -> - Logs.app (fun m -> m "using command %a" Vmm_core.pp_command command) ; - let s_exts = (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct command) :: 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 policy 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 policy 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 policy 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 policy 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 policy 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 ()) - | `Command -> - req Vmm_asn.Oid.command req_exts Vmm_asn.command_of_cstruct >>= fun command -> - Logs.app (fun m -> m "a leaf certificate with command %a" - Vmm_core.pp_command command) ; - let s_exts = (Vmm_asn.Oid.command, Vmm_asn.command_to_cstruct command) :: s_exts in - (match command with - | `Create_block | `Destroy_block -> - req Vmm_asn.Oid.block_device req_exts Vmm_asn.string_of_cstruct >>| fun block_device -> - Logs.app (fun m -> m "block device %s" block_device) ; - (Vmm_asn.Oid.block_device, Vmm_asn.string_to_cstruct block_device) :: s_exts - | _ -> Ok s_exts) >>= fun s_exts -> - (match command with - | `Create_block -> - req Vmm_asn.Oid.memory req_exts Vmm_asn.int_of_cstruct >>| fun block_size -> - Logs.app (fun m -> m "block size %dMB" block_size) ; - (Vmm_asn.Oid.memory, Vmm_asn.int_to_cstruct block_size) :: s_exts - | _ -> Ok s_exts) >>= fun s_exts -> - 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) + match + List.filter (function + | (_, `Unsupported (oid, _)) when Asn.OID.equal oid Vmm_asn.oid -> true + | _ -> false) + req_exts + with + | [ (_, `Unsupported (_, v)) as ext ] -> + Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) -> + (if Vmm_asn.version_eq version asn_version then + Ok () + else + Error (`Msg "unknown version in request")) >>= fun () -> + (* TODO l_exts / d_exts trouble *) + Logs.app (fun m -> m "signing %a" Vmm_asn.pp_wire_command cmd) ; + Ok (ext :: l_exts) >>= fun extensions -> + sign ~dbname extensions issuer key csr (Duration.of_day days) + | _ -> Error (`Msg "none or multiple albatross extensions found") let jump _ db cacert cakey csrname days = Nocrypto_entropy_unix.initialize () ; diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index dc53d72..d056521 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -5,53 +5,7 @@ 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, also for block_create *) - 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 leaf certs *) - let command = m <| 42 - - (* used in CRL certs *) - let crl = m <| 43 -end - -let command : command Asn.t = - let alist = [ - 0, `Info ; - 1, `Create_vm ; - 2, `Force_create_vm ; - 3, `Destroy_vm ; - 4, `Statistics ; - 5, `Console ; - 6, `Log ; - 7, `Crl ; - 8, `Create_block ; - 9, `Destroy_block ; - ] - in - let rev = List.map (fun (k, v) -> (v, k)) alist in - Asn.S.enumerated (fun i -> List.assoc i alist) (fun k -> List.assoc k rev) +let oid = Asn.OID.(base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 43) open Rresult.R.Infix @@ -68,9 +22,6 @@ let projections_of asn = let c = Asn.codec Asn.der asn in (decode_strict c, Asn.encode c) -let int_of_cstruct, int_to_cstruct = projections_of Asn.S.int -let ints_of_cstruct, ints_to_cstruct = projections_of Asn.S.(sequence_of int) - let ipv4 = let f cs = Ipaddr.V4.of_bytes_exn (Cstruct.to_string cs) and g ip = Cstruct.of_string (Ipaddr.V4.to_bytes ip) @@ -95,14 +46,6 @@ let bridge = (required ~label:"router" ipv4) (required ~label:"netmask" int)))) -let bridges_of_cstruct, bridges_to_cstruct = - projections_of (Asn.S.sequence_of bridge) - -let strings_of_cstruct, strings_to_cstruct = - projections_of Asn.S.(sequence_of utf8_string) - -let string_of_cstruct, string_to_cstruct = projections_of Asn.S.utf8_string - let policy = let f (cpuids, vms, memory, block, bridges) = let bridges = match bridges with @@ -143,20 +86,6 @@ let image = (explicit 1 octet_string) (explicit 2 octet_string)) -let image_of_cstruct, image_to_cstruct = projections_of image - -let command_of_cstruct, command_to_cstruct = projections_of command - -let req label cert oid f = - match X509.Extension.unsupported cert oid with - | None -> R.error_msgf "OID %s not present (%a)" label Asn.OID.pp oid - | Some (_, data) -> f data - -let 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 | `AV1 | `AV2 ] let version_of_int = function @@ -184,78 +113,6 @@ let version_eq a b = | `AV2, `AV2 -> true | _ -> false -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 policy_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 requested_memory -> - opt cert Oid.block_device string_of_cstruct >>= fun block_device -> - opt cert Oid.network strings_of_cstruct >>= fun network -> - req "vmimage" cert Oid.vmimage image_of_cstruct >>= fun vmimage -> - opt cert Oid.argv strings_of_cstruct >>= fun argv -> - let network = match network with None -> [] | Some x -> x in - Ok { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } - -let command_of_cert version cert = - version_of_cert version cert >>= fun () -> - req "command" cert Oid.command command_of_cstruct - -let block_device_of_cert version cert = - version_of_cert version cert >>= fun () -> - req "block-device" cert Oid.block_device string_of_cstruct - -let block_size_of_cert version cert = - version_of_cert version cert >>= fun () -> - req "block-size" cert Oid.memory int_of_cstruct - (* communication protocol *) type console_cmd = [ | `Console_add @@ -699,3 +556,23 @@ let log_entry = (required ~label:"event" log_event)) let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry + +type cert_extension = version * wire_command + +let cert_extension = + Asn.S.(sequence2 + (required ~label:"version" version) + (required ~label:"command" wire_command)) + +let cert_extension_of_cstruct, cert_extension_to_cstruct = + projections_of cert_extension + +let wire_command_of_cert version cert = + match X509.Extension.unsupported cert oid with + | None -> R.error_msgf "albatross OID is not present in certificate (%a)" Asn.OID.pp oid + | Some (_, data) -> + cert_extension_of_cstruct data >>= fun (v, wire) -> + if not (version_eq v version) then + R.error_msgf "unexpected version %a (expected %a)" pp_version v pp_version version + else + Ok wire diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 03f28df..28e14e4 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -1,76 +1,13 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) +open Vmm_core + (** ASN.1 encoding of resources and configuration *) -(** Object Identifiers *) +(** {1 Object Identifier} *) -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 hvt amd64 - image, [ [1] OCTET_STRING] for an hvt arm64 image, and [ [2] OCTET_STRING] - for a compressed am64 hvt 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} *) - - (** [command] is a [BIT_STRING] denoting the command this certificate. *) - val command : Asn.OID.t - - - (** [crl] is a [OCTET_STRING] denoting the revocation list of the intermediate - CA. *) - val crl : Asn.OID.t -end +(** OID in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.43) *) +val oid : Asn.OID.t (** {1 Encoding and decoding functions} *) @@ -83,89 +20,6 @@ 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 - -(** [command_to_cstruct perms] is the DER encoded command. *) -val command_to_cstruct : Vmm_core.command -> Cstruct.t - -(** [command_of_cstruct buffer] is either a decoded command of the DER encoded - [buffer] or an error. *) -val command_of_cstruct : Cstruct.t -> (Vmm_core.command, [> `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 - -(** [policy_of_cert version cert] is either the decoded policy, or an error. *) -val policy_of_cert : version -> X509.t -> (Vmm_core.policy, [> `Msg of string ]) result - -(** [command_of_cert version cert] is either the decoded command, or an error. *) -val command_of_cert : version -> X509.t -> (Vmm_core.command, [> `Msg of string ]) result - -(** [block_device_of_cert version cert] is either the decoded block device, or an error. *) -val block_device_of_cert : version -> X509.t -> (string, [> `Msg of string ]) result - -(** [block_size_of_cert version cert] is either the decoded block size, or an error. *) -val block_size_of_cert : version -> X509.t -> (int, [> `Msg of string ]) result - -open Vmm_core type console_cmd = [ | `Console_add | `Console_subscribe @@ -204,6 +58,8 @@ type wire_command = [ | `Vm_cmd of vm_cmd | `Policy_cmd of policy_cmd ] +val pp_wire_command : wire_command Fmt.t + type header = { version : version ; sequence : int64 ; @@ -226,3 +82,10 @@ type log_entry = header * Ptime.t * Log.event val log_entry_to_cstruct : log_entry -> Cstruct.t val log_entry_of_cstruct : Cstruct.t -> (log_entry, [> `Msg of string ]) result + +type cert_extension = version * wire_command + +val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result +val cert_extension_to_cstruct : cert_extension -> Cstruct.t + +val wire_command_of_cert : version -> X509.t -> (wire_command, [> `Msg of string ]) result diff --git a/src/vmm_core.ml b/src/vmm_core.ml index f27a928..41a5212 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -31,37 +31,6 @@ module IS = Set.Make(I) module IM = Map.Make(I) module IM64 = Map.Make(Int64) -type command = - [ `Info | `Create_vm | `Force_create_vm | `Destroy_vm - | `Statistics | `Console | `Log | `Crl - | `Create_block | `Destroy_block ] - -let pp_command ppf cmd = - Fmt.string ppf @@ match cmd with - | `Info -> "info" - | `Create_vm -> "create-vm" - | `Force_create_vm -> "force-create-vm" - | `Destroy_vm -> "destroy-vm" - | `Statistics -> "statistics" - | `Console -> "console" - | `Log -> "log" - | `Crl -> "crl" - | `Create_block -> "create-block" - | `Destroy_block -> "destroy-block" - -let command_of_string = function - | x when x = "info" -> Some `Info - | x when x = "create-vm" -> Some `Create_vm - | x when x = "force-create-vm" -> Some `Force_create_vm - | x when x = "destroy-vm" -> Some `Destroy_vm - | x when x = "statistics" -> Some `Statistics - | x when x = "console" -> Some `Console - | x when x = "log" -> Some `Log - | x when x = "crl" -> Some `Crl - | x when x = "create-block" -> Some `Create_block - | x when x = "destroy-block" -> Some `Destroy_block - | _ -> None - type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ] let vmtype_to_int = function diff --git a/src/vmm_core.mli b/src/vmm_core.mli index fa9c71c..3706744 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -18,21 +18,6 @@ module IM64 : sig include Map.S with type key = Int64.t end -type command = - [ `Console - | `Create_block - | `Create_vm - | `Crl - | `Destroy_block - | `Destroy_vm - | `Force_create_vm - | `Info - | `Log - | `Statistics ] -val pp_command : command Fmt.t - -val command_of_string : string -> command option - type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] val vmtype_to_int : vmtype -> int val int_to_vmtype : int -> vmtype option diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index 74b2e8a..4b99e5a 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -2,7 +2,7 @@ open Rresult.R.Infix open Vmm_core -let asn_version = `AV1 +let asn_version = `AV2 (* let check_policy = (* get names and static resources *) @@ -28,26 +28,6 @@ let handle _addr chain = (* TODO here: inspect top-level-cert of chain. may need to create bridges and/or block device subdirectory (zfs create) *) (* let login_hdr, login_ev = Log.hdr name, `Login addr in *) - Vmm_asn.command_of_cert asn_version leaf >>= function - | `Info -> Ok (name, `Vm_cmd `Vm_info) - | `Create_vm -> - (* TODO: update acl *) - Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config -> - (name, `Vm_cmd (`Vm_create vm_config)) - | `Force_create_vm -> - (* TODO: update acl *) - Vmm_asn.vm_of_cert prefix leaf >>| fun vm_config -> - (name, `Vm_cmd (`Vm_force_create vm_config)) - | `Destroy_vm -> Ok (name, `Vm_cmd `Vm_destroy) - | `Statistics -> Ok (name, `Stats_cmd `Stats_subscribe) - | `Console -> Ok (name, `Console_cmd `Console_subscribe) - | `Log -> Ok (name, `Log_cmd `Log_subscribe) - | `Crl -> assert false - | `Create_block -> assert false -(* Vmm_asn.block_device_of_cert asn_version leaf >>= fun block_name -> - Vmm_asn.block_size_of_cert asn_version leaf >>| fun block_size -> - `Create_block (block_name, block_size) *) - | `Destroy_block -> assert false -(* Vmm_asn.block_device_of_cert asn_version leaf >>| fun block_name -> - `Destroy_block block_name -*) + (* TODO: update policies! *) + Vmm_asn.wire_command_of_cert asn_version leaf >>| fun wire -> + (name, wire) From d896d89bba35a02532fd9b8a5e1dc206fb738ce8 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 20:54:53 +0200 Subject: [PATCH 37/73] . --- src/vmm_x509.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml index 4b99e5a..4e3e3d9 100644 --- a/src/vmm_x509.ml +++ b/src/vmm_x509.ml @@ -25,9 +25,8 @@ let handle _addr chain = (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 login_hdr, login_ev = Log.hdr name, `Login addr in *) + (* TODO: inspect top-level-cert of chain. *) + (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) (* TODO: update policies! *) Vmm_asn.wire_command_of_cert asn_version leaf >>| fun wire -> (name, wire) From 611d234e1ac5d6d148fd8199dc4bacab8f553bd4 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 21:20:51 +0200 Subject: [PATCH 38/73] remove dead code --- provision/vmm_sign.ml | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/provision/vmm_sign.ml b/provision/vmm_sign.ml index eb5b605..425c7b2 100644 --- a/provision/vmm_sign.ml +++ b/provision/vmm_sign.ml @@ -6,25 +6,6 @@ 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" From f3c67f626af6952321943664c1a58c099c65a44f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 21:38:34 +0200 Subject: [PATCH 39/73] more cleanups --- src/vmm_asn.ml | 24 +++++++++--------------- src/vmm_core.ml | 20 -------------------- src/vmm_core.mli | 12 ++---------- 3 files changed, 11 insertions(+), 45 deletions(-) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index d056521..4f6662a 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -88,17 +88,6 @@ let image = type version = [ `AV0 | `AV1 | `AV2 ] -let version_of_int = function - | 0 -> Ok `AV0 - | 1 -> Ok `AV1 - | 2 -> Ok `AV2 - | _ -> Error (`Msg "couldn't parse version") - -let version_to_int = function - | `AV0 -> 0 - | `AV1 -> 1 - | `AV2 -> 2 - let pp_version ppf v = Fmt.int ppf (match v with @@ -418,10 +407,15 @@ let policy_cmd = (explicit 2 null)) let version = - let f data = match version_of_int data with - | Ok v -> v - | Error (`Msg m) -> Asn.S.error (`Parse m) - and g = version_to_int + let f data = match data with + | 0 -> `AV0 + | 1 -> `AV1 + | 2 -> `AV2 + | _ -> Asn.S.error (`Parse "unknown version number") + and g = function + | `AV0 -> 0 + | `AV1 -> 1 + | `AV2 -> 2 in Asn.S.map f g Asn.S.int diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 41a5212..0e961a1 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -29,21 +29,9 @@ end module IS = Set.Make(I) module IM = Map.Make(I) -module IM64 = Map.Make(Int64) type vmtype = [ `Hvt_amd64 | `Hvt_arm64 | `Hvt_amd64_compressed ] -let vmtype_to_int = function - | `Hvt_amd64 -> 0 - | `Hvt_arm64 -> 1 - | `Hvt_amd64_compressed -> 2 - -let int_to_vmtype = function - | 0 -> Some `Hvt_amd64 - | 1 -> Some `Hvt_arm64 - | 2 -> Some `Hvt_amd64_compressed - | _ -> None - let pp_vmtype ppf = function | `Hvt_amd64 -> Fmt.pf ppf "hvt-amd64" | `Hvt_amd64_compressed -> Fmt.pf ppf "hvt-amd64-compressed" @@ -188,14 +176,6 @@ let translate_tap vm tap = | [ (_, b) ] -> Some b | _ -> None -let identifier serial = - match Hex.of_cstruct @@ Nocrypto.Hash.SHA256.digest @@ - Nocrypto.Numeric.Z.to_cstruct_be @@ serial - with - | `Hex str -> str - -let id cert = identifier (X509.serial cert) - let name cert = X509.common_name_to_string cert (* this separates the leaf and top-level certificate from the chain, diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 3706744..3b01e1a 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -14,13 +14,7 @@ module IM : sig include Map.S with type key = I.t end -module IM64 : sig - include Map.S with type key = Int64.t -end - type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -val vmtype_to_int : vmtype -> int -val int_to_vmtype : int -> vmtype option val pp_vmtype : vmtype Fmt.t type id = string list @@ -32,8 +26,8 @@ val domain : 'a list -> 'a list val pp_id : id Fmt.t type bridge = - [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int - | `Internal of string ] + [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int + | `Internal of string ] val pp_bridge : bridge Fmt.t type policy = { @@ -81,8 +75,6 @@ type vm = { val pp_vm : vm Fmt.t val translate_tap : vm -> string -> string option -val identifier : Nocrypto.Numeric.Z.t -> string -val id : X509.t -> string val name : X509.t -> string val separate_chain : 'a list -> ('a * 'a list, [> `Msg of string ]) result From 46548418cdaf1978a6bc45244e8efa4a3306a214 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 21:53:44 +0200 Subject: [PATCH 40/73] minor cleanup: stats type --- app/vmm_influxdb_stats.ml | 2 +- src/vmm_asn.ml | 26 +++++++------------------- src/vmm_asn.mli | 2 +- src/vmm_core.ml | 11 ++++++++++- src/vmm_core.mli | 7 ++++++- stats/vmm_stats.ml | 2 +- 6 files changed, 26 insertions(+), 24 deletions(-) diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index f2780e7..ef7d9b2 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -199,7 +199,7 @@ let rec read_sock_write_tcp c ?fd addr addrtype = end else let name = string_of_id hdr.Vmm_asn.id in let ru = P.encode_ru name ru in - let vmm = match vmm with [] -> [] | _ -> [ P.encode_vmm name vmm ] in + let vmm = match vmm with None -> [] | Some xs -> [ P.encode_vmm name xs ] in let taps = List.map (P.encode_if name) ifs in let out = (String.concat ~sep:"\n" (ru :: vmm @ taps)) ^ "\n" in Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ; diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 4f6662a..a233928 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -211,37 +211,26 @@ type stats_cmd = [ | `Stats_add of int * string list | `Stats_remove | `Stats_subscribe - | `Stats_data of rusage * (string * int64) list * ifdata list + | `Stats_data of stats ] let pp_stats_cmd ppf = function | `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps | `Stats_remove -> Fmt.string ppf "stat remove" | `Stats_subscribe -> Fmt.string ppf "stat subscribe" - | `Stats_data (ru, vmm, ifs) -> Fmt.pf ppf "stats data: %a %a %a" - pp_rusage ru - pp_vmm vmm - Fmt.(list ~sep:(unit "@.@.") pp_ifdata) ifs + | `Stats_data stats -> Fmt.pf ppf "stats data: %a" pp_stats stats let stats_cmd = let f = function | `C1 (pid, taps) -> `Stats_add (pid, taps) | `C2 () -> `Stats_remove | `C3 () -> `Stats_subscribe - | `C4 (ru, vmm, ifdata) -> - let vmm = match vmm with None -> [] | Some vmm -> vmm - and ifdata = match ifdata with None -> [] | Some ifs -> ifs - in - `Stats_data (ru, vmm, ifdata) + | `C4 (ru, ifs, vmm) -> `Stats_data (ru, vmm, ifs) and g = function | `Stats_add (pid, taps) -> `C1 (pid, taps) | `Stats_remove -> `C2 () | `Stats_subscribe -> `C3 () - | `Stats_data (ru, vmm, ifdata) -> - let vmm = match vmm with [] -> None | xs -> Some xs - and ifs = match ifdata with [] -> None | xs -> Some xs - in - `C4 (ru, vmm, ifs) + | `Stats_data (ru, ifs, vmm) -> `C4 (ru, vmm, ifs) in Asn.S.map f g @@ Asn.S.(choice4 @@ -252,12 +241,11 @@ let stats_cmd = (explicit 2 null) (explicit 3 (sequence3 (required ~label:"resource_usage" ru) - (optional ~label:"vmm_stats" @@ explicit 0 + (required ~label:"ifdata" (sequence_of ifdata)) + (optional ~label:"vmm_stats" (sequence_of (sequence2 (required ~label:"key" utf8_string) - (required ~label:"value" int64)))) - (optional ~label:"ifdata" @@ explicit 1 - (sequence_of ifdata))))) + (required ~label:"value" int64))))))) let addr = Asn.S.(sequence2 diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 28e14e4..ea1a5eb 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -30,7 +30,7 @@ type stats_cmd = [ | `Stats_add of int * string list | `Stats_remove | `Stats_subscribe - | `Stats_data of rusage * (string * int64) list * ifdata list + | `Stats_data of stats ] type log_cmd = [ diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 0e961a1..694736b 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -209,7 +209,9 @@ let pp_rusage ppf r = Fmt.pf ppf "utime %Lu.%d stime %Lu.%d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu" (fst r.utime) (snd r.utime) (fst r.stime) (snd r.stime) r.maxrss r.ixrss r.idrss r.isrss r.minflt r.majflt r.nswap r.inblock r.outblock r.msgsnd r.msgrcv r.nsignals r.nvcsw r.nivcsw -let pp_vmm ppf vmm = + +type vmm_stats = (string * int64) list +let pp_vmm_stats ppf vmm = Fmt.(list ~sep:(unit "@,") (pair ~sep:(unit ": ") string int64)) ppf vmm type ifdata = { @@ -237,6 +239,13 @@ 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 +type stats = rusage * vmm_stats option * ifdata list +let pp_stats ppf (ru, vmm, ifs) = + Fmt.pf ppf "%a@.%a@.%a" + pp_rusage ru + Fmt.(option ~none:(unit "no vmm stats") pp_vmm_stats) vmm + Fmt.(list ~sep:(unit "@.@.") pp_ifdata) ifs + module Log = struct type event = [ `Startup diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 3b01e1a..2b1a12b 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -98,7 +98,9 @@ type rusage = { nivcsw : int64; } val pp_rusage : rusage Fmt.t -val pp_vmm : (string * int64) list Fmt.t + +type vmm_stats = (string * int64) list +val pp_vmm_stats : vmm_stats Fmt.t type ifdata = { name : string; @@ -122,6 +124,9 @@ type ifdata = { } val pp_ifdata : ifdata Fmt.t +type stats = rusage * vmm_stats option * ifdata list +val pp_stats : stats Fmt.t + module Log : sig type event = diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index 4c8e752..208434c 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -112,7 +112,7 @@ let tick t = | None -> Logs.err (fun m -> m "failed to get rusage for %d" pid) ; out | Some ru' -> let stats = - let vmm' = match vmm with None -> [] | Some xs -> List.combine !descr xs in + let vmm' = match vmm with None -> None | Some xs -> Some (List.combine !descr xs) in ru', vmm', ifd in List.fold_left (fun out (id, socket) -> From ce0c42fa77e155bb51f47ae564a566e54264b294 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 22:14:28 +0200 Subject: [PATCH 41/73] more cleanups --- app/vmm_log.ml | 7 ------- src/vmm_core.ml | 1 - src/vmm_engine.ml | 28 ++-------------------------- src/vmm_resources.ml | 9 ++++++--- src/vmm_unix.ml | 1 - 5 files changed, 8 insertions(+), 38 deletions(-) diff --git a/app/vmm_log.ml b/app/vmm_log.ml index a0fe782..8d688c1 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -5,8 +5,6 @@ (* 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! *) @@ -55,11 +53,6 @@ let write_to_file file = in mvar, write_loop -(* TODO: - - should there be an unsubscribe command? - - should there be acks for history/datain? - *) - let tree = ref Vmm_trie.empty let bcast = ref 0L diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 694736b..6f1c4b4 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -142,7 +142,6 @@ let good_bridge idxs nets = List.for_all (fun n -> String.Map.mem n nets) idxs let vm_matches_res (res : policy) (vm : vm_config) = - (* TODO block device *) res.vms >= 1 && IS.mem vm.cpuid res.cpuids && vm.requested_memory <= res.memory && good_bridge vm.network res.bridges diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 7145e62..0df0648 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -12,10 +12,6 @@ type 'a t = { console_counter : int64 ; stats_counter : int64 ; log_counter : int64 ; - (* TODO: refine, maybe: - bridges : (Macaddr.t String.Map.t * String.Set.t) String.Map.t ; *) - used_bridges : String.Set.t String.Map.t ; - (* TODO: used block devices (since each may only be active once) *) resources : Vmm_resources.t ; tasks : 'a String.Map.t ; } @@ -25,7 +21,6 @@ let init wire_version = { console_counter = 1L ; stats_counter = 1L ; log_counter = 1L ; - used_bridges = String.Map.empty ; resources = Vmm_resources.empty ; tasks = String.Map.empty ; } @@ -58,7 +53,6 @@ let handle_create t hdr vm_config = (* prepare VM: save VM image to disk, create fifo, ... *) Vmm_unix.prepare name vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; - (* TODO should we pre-reserve sth in t? *) let cons_out = let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in (header, `Command (`Console_cmd `Console_add)) @@ -70,16 +64,7 @@ let handle_create t hdr vm_config = Logs.debug (fun m -> m "exec()ed vm") ; Vmm_resources.insert_vm t.resources name vm >>= fun resources -> let tasks = String.Map.add (string_of_id name) task t.tasks in - let used_bridges = - List.fold_left2 (fun b br ta -> - let old = match String.Map.find br b with - | None -> String.Set.empty - | Some x -> x - in - String.Map.add br (String.Set.add ta old) b) - t.used_bridges vm_config.network taps - in - let t = { t with resources ; tasks ; used_bridges } in + let t = { t with resources ; tasks } in let t, out = log t name (`VM_start (vm.pid, vm.taps, None)) in let data = `Success (`String "created VM") in Ok (t, [ `Data (hdr, data) ; out ], name, vm))) @@ -95,19 +80,10 @@ let handle_shutdown t name vm r = | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; let resources = Vmm_resources.remove t.resources name in - let used_bridges = - List.fold_left2 (fun b br ta -> - let old = match String.Map.find br b with - | None -> String.Set.empty - | Some x -> x - in - String.Map.add br (String.Set.remove ta old) b) - t.used_bridges vm.config.network vm.taps - in let stat_out = `Stats_remove in let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let tasks = String.Map.remove (string_of_id name) t.tasks in - let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; used_bridges ; tasks } in + let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in let t, logout = log t name (`VM_stop (vm.pid, r)) in (t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ; logout ]) diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index f51799b..e9459d8 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -10,7 +10,8 @@ type res_entry = { let empty_res = { running_vms = 0 ; used_memory = 0 } let check_resource (policy : policy) (vm : vm_config) (res : res_entry) = - succ res.running_vms <= policy.vms && res.used_memory + vm.requested_memory <= policy.memory && + succ res.running_vms <= policy.vms && + res.used_memory + vm.requested_memory <= policy.memory && vm_matches_res policy vm let check_resource_policy (policy : policy) (res : res_entry) = @@ -81,8 +82,10 @@ let check_policy_below t name p = match res, entry with | Ok p, Policy p' -> if is_sub ~super:p ~sub:p then Ok p' else Error () | Ok p, Vm vm -> - (* TODO block device *) - if IS.mem vm.config.cpuid p.cpuids && good_bridge vm.config.network p.bridges then Ok p else Error () + let cfg = vm.config in + if IS.mem cfg.cpuid p.cpuids && good_bridge cfg.network p.bridges + then Ok p + else Error () | res, _ -> res) (Ok p) diff --git a/src/vmm_unix.ml b/src/vmm_unix.ml index b6cb824..17fa587 100644 --- a/src/vmm_unix.ml +++ b/src/vmm_unix.ml @@ -146,7 +146,6 @@ let cpuset cpu = | x -> Error (`Msg ("unsupported operating system " ^ x)) let exec name vm taps = - (* TODO: --net-mac=xx *) let net = List.map (fun t -> "--net=" ^ t) taps in let argv = match vm.argv with None -> [] | Some xs -> xs in (match taps with From 6f18f1bfffa512582cae49bfed5ac4ff8832c57f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 23 Oct 2018 23:11:22 +0200 Subject: [PATCH 42/73] type data for streamed thingies --- app/vmm_console.ml | 7 ++- app/vmm_influxdb_stats.ml | 2 +- app/vmm_log.ml | 33 +++++++------- app/vmmd.ml | 3 ++ src/vmm_asn.ml | 91 +++++++++++++++++++++++---------------- src/vmm_asn.mli | 14 ++++-- src/vmm_engine.ml | 5 +-- stats/vmm_stats.ml | 4 +- 8 files changed, 92 insertions(+), 67 deletions(-) diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 10475c9..7365cca 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -32,7 +32,7 @@ let read_console name ring channel () = | None -> Lwt.return_unit | Some fd -> let header = Vmm_asn.{ version = my_version ; sequence = 0L ; id } in - Vmm_lwt.write_wire fd (header, `Command (`Console_cmd (`Console_data (t, line)))) >>= function + Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function | Error _ -> Vmm_lwt.safe_close fd >|= fun () -> active := String.Map.remove name !active @@ -92,7 +92,7 @@ let subscribe s id = Logs.debug (fun m -> m "found %d history" (List.length entries)) ; Lwt_list.iter_s (fun (i, v) -> let header = Vmm_asn.{ version = my_version ; sequence = 0L ; id } in - Vmm_lwt.write_wire s (header, `Command (`Console_cmd (`Console_data (i, v)))) >|= fun _ -> ()) + Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >|= fun _ -> ()) entries >>= fun () -> (match String.Map.find name !active with | None -> Lwt.return_unit @@ -114,8 +114,7 @@ let handle s addr () = else match cmd with | `Console_add -> add_fifo header.Vmm_asn.id - | `Console_subscribe -> subscribe s header.Vmm_asn.id - | `Console_data _ -> Lwt.return (Error (`Msg "unexpected command"))) >>= (function + | `Console_subscribe -> subscribe s header.Vmm_asn.id) >>= (function | Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg)) | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index ef7d9b2..d6b172c 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -189,7 +189,7 @@ let rec read_sock_write_tcp c ?fd addr addrtype = safe_close fd >>= fun () -> safe_close c >|= fun () -> true - | Ok (hdr, `Command (`Stats_cmd (`Stats_data (ru, vmm, ifs)))) -> + | Ok (hdr, `Data (`Stats_data (ru, vmm, ifs))) -> begin if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin Logs.err (fun m -> m "unknown wire protocol version") ; diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 8d688c1..089e188 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -73,9 +73,7 @@ let send_history s ring id = (* just need a wrapper in tag = Log.Data, id = reqid *) Lwt_list.fold_left_s (fun r (header, ts, event) -> match r with - | Ok () -> - let data = header, `Command (`Log_cmd (`Log_data (ts, event))) in - Vmm_lwt.write_wire s data + | Ok () -> Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event))) | Error e -> Lwt.return (Error e)) (Ok ()) res @@ -91,24 +89,29 @@ let handle mvar ring s addr () = | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit + | Ok (hdr, `Data (`Log_data (ts, event))) -> + if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin + Logs.warn (fun m -> m "unsupported version") ; + Lwt.return_unit + end else begin + let data = Vmm_asn.log_entry_to_cstruct (hdr, ts, event) in + Vmm_ring.write ring (ts, Cstruct.to_string data) ; + Lwt_mvar.put mvar data >>= fun () -> + let data' = + let header = Vmm_asn.{ version = my_version ; sequence = !bcast ; id = hdr.Vmm_asn.id } in + (header, `Data (`Log_data (ts, event))) + in + bcast := Int64.succ !bcast ; + broadcast hdr.Vmm_asn.id data' !tree >>= fun tree' -> + tree := tree' ; + loop () + end | Ok (hdr, `Command (`Log_cmd lc)) -> if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin Logs.warn (fun m -> m "unsupported version") ; Lwt.return_unit end else begin match lc with - | `Log_data (ts, event) -> - let data = Vmm_asn.log_entry_to_cstruct (hdr, ts, event) in - Vmm_ring.write ring (ts, Cstruct.to_string data) ; - Lwt_mvar.put mvar data >>= fun () -> - let data' = - let header = Vmm_asn.{ version = my_version ; sequence = !bcast ; id = hdr.Vmm_asn.id } in - (header, `Command (`Log_cmd (`Log_data (ts, event)))) - in - bcast := Int64.succ !bcast ; - broadcast hdr.Vmm_asn.id data' !tree >>= fun tree' -> - tree := tree' ; - loop () | `Log_subscribe -> let tree', ret = Vmm_trie.insert hdr.Vmm_asn.id s !tree in tree := tree' ; diff --git a/app/vmmd.ml b/app/vmmd.ml index fea7f31..e0238b7 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -40,6 +40,9 @@ let create c_fd process cont = | `Failure f -> Logs.err (fun m -> m "console failed with %s" f) ; Lwt.return_unit + | `Data _ -> + Logs.err (fun m -> m "console replied with data") ; + Lwt.return_unit | `Success _msg -> (* assert hdr.id = id! *) let await, wakeme = Lwt.wait () in diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index a233928..7f2df72 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -106,32 +106,24 @@ let version_eq a b = type console_cmd = [ | `Console_add | `Console_subscribe - | `Console_data of Ptime.t * string ] let pp_console_cmd ppf = function | `Console_add -> Fmt.string ppf "console add" | `Console_subscribe -> Fmt.string ppf "console subscribe" - | `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s" - (Ptime.pp_rfc3339 ()) ts line let console_cmd = let f = function | `C1 () -> `Console_add | `C2 () -> `Console_subscribe - | `C3 (timestamp, data) -> `Console_data (timestamp, data) and g = function | `Console_add -> `C1 () | `Console_subscribe -> `C2 () - | `Console_data (timestamp, data) -> `C3 (timestamp, data) in Asn.S.map f g @@ - Asn.S.(choice3 + Asn.S.(choice2 (explicit 0 null) - (explicit 1 null) - (explicit 2 (sequence2 - (required ~label:"timestamp" utc_time) - (required ~label:"data" utf8_string)))) + (explicit 1 null)) (* TODO is this good? *) let int64 = @@ -211,41 +203,30 @@ type stats_cmd = [ | `Stats_add of int * string list | `Stats_remove | `Stats_subscribe - | `Stats_data of stats ] let pp_stats_cmd ppf = function | `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps | `Stats_remove -> Fmt.string ppf "stat remove" | `Stats_subscribe -> Fmt.string ppf "stat subscribe" - | `Stats_data stats -> Fmt.pf ppf "stats data: %a" pp_stats stats let stats_cmd = let f = function | `C1 (pid, taps) -> `Stats_add (pid, taps) | `C2 () -> `Stats_remove | `C3 () -> `Stats_subscribe - | `C4 (ru, ifs, vmm) -> `Stats_data (ru, vmm, ifs) and g = function | `Stats_add (pid, taps) -> `C1 (pid, taps) | `Stats_remove -> `C2 () | `Stats_subscribe -> `C3 () - | `Stats_data (ru, ifs, vmm) -> `C4 (ru, vmm, ifs) in Asn.S.map f g @@ - Asn.S.(choice4 + Asn.S.(choice3 (explicit 0 (sequence2 (required ~label:"pid" int) (required ~label:"taps" (sequence_of utf8_string)))) (explicit 1 null) - (explicit 2 null) - (explicit 3 (sequence3 - (required ~label:"resource_usage" ru) - (required ~label:"ifdata" (sequence_of ifdata)) - (optional ~label:"vmm_stats" - (sequence_of (sequence2 - (required ~label:"key" utf8_string) - (required ~label:"value" int64))))))) + (explicit 2 null)) let addr = Asn.S.(sequence2 @@ -295,28 +276,20 @@ let log_event = (explicit 2 int)))))) type log_cmd = [ - | `Log_data of Ptime.t * Log.event | `Log_subscribe ] let pp_log_cmd ppf = function - | `Log_data (ts, event) -> Fmt.pf ppf "log data: %a %a" (Ptime.pp_rfc3339 ()) ts Log.pp_event event | `Log_subscribe -> Fmt.string ppf "log subscribe" let log_cmd = let f = function - | `C1 (timestamp, event) -> `Log_data (timestamp, event) - | `C2 () -> `Log_subscribe + | () -> `Log_subscribe and g = function - | `Log_data (timestamp, event) -> `C1 (timestamp, event) - | `Log_subscribe -> `C2 () + | `Log_subscribe -> () in Asn.S.map f g @@ - Asn.S.(choice2 - (explicit 0 (sequence2 - (required ~label:"timestamp" utc_time) - (required ~label:"event" log_event))) - (explicit 1 null)) + Asn.S.null type vm_cmd = [ | `Vm_info @@ -444,6 +417,45 @@ let wire_command : wire_command Asn.S.t = (explicit 3 vm_cmd) (explicit 4 policy_cmd)) +type data = [ + | `Console_data of Ptime.t * string + | `Stats_data of stats + | `Log_data of Ptime.t * Log.event +] + +let pp_data ppf = function + | `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s" + (Ptime.pp_rfc3339 ()) ts line + | `Stats_data stats -> Fmt.pf ppf "stats data: %a" pp_stats stats + | `Log_data (ts, event) -> Fmt.pf ppf "log data: %a %a" (Ptime.pp_rfc3339 ()) ts Log.pp_event event + +let data = + let f = function + | `C1 (timestamp, data) -> `Console_data (timestamp, data) + | `C2 (ru, ifs, vmm) -> `Stats_data (ru, vmm, ifs) + | `C3 (timestamp, event) -> `Log_data (timestamp, event) + and g = function + | `Console_data (timestamp, data) -> `C1 (timestamp, data) + | `Stats_data (ru, ifs, vmm) -> `C2 (ru, vmm, ifs) + | `Log_data (timestamp, event) -> `C3 (timestamp, event) + in + Asn.S.map f g @@ + Asn.S.(choice3 + (explicit 0 (sequence2 + (required ~label:"timestamp" utc_time) + (required ~label:"data" utf8_string))) + (explicit 1 (sequence3 + (required ~label:"resource_usage" ru) + (required ~label:"ifdata" (sequence_of ifdata)) + (optional ~label:"vmm_stats" + (sequence_of (sequence2 + (required ~label:"key" utf8_string) + (required ~label:"value" int64)))))) + (explicit 2 (sequence2 + (required ~label:"timestamp" utc_time) + (required ~label:"event" log_event)))) + + type header = { version : version ; sequence : int64 ; @@ -471,7 +483,8 @@ let pp_success ppf = function type wire = header * [ | `Command of wire_command | `Success of success - | `Failure of string ] + | `Failure of string + | `Data of data ] let pp_wire ppf (header, data) = let id = header.id in @@ -479,6 +492,7 @@ let pp_wire ppf (header, data) = | `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp_wire_command c | `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f | `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s + | `Data d -> pp_data ppf d let wire = let f (header, payload) = @@ -494,6 +508,7 @@ let wire = in `Success p | `C3 str -> `Failure str + | `C4 data -> `Data data and g (header, payload) = header, match payload with @@ -507,12 +522,13 @@ let wire = in `C2 p | `Failure str -> `C3 str + | `Data d -> `C4 d in Asn.S.map f g @@ Asn.S.(sequence2 (required ~label:"header" header) (required ~label:"payload" - (choice3 + (choice4 (explicit 0 wire_command) (explicit 1 (choice4 (explicit 0 null) @@ -525,7 +541,8 @@ let wire = (sequence2 (required ~label:"name" (sequence_of utf8_string)) (required ~label:"vm_config" vm_config)))))) - (explicit 2 utf8_string)))) + (explicit 2 utf8_string) + (explicit 3 data)))) let wire_of_cstruct, wire_to_cstruct = projections_of wire diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index ea1a5eb..ff5ec93 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -23,18 +23,15 @@ val pp_version : version Fmt.t type console_cmd = [ | `Console_add | `Console_subscribe - | `Console_data of Ptime.t * string ] type stats_cmd = [ | `Stats_add of int * string list | `Stats_remove | `Stats_subscribe - | `Stats_data of stats ] type log_cmd = [ - | `Log_data of Ptime.t * Log.event | `Log_subscribe ] @@ -60,6 +57,14 @@ type wire_command = [ val pp_wire_command : wire_command Fmt.t +type data = [ + | `Console_data of Ptime.t * string + | `Stats_data of stats + | `Log_data of Ptime.t * Log.event +] + +val pp_data : data Fmt.t + type header = { version : version ; sequence : int64 ; @@ -69,7 +74,8 @@ type header = { type wire = header * [ | `Command of wire_command | `Success of [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ] - | `Failure of string ] + | `Failure of string + | `Data of data ] val pp_wire : wire Fmt.t diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 0df0648..81e2aca 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -38,7 +38,7 @@ let log t id event = let header = Vmm_asn.{ version = t.wire_version ; sequence = t.log_counter ; id } in let log_counter = Int64.succ t.log_counter in Logs.debug (fun m -> m "LOG %a" Log.pp_event event) ; - ({ t with log_counter }, `Log (header, `Command (`Log_cmd data))) + ({ t with log_counter }, `Log (header, `Data data)) let handle_create t hdr vm_config = let name = hdr.Vmm_asn.id in @@ -80,13 +80,12 @@ let handle_shutdown t name vm r = | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; let resources = Vmm_resources.remove t.resources name in - let stat_out = `Stats_remove in let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let tasks = String.Map.remove (string_of_id name) t.tasks in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in let t, logout = log t name (`VM_stop (vm.pid, r)) in - (t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ; logout ]) + (t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ]) let handle_command t (header, payload) = let msg_to_err = function diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index 208434c..02f8424 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -121,8 +121,7 @@ let tick t = | Some real_id -> let header = Vmm_asn.{ version = my_version ; sequence = !bcast ; id = real_id } in bcast := Int64.succ !bcast ; - let data = `Stats_data stats in - ((socket, vmid, (header, `Command (`Stats_cmd data))) :: out)) + ((socket, vmid, (header, `Data (`Stats_data stats))) :: out)) out xs) [] (Vmm_trie.all t'.vmid_pid) in @@ -192,7 +191,6 @@ let handle t socket (header, wire) = | `Stats_subscribe -> let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in Ok ({ t with name_sockets }, `None, close, Some "subscribed") - | _ -> Error (`Msg "unknown command") end | _ -> Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire (header, wire)) ; From d513269453c6ad3af6640c2560b40e7335d81bf4 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Oct 2018 00:03:36 +0200 Subject: [PATCH 43/73] move stuff into vmm_commands --- app/vmm_client.ml | 2 +- app/vmm_console.ml | 12 +-- app/vmm_influxdb_stats.ml | 9 +- app/vmm_log.ml | 32 +++---- app/vmm_tls_endpoint.ml | 8 +- app/vmmc.ml | 10 +-- app/vmmd.ml | 2 +- provision/vmm_sign.ml | 4 +- src/vmm_asn.ml | 185 +++++++------------------------------- src/vmm_asn.mli | 85 ++---------------- src/vmm_commands.ml | 126 +++++++++++++++++++++++++- src/vmm_commands.mli | 85 ++++++++++++++++-- src/vmm_core.ml | 166 +++++++++++++++++++--------------- src/vmm_core.mli | 142 +++++++++++++++-------------- src/vmm_engine.ml | 36 ++++---- src/vmm_engine.mli | 12 +-- src/vmm_lwt.mli | 22 +++-- src/vmm_tls.mli | 8 +- stats/vmm_stats.ml | 15 ++-- 19 files changed, 496 insertions(+), 465 deletions(-) diff --git a/app/vmm_client.ml b/app/vmm_client.ml index bebe90f..f38b58c 100644 --- a/app/vmm_client.ml +++ b/app/vmm_client.ml @@ -6,7 +6,7 @@ let rec read_tls_write_cons t = Vmm_tls.read_tls t >>= function | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit | Ok wire -> - Logs.app (fun m -> m "%a" Vmm_asn.pp_wire wire) ; + Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire) ; read_tls_write_cons t let client cas host port cert priv_key = diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 7365cca..1fb787d 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -31,7 +31,7 @@ let read_console name ring channel () = (match String.Map.find name !active with | None -> Lwt.return_unit | Some fd -> - let header = Vmm_asn.{ version = my_version ; sequence = 0L ; id } in + let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function | Error _ -> Vmm_lwt.safe_close fd >|= fun () -> @@ -91,7 +91,7 @@ let subscribe s id = let entries = Vmm_ring.read r in Logs.debug (fun m -> m "found %d history" (List.length entries)) ; Lwt_list.iter_s (fun (i, v) -> - let header = Vmm_asn.{ version = my_version ; sequence = 0L ; id } in + let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >|= fun _ -> ()) entries >>= fun () -> (match String.Map.find name !active with @@ -109,12 +109,12 @@ let handle s addr () = Lwt.return_unit | Ok (header, `Command (`Console_cmd cmd)) -> begin - (if not (Vmm_asn.version_eq header.Vmm_asn.version my_version) then + (if not (Vmm_commands.version_eq header.Vmm_commands.version my_version) then Lwt.return (Error (`Msg "ignoring data with bad version")) else match cmd with - | `Console_add -> add_fifo header.Vmm_asn.id - | `Console_subscribe -> subscribe s header.Vmm_asn.id) >>= (function + | `Console_add -> add_fifo header.Vmm_commands.id + | `Console_subscribe -> subscribe s header.Vmm_commands.id) >>= (function | Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg)) | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; @@ -125,7 +125,7 @@ let handle s addr () = Lwt.return_unit end | Ok wire -> - Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire wire) ; + Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ; loop () in loop () >>= fun () -> diff --git a/app/vmm_influxdb_stats.ml b/app/vmm_influxdb_stats.ml index d6b172c..f53ce3c 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmm_influxdb_stats.ml @@ -5,6 +5,7 @@ open Lwt.Infix open Astring open Vmm_core +open Vmm_core.Stats (* @@ -191,13 +192,13 @@ let rec read_sock_write_tcp c ?fd addr addrtype = true | Ok (hdr, `Data (`Stats_data (ru, vmm, ifs))) -> begin - if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin + if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin Logs.err (fun m -> m "unknown wire protocol version") ; safe_close fd >>= fun () -> safe_close c >|= fun () -> false end else - let name = string_of_id hdr.Vmm_asn.id in + let name = string_of_id hdr.Vmm_commands.id in let ru = P.encode_ru name ru in let vmm = match vmm with None -> [] | Some xs -> [ P.encode_vmm name xs ] in let taps = List.map (P.encode_if name) ifs in @@ -214,12 +215,12 @@ let rec read_sock_write_tcp c ?fd addr addrtype = false end | Ok wire -> - Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire wire) ; + Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ; Lwt.return (Some fd) >>= fun fd -> read_sock_write_tcp c ?fd addr addrtype let query_sock vm c = - let header = Vmm_asn.{ version = my_version ; sequence = !command ; id = vm } in + let header = Vmm_commands.{ version = my_version ; sequence = !command ; id = vm } in command := Int64.succ !command ; Logs.debug (fun m -> m "%Lu requesting %a via socket" !command pp_id vm) ; Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe)) diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 089e188..bc6bc73 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -55,25 +55,26 @@ let write_to_file file = let tree = ref Vmm_trie.empty -let bcast = ref 0L - let send_history s ring id = let elements = Vmm_ring.read ring in let res = List.fold_left (fun acc (_, x) -> let cs = Cstruct.of_string x in match Vmm_asn.log_entry_of_cstruct cs with - | Ok (header, ts, event) -> - if Vmm_core.is_sub_id ~super:id ~sub:header.Vmm_asn.id - then (header, ts, event) :: acc + | Ok (ts, event) -> + let sub = Vmm_core.Log.name event in + if Vmm_core.is_sub_id ~super:id ~sub + then (ts, event) :: acc else acc | _ -> acc) [] elements in (* just need a wrapper in tag = Log.Data, id = reqid *) - Lwt_list.fold_left_s (fun r (header, ts, event) -> + Lwt_list.fold_left_s (fun r (ts, event) -> match r with - | Ok () -> Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event))) + | Ok () -> + let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in + Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event))) | Error e -> Lwt.return (Error e)) (Ok ()) res @@ -90,30 +91,29 @@ let handle mvar ring s addr () = Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit | Ok (hdr, `Data (`Log_data (ts, event))) -> - if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin + if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin Logs.warn (fun m -> m "unsupported version") ; Lwt.return_unit end else begin - let data = Vmm_asn.log_entry_to_cstruct (hdr, ts, event) in + let data = Vmm_asn.log_entry_to_cstruct (ts, event) in Vmm_ring.write ring (ts, Cstruct.to_string data) ; Lwt_mvar.put mvar data >>= fun () -> let data' = - let header = Vmm_asn.{ version = my_version ; sequence = !bcast ; id = hdr.Vmm_asn.id } in + let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id = hdr.Vmm_commands.id } in (header, `Data (`Log_data (ts, event))) in - bcast := Int64.succ !bcast ; - broadcast hdr.Vmm_asn.id data' !tree >>= fun tree' -> + broadcast hdr.Vmm_commands.id data' !tree >>= fun tree' -> tree := tree' ; loop () end | Ok (hdr, `Command (`Log_cmd lc)) -> - if not (Vmm_asn.version_eq hdr.Vmm_asn.version my_version) then begin + if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin Logs.warn (fun m -> m "unsupported version") ; Lwt.return_unit end else begin match lc with | `Log_subscribe -> - let tree', ret = Vmm_trie.insert hdr.Vmm_asn.id s !tree in + let tree', ret = Vmm_trie.insert hdr.Vmm_commands.id s !tree in tree := tree' ; (match ret with | None -> Lwt.return_unit @@ -124,14 +124,14 @@ let handle mvar ring s addr () = Logs.err (fun m -> m "error while sending reply for subscribe") ; Lwt.return_unit | Ok () -> - send_history s ring hdr.Vmm_asn.id >>= function + send_history s ring hdr.Vmm_commands.id >>= function | Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit | Ok () -> loop () (* TODO no need to loop ;) *) end | Ok wire -> - Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire wire) ; + Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ; loop () in loop () >>= fun () -> diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 852e090..8c8f8f6 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -44,7 +44,7 @@ let read fd tls = Vmm_lwt.read_wire fd >>= function | Error _ -> Lwt.return (Error (`Msg "exception while reading")) | Ok wire -> - Logs.debug (fun m -> m "read proxying %a" Vmm_asn.pp_wire wire) ; + Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire wire) ; Vmm_tls.write_tls tls wire >>= function | Ok () -> loop () | Error `Exception -> Lwt.return (Error (`Msg "exception")) @@ -55,7 +55,7 @@ let process fd tls = Vmm_lwt.read_wire fd >>= function | Error _ -> Lwt.return (Error (`Msg "read error")) | Ok wire -> - Logs.debug (fun m -> m "proxying %a" Vmm_asn.pp_wire wire) ; + Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ; Vmm_tls.write_tls tls wire >|= function | Ok () -> Ok () | Error `Exception -> Error (`Msg "exception on write") @@ -65,10 +65,10 @@ let handle ca (tls, addr) = match Vmm_x509.handle addr chain with | Error (`Msg m) -> Lwt.fail_with m | Ok (name, cmd) -> - let sock, next = Vmm_commands.handle cmd in + let sock, next = Vmm_commands.endpoint cmd in connect (Vmm_core.socket_path sock) >>= fun fd -> let wire = - let header = Vmm_asn.{version = my_version ; sequence = !command ; id = name } in + let header = Vmm_commands.{version = my_version ; sequence = !command ; id = name } in command := Int64.succ !command ; (header, `Command cmd) in diff --git a/app/vmmc.ml b/app/vmmc.ml index 04ca11f..5904d32 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -13,8 +13,8 @@ let process fd = | Error _ -> Error (`Msg "read or parse error") | Ok (header, reply) -> - if Vmm_asn.version_eq header.Vmm_asn.version version then begin - Logs.app (fun m -> m "%a" Vmm_asn.pp_wire (header, reply)) ; + if Vmm_commands.version_eq header.Vmm_commands.version version then begin + Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) ; Ok () end else begin Logs.err (fun m -> m "version not equal") ; @@ -40,10 +40,10 @@ let read fd = in loop () -let handle opt_socket id (cmd : Vmm_asn.wire_command) = - let sock, next = Vmm_commands.handle cmd in +let handle opt_socket id (cmd : Vmm_commands.t) = + let sock, next = Vmm_commands.endpoint cmd in connect (socket sock opt_socket) >>= fun fd -> - let header = Vmm_asn.{ version ; sequence = 0L ; id } in + let header = Vmm_commands.{ version ; sequence = 0L ; id } in Vmm_lwt.write_wire fd (header, `Command cmd) >>= function | Error `Exception -> Lwt.return (Error (`Msg "couldn't write")) | Ok () -> diff --git a/app/vmmd.ml b/app/vmmd.ml index e0238b7..5a22172 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -29,7 +29,7 @@ let create c_fd process cont = Logs.err (fun m -> m "error while reading from console") ; Lwt.return_unit | Ok (header, wire) -> - if not (Vmm_asn.version_eq version header.Vmm_asn.version) then begin + if not (Vmm_commands.version_eq version header.Vmm_commands.version) then begin Logs.err (fun m -> m "invalid version while reading from console") ; Lwt.return_unit end else diff --git a/provision/vmm_sign.ml b/provision/vmm_sign.ml index 425c7b2..26ece81 100644 --- a/provision/vmm_sign.ml +++ b/provision/vmm_sign.ml @@ -29,12 +29,12 @@ let sign dbname cacert key csr days = with | [ (_, `Unsupported (_, v)) as ext ] -> Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) -> - (if Vmm_asn.version_eq version asn_version then + (if Vmm_commands.version_eq version asn_version then Ok () else Error (`Msg "unknown version in request")) >>= fun () -> (* TODO l_exts / d_exts trouble *) - Logs.app (fun m -> m "signing %a" Vmm_asn.pp_wire_command cmd) ; + Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ; Ok (ext :: l_exts) >>= fun extensions -> sign ~dbname extensions issuer key csr (Duration.of_day days) | _ -> Error (`Msg "none or multiple albatross extensions found") diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 7f2df72..1313e91 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -1,6 +1,7 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) open Vmm_core +open Vmm_commands open Rresult open Astring @@ -86,32 +87,6 @@ let image = (explicit 1 octet_string) (explicit 2 octet_string)) -type version = [ `AV0 | `AV1 | `AV2 ] - -let pp_version ppf v = - Fmt.int ppf - (match v with - | `AV0 -> 0 - | `AV1 -> 1 - | `AV2 -> 2) - -let version_eq a b = - match a, b with - | `AV0, `AV0 -> true - | `AV1, `AV1 -> true - | `AV2, `AV2 -> true - | _ -> false - -(* communication protocol *) -type console_cmd = [ - | `Console_add - | `Console_subscribe -] - -let pp_console_cmd ppf = function - | `Console_add -> Fmt.string ppf "console add" - | `Console_subscribe -> Fmt.string ppf "console subscribe" - let console_cmd = let f = function | `C1 () -> `Console_add @@ -141,6 +116,7 @@ let timeval = (required ~label:"microseconds" int)) let ru = + let open Stats in let f (utime, (stime, (maxrss, (ixrss, (idrss, (isrss, (minflt, (majflt, (nswap, (inblock, (outblock, (msgsnd, (msgrcv, (nsignals, (nvcsw, nivcsw))))))))))))))) = { utime ; stime ; maxrss ; ixrss ; idrss ; isrss ; minflt ; majflt ; nswap ; inblock ; outblock ; msgsnd ; msgrcv ; nsignals ; nvcsw ; nivcsw } and g ru = @@ -173,6 +149,7 @@ let int32 = Asn.S.map f g Asn.S.int let ifdata = + let open Stats in let f (name, (flags, (send_length, (max_send_length, (send_drops, (mtu, (baudrate, (input_packets, (input_errors, (output_packets, (output_errors, (collisions, (input_bytes, (output_bytes, (input_mcast, (output_mcast, (input_dropped, output_dropped))))))))))))))))) = { name; flags; send_length; max_send_length; send_drops; mtu; baudrate; input_packets; input_errors; output_packets; output_errors; collisions; input_bytes; output_bytes; input_mcast; output_mcast; input_dropped; output_dropped } and g i = @@ -199,17 +176,6 @@ let ifdata = @ (required ~label:"input_dropped" int64) -@ (required ~label:"output_dropped" int64)) -type stats_cmd = [ - | `Stats_add of int * string list - | `Stats_remove - | `Stats_subscribe -] - -let pp_stats_cmd ppf = function - | `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps - | `Stats_remove -> Fmt.string ppf "stat remove" - | `Stats_subscribe -> Fmt.string ppf "stat subscribe" - let stats_cmd = let f = function | `C1 (pid, taps) -> `Stats_add (pid, taps) @@ -228,60 +194,56 @@ let stats_cmd = (explicit 1 null) (explicit 2 null)) -let addr = - Asn.S.(sequence2 - (required ~label:"ip" ipv4) - (required ~label:"port" int)) - let log_event = let f = function | `C1 () -> `Startup - | `C2 (ip, port) -> `Login (ip, port) - | `C3 (ip, port) -> `Logout (ip, port) - | `C4 (pid, taps, block) -> `VM_start (pid, taps, block) - | `C5 (pid, status) -> + | `C2 (name, ip, port) -> `Login (name, ip, port) + | `C3 (name, ip, port) -> `Logout (name, ip, port) + | `C4 (name, pid, taps, block) -> `Vm_start (name, pid, taps, block) + | `C5 (name, pid, status) -> let status' = match status with | `C1 n -> `Exit n | `C2 n -> `Signal n | `C3 n -> `Stop n in - `VM_stop (pid, status') + `Vm_stop (name, pid, status') and g = function | `Startup -> `C1 () - | `Login (ip, port) -> `C2 (ip, port) - | `Logout (ip, port) -> `C3 (ip, port) - | `VM_start (pid, taps, block) -> `C4 (pid, taps, block) - | `VM_stop (pid, status) -> + | `Login (name, ip, port) -> `C2 (name, ip, port) + | `Logout (name, ip, port) -> `C3 (name, ip, port) + | `Vm_start (name, pid, taps, block) -> `C4 (name, pid, taps, block) + | `Vm_stop (name, pid, status) -> let status' = match status with | `Exit n -> `C1 n | `Signal n -> `C2 n | `Stop n -> `C3 n in - `C5 (pid, status') + `C5 (name, pid, status') + in + let endp = + Asn.S.(sequence3 + (required ~label:"name" (sequence_of utf8_string)) + (required ~label:"ip" ipv4) + (required ~label:"port" int)) in Asn.S.map f g @@ Asn.S.(choice5 (explicit 0 null) - (explicit 1 addr) - (explicit 2 addr) - (explicit 3 (sequence3 - (required ~label:"pid" int) - (required ~label:"taps" (sequence_of utf8_string)) - (optional ~label:"block" utf8_string))) - (explicit 4 (sequence2 + (explicit 1 endp) + (explicit 2 endp) + (explicit 3 (sequence4 + (required ~label:"name" (sequence_of utf8_string)) + (required ~label:"pid" int) + (required ~label:"taps" (sequence_of utf8_string)) + (optional ~label:"block" utf8_string))) + (explicit 4 (sequence3 + (required ~label:"name" (sequence_of utf8_string)) (required ~label:"pid" int) (required ~label:"status" (choice3 (explicit 0 int) (explicit 1 int) (explicit 2 int)))))) -type log_cmd = [ - | `Log_subscribe -] - -let pp_log_cmd ppf = function - | `Log_subscribe -> Fmt.string ppf "log subscribe" - let log_cmd = let f = function | () -> `Log_subscribe @@ -291,19 +253,6 @@ let log_cmd = Asn.S.map f g @@ Asn.S.null -type vm_cmd = [ - | `Vm_info - | `Vm_create of vm_config - | `Vm_force_create of vm_config - | `Vm_destroy -] - -let pp_vm_cmd ppf = function - | `Vm_info -> Fmt.string ppf "vm info" - | `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config - | `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config - | `Vm_destroy -> Fmt.string ppf "vm destroy" - let vm_config = let f (cpuid, requested_memory, block_device, network, vmimage, argv) = let network = match network with None -> [] | Some xs -> xs in @@ -340,17 +289,6 @@ let vm_cmd = (explicit 2 vm_config) (explicit 3 null)) -type policy_cmd = [ - | `Policy_info - | `Policy_add of policy - | `Policy_remove -] - -let pp_policy_cmd ppf = function - | `Policy_info -> Fmt.string ppf "policy info" - | `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy - | `Policy_remove -> Fmt.string ppf "policy remove" - let policy_cmd = let f = function | `C1 () -> `Policy_info @@ -380,22 +318,7 @@ let version = in Asn.S.map f g Asn.S.int -type wire_command = [ - | `Console_cmd of console_cmd - | `Stats_cmd of stats_cmd - | `Log_cmd of log_cmd - | `Vm_cmd of vm_cmd - | `Policy_cmd of policy_cmd - ] - -let pp_wire_command ppf = function - | `Console_cmd c -> pp_console_cmd ppf c - | `Stats_cmd s -> pp_stats_cmd ppf s - | `Log_cmd l -> pp_log_cmd ppf l - | `Vm_cmd v -> pp_vm_cmd ppf v - | `Policy_cmd p -> pp_policy_cmd ppf p - -let wire_command : wire_command Asn.S.t = +let wire_command = let f = function | `C1 console -> `Console_cmd console | `C2 stats -> `Stats_cmd stats @@ -417,18 +340,6 @@ let wire_command : wire_command Asn.S.t = (explicit 3 vm_cmd) (explicit 4 policy_cmd)) -type data = [ - | `Console_data of Ptime.t * string - | `Stats_data of stats - | `Log_data of Ptime.t * Log.event -] - -let pp_data ppf = function - | `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s" - (Ptime.pp_rfc3339 ()) ts line - | `Stats_data stats -> Fmt.pf ppf "stats data: %a" pp_stats stats - | `Log_data (ts, event) -> Fmt.pf ppf "log data: %a %a" (Ptime.pp_rfc3339 ()) ts Log.pp_event event - let data = let f = function | `C1 (timestamp, data) -> `Console_data (timestamp, data) @@ -455,13 +366,6 @@ let data = (required ~label:"timestamp" utc_time) (required ~label:"event" log_event)))) - -type header = { - version : version ; - sequence : int64 ; - id : id ; -} - let header = let f (version, sequence, id) = { version ; sequence ; id } and g h = h.version, h.sequence, h.id @@ -472,28 +376,6 @@ let header = (required ~label:"sequence" int64) (required ~label:"id" (sequence_of utf8_string))) -type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ] - -let pp_success ppf = function - | `Empty -> Fmt.string ppf "success" - | `String data -> Fmt.pf ppf "success: %s" data - | `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps - | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms - -type wire = header * [ - | `Command of wire_command - | `Success of success - | `Failure of string - | `Data of data ] - -let pp_wire ppf (header, data) = - let id = header.id in - match data with - | `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp_wire_command c - | `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f - | `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s - | `Data d -> pp_data ppf d - let wire = let f (header, payload) = header, @@ -544,19 +426,16 @@ let wire = (explicit 2 utf8_string) (explicit 3 data)))) -let wire_of_cstruct, wire_to_cstruct = projections_of wire - -type log_entry = header * Ptime.t * Log.event +let wire_of_cstruct, (wire_to_cstruct : Vmm_commands.wire -> Cstruct.t) = projections_of wire let log_entry = - Asn.S.(sequence3 - (required ~label:"headet" header) + Asn.S.(sequence2 (required ~label:"timestamp" utc_time) (required ~label:"event" log_event)) let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry -type cert_extension = version * wire_command +type cert_extension = version * t let cert_extension = Asn.S.(sequence2 diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index ff5ec93..8fd920d 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -9,89 +9,18 @@ open Vmm_core (** OID in the Mirage namespace (enterprise arc 1.3.6.1.4.1.49836.43) *) val oid : Asn.OID.t -(** {1 Encoding and decoding functions} *) +val wire_to_cstruct : Vmm_commands.wire -> Cstruct.t -(** The type of versions of the ASN.1 grammar defined above. *) -type version = [ `AV0 | `AV1 | `AV2 ] +val wire_of_cstruct : Cstruct.t -> (Vmm_commands.wire, [> `Msg of string ]) result -(** [version_eq a b] is true if [a] and [b] are equal. *) -val version_eq : version -> version -> bool +val log_entry_to_cstruct : Log.t -> Cstruct.t -(** [pp_version ppf version] pretty prints [version] onto [ppf]. *) -val pp_version : version Fmt.t +val log_entry_of_cstruct : Cstruct.t -> (Log.t, [> `Msg of string ]) result -type console_cmd = [ - | `Console_add - | `Console_subscribe -] - -type stats_cmd = [ - | `Stats_add of int * string list - | `Stats_remove - | `Stats_subscribe -] - -type log_cmd = [ - | `Log_subscribe -] - -type vm_cmd = [ - | `Vm_info - | `Vm_create of vm_config - | `Vm_force_create of vm_config - | `Vm_destroy -] - -type policy_cmd = [ - | `Policy_info - | `Policy_add of policy - | `Policy_remove -] - -type wire_command = [ - | `Console_cmd of console_cmd - | `Stats_cmd of stats_cmd - | `Log_cmd of log_cmd - | `Vm_cmd of vm_cmd - | `Policy_cmd of policy_cmd ] - -val pp_wire_command : wire_command Fmt.t - -type data = [ - | `Console_data of Ptime.t * string - | `Stats_data of stats - | `Log_data of Ptime.t * Log.event -] - -val pp_data : data Fmt.t - -type header = { - version : version ; - sequence : int64 ; - id : id ; -} - -type wire = header * [ - | `Command of wire_command - | `Success of [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ] - | `Failure of string - | `Data of data ] - -val pp_wire : wire Fmt.t - -val wire_to_cstruct : wire -> Cstruct.t - -val wire_of_cstruct : Cstruct.t -> (wire, [> `Msg of string ]) result - -type log_entry = header * Ptime.t * Log.event - -val log_entry_to_cstruct : log_entry -> Cstruct.t - -val log_entry_of_cstruct : Cstruct.t -> (log_entry, [> `Msg of string ]) result - -type cert_extension = version * wire_command +type cert_extension = Vmm_commands.version * Vmm_commands.t val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result val cert_extension_to_cstruct : cert_extension -> Cstruct.t -val wire_command_of_cert : version -> X509.t -> (wire_command, [> `Msg of string ]) result +val wire_command_of_cert : Vmm_commands.version -> X509.t -> + (Vmm_commands.t, [> `Msg of string ]) result diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index f10f4c9..03b486f 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -1,10 +1,134 @@ (* (c) 2018 Hannes Mehnert, all rights reserved *) +(* the wire protocol *) open Vmm_core -let handle = function +type version = [ `AV0 | `AV1 | `AV2 ] + +let pp_version ppf v = + Fmt.int ppf + (match v with + | `AV0 -> 0 + | `AV1 -> 1 + | `AV2 -> 2) + +let version_eq a b = + match a, b with + | `AV0, `AV0 -> true + | `AV1, `AV1 -> true + | `AV2, `AV2 -> true + | _ -> false + +type console_cmd = [ + | `Console_add + | `Console_subscribe +] + +let pp_console_cmd ppf = function + | `Console_add -> Fmt.string ppf "console add" + | `Console_subscribe -> Fmt.string ppf "console subscribe" + +type stats_cmd = [ + | `Stats_add of int * string list + | `Stats_remove + | `Stats_subscribe +] + +let pp_stats_cmd ppf = function + | `Stats_add (pid, taps) -> Fmt.pf ppf "stats add: pid %d taps %a" pid Fmt.(list ~sep:(unit ", ") string) taps + | `Stats_remove -> Fmt.string ppf "stat remove" + | `Stats_subscribe -> Fmt.string ppf "stat subscribe" + +type log_cmd = [ + | `Log_subscribe +] + +let pp_log_cmd ppf = function + | `Log_subscribe -> Fmt.string ppf "log subscribe" + +type vm_cmd = [ + | `Vm_info + | `Vm_create of vm_config + | `Vm_force_create of vm_config + | `Vm_destroy +] + +let pp_vm_cmd ppf = function + | `Vm_info -> Fmt.string ppf "vm info" + | `Vm_create vm_config -> Fmt.pf ppf "create %a" pp_vm_config vm_config + | `Vm_force_create vm_config -> Fmt.pf ppf "force create %a" pp_vm_config vm_config + | `Vm_destroy -> Fmt.string ppf "vm destroy" + +type policy_cmd = [ + | `Policy_info + | `Policy_add of policy + | `Policy_remove +] + +let pp_policy_cmd ppf = function + | `Policy_info -> Fmt.string ppf "policy info" + | `Policy_add policy -> Fmt.pf ppf "add policy: %a" pp_policy policy + | `Policy_remove -> Fmt.string ppf "policy remove" + +type t = [ + | `Console_cmd of console_cmd + | `Stats_cmd of stats_cmd + | `Log_cmd of log_cmd + | `Vm_cmd of vm_cmd + | `Policy_cmd of policy_cmd + ] + +let pp ppf = function + | `Console_cmd c -> pp_console_cmd ppf c + | `Stats_cmd s -> pp_stats_cmd ppf s + | `Log_cmd l -> pp_log_cmd ppf l + | `Vm_cmd v -> pp_vm_cmd ppf v + | `Policy_cmd p -> pp_policy_cmd ppf p + +type data = [ + | `Console_data of Ptime.t * string + | `Stats_data of Stats.t + | `Log_data of Log.t +] + +let pp_data ppf = function + | `Console_data (ts, line) -> Fmt.pf ppf "console data %a: %s" + (Ptime.pp_rfc3339 ()) ts line + | `Stats_data stats -> Fmt.pf ppf "stats data: %a" Stats.pp stats + | `Log_data log -> Fmt.pf ppf "log data: %a" Log.pp log + +type header = { + version : version ; + sequence : int64 ; + id : id ; +} + +type success = [ `Empty | `String of string | `Policies of (id * policy) list | `Vms of (id * vm_config) list ] + +let pp_success ppf = function + | `Empty -> Fmt.string ppf "success" + | `String data -> Fmt.pf ppf "success: %s" data + | `Policies ps -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_policy)) ppf ps + | `Vms vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") pp_id pp_vm_config)) ppf vms + +type wire = header * [ + | `Command of t + | `Success of success + | `Failure of string + | `Data of data ] + +let pp_wire ppf (header, data) = + let id = header.id in + match data with + | `Command c -> Fmt.pf ppf "host %a: %a" pp_id id pp c + | `Failure f -> Fmt.pf ppf "host %a: command failed %s" pp_id id f + | `Success s -> Fmt.pf ppf "host %a: %a" pp_id id pp_success s + | `Data d -> pp_data ppf d + +let endpoint = function | `Vm_cmd _ -> `Vmmd, `End | `Policy_cmd _ -> `Vmmd, `End | `Stats_cmd _ -> `Stats, `Read | `Console_cmd _ -> `Console, `Read | `Log_cmd _ -> `Log, `Read + diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index f242239..430618a 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -1,7 +1,78 @@ -val handle : - [< `Console_cmd of 'a - | `Log_cmd of 'b - | `Policy_cmd of 'c - | `Stats_cmd of 'd - | `Vm_cmd of 'e ] -> - [> `Console | `Log | `Stats | `Vmmd ] * [> `End | `Read ] +open Vmm_core + +(** The type of versions of the grammar defined below. *) +type version = [ `AV0 | `AV1 | `AV2 ] + +(** [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 + +type console_cmd = [ + | `Console_add + | `Console_subscribe +] + +type stats_cmd = [ + | `Stats_add of int * string list + | `Stats_remove + | `Stats_subscribe +] + +type log_cmd = [ + | `Log_subscribe +] + +type vm_cmd = [ + | `Vm_info + | `Vm_create of vm_config + | `Vm_force_create of vm_config + | `Vm_destroy +] + +type policy_cmd = [ + | `Policy_info + | `Policy_add of policy + | `Policy_remove +] + +type t = [ + | `Console_cmd of console_cmd + | `Stats_cmd of stats_cmd + | `Log_cmd of log_cmd + | `Vm_cmd of vm_cmd + | `Policy_cmd of policy_cmd ] + +val pp : t Fmt.t + +type data = [ + | `Console_data of Ptime.t * string + | `Stats_data of Stats.t + | `Log_data of Log.t +] + +val pp_data : data Fmt.t + +type header = { + version : version ; + sequence : int64 ; + id : id ; +} + +type success = [ + | `Empty + | `String of string + | `Policies of (id * policy) list + | `Vms of (id * vm_config) list +] + +type wire = header * [ + | `Command of t + | `Success of success + | `Failure of string + | `Data of data ] + +val pp_wire : wire Fmt.t + +val endpoint : t -> service * [ `End | `Read ] diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 6f1c4b4..c43a348 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -7,6 +7,8 @@ open Rresult.R.Infix let tmpdir = Fpath.(v "/var" / "run" / "albatross") let dbdir = Fpath.(v "/var" / "db" / "albatross") +type service = [ `Console | `Log | `Stats | `Vmmd ] + let socket_path t = let path name = Fpath.(tmpdir / "util" / name + "sock") in let path = match t with @@ -185,88 +187,104 @@ let separate_chain = function | [ 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 ; -} +module Stats = struct + type rusage = { + utime : (int64 * int) ; + stime : (int64 * int) ; + maxrss : int64 ; + ixrss : int64 ; + idrss : int64 ; + isrss : int64 ; + minflt : int64 ; + majflt : int64 ; + nswap : int64 ; + inblock : int64 ; + outblock : int64 ; + msgsnd : int64 ; + msgrcv : int64 ; + nsignals : int64 ; + nvcsw : int64 ; + nivcsw : int64 ; + } -let pp_rusage ppf r = - Fmt.pf ppf "utime %Lu.%d stime %Lu.%d maxrss %Lu ixrss %Lu idrss %Lu isrss %Lu minflt %Lu majflt %Lu nswap %Lu inblock %Lu outblock %Lu msgsnd %Lu msgrcv %Lu signals %Lu nvcsw %Lu nivcsw %Lu" - (fst r.utime) (snd r.utime) (fst r.stime) (snd r.stime) r.maxrss r.ixrss r.idrss r.isrss r.minflt r.majflt r.nswap r.inblock r.outblock r.msgsnd r.msgrcv r.nsignals r.nvcsw r.nivcsw + let 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 vmm_stats = (string * int64) list -let pp_vmm_stats ppf vmm = - Fmt.(list ~sep:(unit "@,") (pair ~sep:(unit ": ") string int64)) ppf vmm + type vmm = (string * int64) list + let pp_vmm ppf vmm = + Fmt.(list ~sep:(unit "@,") (pair ~sep:(unit ": ") string int64)) ppf vmm -type ifdata = { - name : string ; - flags : int32 ; - send_length : int32 ; - max_send_length : int32 ; - send_drops : int32 ; - mtu : int32 ; - baudrate : int64 ; - input_packets : int64 ; - input_errors : int64 ; - output_packets : int64 ; - output_errors : int64 ; - collisions : int64 ; - input_bytes : int64 ; - output_bytes : int64 ; - input_mcast : int64 ; - output_mcast : int64 ; - input_dropped : int64 ; - output_dropped : int64 ; -} + type 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 + 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 -type stats = rusage * vmm_stats option * ifdata list -let pp_stats ppf (ru, vmm, ifs) = - Fmt.pf ppf "%a@.%a@.%a" - pp_rusage ru - Fmt.(option ~none:(unit "no vmm stats") pp_vmm_stats) vmm - Fmt.(list ~sep:(unit "@.@.") pp_ifdata) ifs + type t = rusage * vmm option * ifdata list + let pp ppf (ru, vmm, ifs) = + Fmt.pf ppf "%a@.%a@.%a" + pp_rusage ru + Fmt.(option ~none:(unit "no vmm stats") pp_vmm) vmm + Fmt.(list ~sep:(unit "@.@.") pp_ifdata) ifs +end + +type process_exit = [ `Exit of int | `Signal of int | `Stop of int ] + +let pp_process_exit ppf = function + | `Exit n -> Fmt.pf ppf "exit %a (%d)" Fmt.Dump.signal n n + | `Signal n -> Fmt.pf ppf "signal %a (%d)" Fmt.Dump.signal n n + | `Stop n -> Fmt.pf ppf "stop %a (%d)" Fmt.Dump.signal n n module Log = struct - type 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 ] - ] + type log_event = [ + | `Login of id * Ipaddr.V4.t * int + | `Logout of id * Ipaddr.V4.t * int + | `Startup + | `Vm_start of id * int * string list * string option + | `Vm_stop of id * int * process_exit + ] - let 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 + let name = function + | `Startup -> [] + | `Login (name, _, _) -> name + | `Logout (name, _, _) -> name + | `Vm_start (name, _, _ ,_) -> name + | `Vm_stop (name, _, _) -> name + + let pp_log_event ppf = function + | `Startup -> Fmt.(pf ppf "startup") + | `Login (name, ip, port) -> Fmt.pf ppf "%a login %a:%d" pp_id name Ipaddr.V4.pp_hum ip port + | `Logout (name, ip, port) -> Fmt.pf ppf "%a logout %a:%d" pp_id name Ipaddr.V4.pp_hum ip port + | `Vm_start (name, pid, taps, block) -> + Fmt.pf ppf "%a started %d (tap %a, block %a)" + pp_id name pid Fmt.(list ~sep:(unit "; ") string) taps Fmt.(option ~none:(unit "no") string) block - | `VM_stop (pid, code) -> - let s, c = match code with - | `Exit n -> "exit", n - | `Signal n -> "signal", n - | `Stop n -> "stop", n - in - Fmt.pf ppf "STOPPED %d with %s %a" pid s Fmt.Dump.signal c + | `Vm_stop (name, pid, code) -> + Fmt.pf ppf "%a stopped %d with %a" pp_id name pid pp_process_exit code + + type t = Ptime.t * log_event + + let pp ppf (ts, ev) = + Fmt.pf ppf "%a: %a" (Ptime.pp_rfc3339 ()) ts pp_log_event ev end diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 2b1a12b..48c91e5 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -1,8 +1,11 @@ val tmpdir : Fpath.t val dbdir : Fpath.t -val socket_path : [< `Console | `Log | `Stats | `Vmmd ] -> string -val pp_socket : - Format.formatter -> [< `Console | `Log | `Stats | `Vmmd ] -> unit + +type service = [ `Console | `Log | `Stats | `Vmmd ] + +val socket_path : service -> string +val pp_socket : service Fmt.t + module I : sig type t = int val compare : int -> int -> int end module IS : sig @@ -14,9 +17,6 @@ module IM : sig include Map.S with type key = I.t end -type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] -val pp_vmtype : vmtype Fmt.t - type id = string list val string_of_id : string list -> string val id_of_string : string -> string list @@ -45,6 +45,9 @@ val sub_block : 'a option -> 'a option -> bool val sub_cpu : IS.t -> IS.t -> bool val is_sub : super:policy -> sub:policy -> bool +type vmtype = [ `Hvt_amd64 | `Hvt_amd64_compressed | `Hvt_arm64 ] +val pp_vmtype : vmtype Fmt.t + type vm_config = { cpuid : int; requested_memory : int; @@ -79,68 +82,73 @@ val name : X509.t -> string val separate_chain : 'a list -> ('a * 'a list, [> `Msg of string ]) result -type rusage = { - utime : int64 * int; - stime : int64 * int; - maxrss : int64; - ixrss : int64; - idrss : int64; - isrss : int64; - minflt : int64; - majflt : int64; - nswap : int64; - inblock : int64; - outblock : int64; - msgsnd : int64; - msgrcv : int64; - nsignals : int64; - nvcsw : int64; - nivcsw : int64; -} -val pp_rusage : rusage Fmt.t +module Stats : sig + type rusage = { + utime : int64 * int; + stime : int64 * int; + maxrss : int64; + ixrss : int64; + idrss : int64; + isrss : int64; + minflt : int64; + majflt : int64; + nswap : int64; + inblock : int64; + outblock : int64; + msgsnd : int64; + msgrcv : int64; + nsignals : int64; + nvcsw : int64; + nivcsw : int64; + } + val pp_rusage : rusage Fmt.t -type vmm_stats = (string * int64) list -val pp_vmm_stats : vmm_stats Fmt.t + type vmm = (string * int64) list + val pp_vmm : vmm Fmt.t -type ifdata = { - name : string; - flags : int32; - send_length : int32; - max_send_length : int32; - send_drops : int32; - mtu : int32; - baudrate : int64; - input_packets : int64; - input_errors : int64; - output_packets : int64; - output_errors : int64; - collisions : int64; - input_bytes : int64; - output_bytes : int64; - input_mcast : int64; - output_mcast : int64; - input_dropped : int64; - output_dropped : int64; -} -val pp_ifdata : ifdata Fmt.t + type ifdata = { + name : string; + flags : int32; + send_length : int32; + max_send_length : int32; + send_drops : int32; + mtu : int32; + baudrate : int64; + input_packets : int64; + input_errors : int64; + output_packets : int64; + output_errors : int64; + collisions : int64; + input_bytes : int64; + output_bytes : int64; + input_mcast : int64; + output_mcast : int64; + input_dropped : int64; + output_dropped : int64; + } + val pp_ifdata : ifdata Fmt.t -type stats = rusage * vmm_stats option * ifdata list -val pp_stats : stats Fmt.t + type t = rusage * vmm option * ifdata list + val pp : t Fmt.t +end -module Log : - sig - type event = - [ `Login of Ipaddr.V4.t * int - | `Logout of Ipaddr.V4.t * int - | `Startup - | `VM_start of int * string list * string option - | `VM_stop of int * [ `Exit of int | `Signal of int | `Stop of int ] ] - val pp_event : - Format.formatter -> - [< `Login of Ipaddr.V4.t * int - | `Logout of Ipaddr.V4.t * int - | `Startup - | `VM_start of int * string list * string option - | `VM_stop of int * [< `Exit of int | `Signal of int | `Stop of int ] ] -> - unit - end +type process_exit = [ `Exit of int | `Signal of int | `Stop of int ] + +val pp_process_exit : process_exit Fmt.t + +module Log : sig + type log_event = [ + | `Login of id * Ipaddr.V4.t * int + | `Logout of id * Ipaddr.V4.t * int + | `Startup + | `Vm_start of id * int * string list * string option + | `Vm_stop of id * int * process_exit ] + + val name : log_event -> id + + val pp_log_event : log_event Fmt.t + + type t = Ptime.t * log_event + + val pp : t Fmt.t +end diff --git a/src/vmm_engine.ml b/src/vmm_engine.ml index 81e2aca..4a089e7 100644 --- a/src/vmm_engine.ml +++ b/src/vmm_engine.ml @@ -8,7 +8,7 @@ open Rresult open R.Infix type 'a t = { - wire_version : Vmm_asn.version ; + wire_version : Vmm_commands.version ; console_counter : int64 ; stats_counter : int64 ; log_counter : int64 ; @@ -26,22 +26,22 @@ let init wire_version = { } type service_out = [ - | `Stat of Vmm_asn.wire - | `Log of Vmm_asn.wire - | `Cons of Vmm_asn.wire + | `Stat of Vmm_commands.wire + | `Log of Vmm_commands.wire + | `Cons of Vmm_commands.wire ] -type out = [ service_out | `Data of Vmm_asn.wire ] +type out = [ service_out | `Data of Vmm_commands.wire ] let log t id event = - let data = `Log_data (Ptime_clock.now (), event) in - let header = Vmm_asn.{ version = t.wire_version ; sequence = t.log_counter ; id } in + let data = (Ptime_clock.now (), event) in + let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; id } in let log_counter = Int64.succ t.log_counter in - Logs.debug (fun m -> m "LOG %a" Log.pp_event event) ; - ({ t with log_counter }, `Log (header, `Data data)) + Logs.debug (fun m -> m "log %a" Log.pp data) ; + ({ t with log_counter }, `Log (header, `Data (`Log_data data))) let handle_create t hdr vm_config = - let name = hdr.Vmm_asn.id in + let name = hdr.Vmm_commands.id in (match Vmm_resources.find_vm t.resources name with | Some _ -> Error (`Msg "VM with same name is already running") | None -> Ok ()) >>= fun () -> @@ -54,7 +54,7 @@ let handle_create t hdr vm_config = Vmm_unix.prepare name vm_config >>= fun taps -> Logs.debug (fun m -> m "prepared vm with taps %a" Fmt.(list ~sep:(unit ",@ ") string) taps) ; let cons_out = - let header = Vmm_asn.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in + let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in (header, `Command (`Console_cmd `Console_add)) in Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons_out ], @@ -65,13 +65,13 @@ let handle_create t hdr vm_config = Vmm_resources.insert_vm t.resources name vm >>= fun resources -> let tasks = String.Map.add (string_of_id name) task t.tasks in let t = { t with resources ; tasks } in - let t, out = log t name (`VM_start (vm.pid, vm.taps, None)) in + let t, out = log t name (`Vm_start (name, vm.pid, vm.taps, None)) in let data = `Success (`String "created VM") in Ok (t, [ `Data (hdr, data) ; out ], name, vm))) let setup_stats t name vm = let stat_out = `Stats_add (vm.pid, vm.taps) in - let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in + let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let t = { t with stats_counter = Int64.succ t.stats_counter } in t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ] @@ -80,10 +80,10 @@ let handle_shutdown t name vm r = | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; let resources = Vmm_resources.remove t.resources name in - let header = Vmm_asn.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in + let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let tasks = String.Map.remove (string_of_id name) t.tasks in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in - let t, logout = log t name (`VM_stop (vm.pid, r)) + let t, logout = log t name (`Vm_stop (name, vm.pid, r)) in (t, [ `Stat (header, `Command (`Stats_cmd `Stats_remove)) ; logout ]) @@ -96,12 +96,12 @@ let handle_command t (header, payload) = (t, [ `Data (header, out) ], `End) in msg_to_err ( - let id = header.Vmm_asn.id in + let id = header.Vmm_commands.id in match payload with | `Command (`Policy_cmd pc) -> begin match pc with | `Policy_remove -> - Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_asn.id) ; + Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ; let resources = Vmm_resources.remove t.resources id in Ok ({ t with resources }, [ `Data (header, `Success (`String "removed policy")) ], `End) | `Policy_add policy -> @@ -179,5 +179,5 @@ let handle_command t (header, payload) = end end | _ -> - Logs.err (fun m -> m "ignoring %a" Vmm_asn.pp_wire (header, payload)) ; + Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ; Error (`Msg "unknown command")) diff --git a/src/vmm_engine.mli b/src/vmm_engine.mli index bf119a5..3f4fd2f 100644 --- a/src/vmm_engine.mli +++ b/src/vmm_engine.mli @@ -1,20 +1,20 @@ type 'a t -val init : Vmm_asn.version -> 'a t +val init : Vmm_commands.version -> 'a t type service_out = [ - | `Stat of Vmm_asn.wire - | `Log of Vmm_asn.wire - | `Cons of Vmm_asn.wire + | `Stat of Vmm_commands.wire + | `Log of Vmm_commands.wire + | `Cons of Vmm_commands.wire ] -type out = [ service_out | `Data of Vmm_asn.wire ] +type out = [ service_out | `Data of Vmm_commands.wire ] val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm -> [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * out list -val handle_command : 'a t -> Vmm_asn.wire -> +val handle_command : 'a t -> Vmm_commands.wire -> 'a t * out list * [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result | `End diff --git a/src/vmm_lwt.mli b/src/vmm_lwt.mli index c111b45..f98809b 100644 --- a/src/vmm_lwt.mli +++ b/src/vmm_lwt.mli @@ -1,16 +1,20 @@ val pp_sockaddr : Format.formatter -> Lwt_unix.sockaddr -> unit + val pp_process_status : Format.formatter -> Unix.process_status -> unit -val ret : - Unix.process_status -> [> `Exit of int | `Signal of int | `Stop of int ] + +val ret : Unix.process_status -> Vmm_core.process_exit + val waitpid : int -> (int * Lwt_unix.process_status, unit) result Lwt.t -val wait_and_clear : - int -> - Unix.file_descr -> [> `Exit of int | `Signal of int | `Stop of int ] Lwt.t -val read_wire : - Lwt_unix.file_descr -> - (Vmm_asn.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t + +val wait_and_clear : int -> Unix.file_descr -> Vmm_core.process_exit Lwt.t + +val read_wire : Lwt_unix.file_descr -> + (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t + val write_raw : Lwt_unix.file_descr -> bytes -> (unit, [> `Exception ]) result Lwt.t + val write_wire : - Lwt_unix.file_descr -> Vmm_asn.wire -> (unit, [> `Exception ]) result Lwt.t + Lwt_unix.file_descr -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t + val safe_close : Lwt_unix.file_descr -> unit Lwt.t diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index c5e6967..b72e093 100644 --- a/src/vmm_tls.mli +++ b/src/vmm_tls.mli @@ -1,5 +1,5 @@ -val read_tls : - Tls_lwt.Unix.t -> - (Vmm_asn.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t +val read_tls : Tls_lwt.Unix.t -> + (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t + val write_tls : - Tls_lwt.Unix.t -> Vmm_asn.wire -> (unit, [> `Exception ]) result Lwt.t + Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index 02f8424..7363440 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -5,9 +5,9 @@ open Rresult.R.Infix open Vmm_core -external sysctl_rusage : int -> rusage = "vmmanage_sysctl_rusage" +external sysctl_rusage : int -> Stats.rusage = "vmmanage_sysctl_rusage" external sysctl_ifcount : unit -> int = "vmmanage_sysctl_ifcount" -external sysctl_ifdata : int -> ifdata = "vmmanage_sysctl_ifdata" +external sysctl_ifdata : int -> Stats.ifdata = "vmmanage_sysctl_ifdata" type vmctx @@ -18,8 +18,6 @@ external vmmapi_stats : vmctx -> int64 list = "vmmanage_vmmapi_stats" let my_version = `AV2 -let bcast = ref 0L - let descr = ref [] type 'a t = { @@ -119,8 +117,7 @@ let tick t = match Vmm_core.drop_super ~super:id ~sub:vmid with | None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.pp_id id Vmm_core.pp_id vmid) ; out | Some real_id -> - let header = Vmm_asn.{ version = my_version ; sequence = !bcast ; id = real_id } in - bcast := Int64.succ !bcast ; + let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id = real_id } in ((socket, vmid, (header, `Data (`Stats_data stats))) :: out)) out xs) [] (Vmm_trie.all t'.vmid_pid) @@ -174,13 +171,13 @@ let remove_vmids t vmids = let handle t socket (header, wire) = let r = - if not (Vmm_asn.version_eq my_version header.Vmm_asn.version) then + if not (Vmm_commands.version_eq my_version header.Vmm_commands.version) then Error (`Msg "cannot handle version") else match wire with | `Command (`Stats_cmd cmd) -> begin - let id = header.Vmm_asn.id in + let id = header.Vmm_commands.id in match cmd with | `Stats_add (pid, taps) -> add_pid t id pid taps >>= fun t -> @@ -193,7 +190,7 @@ let handle t socket (header, wire) = Ok ({ t with name_sockets }, `None, close, Some "subscribed") end | _ -> - Logs.warn (fun m -> m "ignoring %a" Vmm_asn.pp_wire (header, wire)) ; + Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, wire)) ; Ok (t, `None, None, None) in match r with From a064c7f58eebd40ba7031cecd096cbf9c999a05c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Oct 2018 00:10:08 +0200 Subject: [PATCH 44/73] move more stuff around --- _tags | 3 +- app/vmm_client.ml | 2 +- app/vmm_tls_endpoint.ml | 6 +- app/vmmd.ml | 10 ++-- src/albatross.mllib | 4 +- src/vmm_tls.ml | 88 +++++++++------------------- src/vmm_tls.mli | 8 +-- src/vmm_tls_lwt.ml | 64 ++++++++++++++++++++ src/vmm_tls_lwt.mli | 5 ++ src/{vmm_engine.ml => vmm_vmmd.ml} | 0 src/{vmm_engine.mli => vmm_vmmd.mli} | 0 src/vmm_x509.ml | 32 ---------- stats/vmm_stats.ml | 4 +- 13 files changed, 115 insertions(+), 111 deletions(-) create mode 100644 src/vmm_tls_lwt.ml create mode 100644 src/vmm_tls_lwt.mli rename src/{vmm_engine.ml => vmm_vmmd.ml} (100%) rename src/{vmm_engine.mli => vmm_vmmd.mli} (100%) delete mode 100644 src/vmm_x509.ml diff --git a/_tags b/_tags index 45dcadd..07bee85 100644 --- a/_tags +++ b/_tags @@ -6,7 +6,8 @@ true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring : package(decompress) : package(asn1-combinators) : package(lwt lwt.unix) -: package(lwt tls.lwt) +: package(lwt tls.lwt) +: package(x509) : package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress) : package(nocrypto tls.lwt nocrypto.lwt) diff --git a/app/vmm_client.ml b/app/vmm_client.ml index f38b58c..1083b08 100644 --- a/app/vmm_client.ml +++ b/app/vmm_client.ml @@ -3,7 +3,7 @@ open Lwt.Infix let rec read_tls_write_cons t = - Vmm_tls.read_tls t >>= function + Vmm_tls_lwt.read_tls t >>= function | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit | Ok wire -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire) ; diff --git a/app/vmm_tls_endpoint.ml b/app/vmm_tls_endpoint.ml index 8c8f8f6..cb1a230 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmm_tls_endpoint.ml @@ -45,7 +45,7 @@ let read fd tls = | Error _ -> Lwt.return (Error (`Msg "exception while reading")) | Ok wire -> Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire wire) ; - Vmm_tls.write_tls tls wire >>= function + Vmm_tls_lwt.write_tls tls wire >>= function | Ok () -> loop () | Error `Exception -> Lwt.return (Error (`Msg "exception")) in @@ -56,13 +56,13 @@ let process fd tls = | Error _ -> Lwt.return (Error (`Msg "read error")) | Ok wire -> Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ; - Vmm_tls.write_tls tls wire >|= function + Vmm_tls_lwt.write_tls tls wire >|= function | Ok () -> Ok () | Error `Exception -> Error (`Msg "exception on write") let handle ca (tls, addr) = client_auth ca tls addr >>= fun chain -> - match Vmm_x509.handle addr chain with + match Vmm_tls.handle addr my_version chain with | Error (`Msg m) -> Lwt.fail_with m | Ok (name, cmd) -> let sock, next = Vmm_commands.endpoint cmd in diff --git a/app/vmmd.ml b/app/vmmd.ml index 5a22172..83e1fba 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -18,7 +18,7 @@ open Lwt.Infix let version = `AV2 -let state = ref (Vmm_engine.init version) +let state = ref (Vmm_vmmd.init version) let create c_fd process cont = Vmm_lwt.read_wire c_fd >>= function @@ -55,13 +55,13 @@ let create c_fd process cont = s := { !s with vm_created = succ !s.vm_created } ; Lwt.async (fun () -> Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> - let state', out' = Vmm_engine.handle_shutdown !state name vm r in + let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in s := { !s with vm_destroyed = succ !s.vm_destroyed } ; state := state' ; process out' >|= fun () -> Lwt.wakeup wakeme ()) ; process out >>= fun () -> - let state', out = Vmm_engine.setup_stats !state name vm in + let state', out = Vmm_vmmd.setup_stats !state name vm in state := state' ; process out (* TODO: need to read from stats socket! *) @@ -83,7 +83,7 @@ let handle out c_fd fd addr = *) let process xs = Lwt_list.iter_p (function - | #Vmm_engine.service_out as o -> out o + | #Vmm_vmmd.service_out as o -> out o | `Data cs -> (* rather: terminate connection *) Vmm_lwt.write_wire fd cs >|= fun _ -> ()) xs @@ -95,7 +95,7 @@ let handle out c_fd fd addr = Lwt.return_unit | Ok wire -> Logs.debug (fun m -> m "read sth") ; - let state', data, next = Vmm_engine.handle_command !state wire in + let state', data, next = Vmm_vmmd.handle_command !state wire in state := state' ; process data >>= fun () -> match next with diff --git a/src/albatross.mllib b/src/albatross.mllib index 5aebb70..42c6b00 100644 --- a/src/albatross.mllib +++ b/src/albatross.mllib @@ -1,10 +1,10 @@ Vmm_asn Vmm_lwt +Vmm_tls_lwt Vmm_tls -Vmm_engine +Vmm_vmmd Vmm_commands Vmm_core -Vmm_engine Vmm_resources Vmm_trie Vmm_unix diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 4bd3daf..a7c41df 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -1,64 +1,30 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) +open Rresult.R.Infix -open Lwt.Infix +open Vmm_core -let read_tls t = - let rec r_n buf off tot = - let l = tot - off in - if l = 0 then - Lwt.return (Ok ()) - else - Lwt.catch (fun () -> - Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function - | 0 -> - Logs.err (fun m -> m "TLS: end of file") ; - Lwt.return (Error `Eof) - | x when x == l -> Lwt.return (Ok ()) - | x when x < l -> r_n buf (off + x) tot - | _ -> - Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ; - Lwt.return (Error `Toomuch)) - (function - | Tls_lwt.Tls_failure a -> - Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ; - Lwt.return (Error `Exception) - | e -> - Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ; - Lwt.return (Error `Exception)) - in - let buf = Cstruct.create 4 in - r_n buf 0 4 >>= function - | Error e -> Lwt.return (Error e) - | Ok () -> - let len = Cstruct.BE.get_uint32 buf 0 in - if len > 0l then - let b = Cstruct.create (Int32.to_int len) in - r_n b 0 (Int32.to_int len) >|= function - | Error e -> Error e - | Ok () -> - (* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a" - hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag - Cstruct.hexdump_pp b) ; *) - match Vmm_asn.wire_of_cstruct b with - | Ok w -> Ok w - | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while parsing data" msg) ; - Error `Exception - else - Lwt.return (Error `Eof) +(* let check_policy = + (* get names and static resources *) + List.fold_left (fun acc ca -> + acc >>= fun acc -> + Vmm_asn.delegation_of_cert asn_version ca >>= fun res -> + let name = id ca in + Ok ((name, res) :: acc)) + (Ok []) chain >>= fun policies -> + (* check static policies *) + Logs.debug (fun m -> m "now checking static policies") ; + check_policies vm_config (List.map snd policies) >>= fun () -> +*) -let write_tls s wire = - let data = Vmm_asn.wire_to_cstruct wire in - let dlen = Cstruct.create 4 in - Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ; - let buf = Cstruct.(append dlen data) in - (* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *) - Lwt.catch - (fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ()) - (function - | Tls_lwt.Tls_failure a -> - Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ; - Lwt.return (Error `Exception) - | e -> - Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ; - Lwt.return (Error `Exception)) +let handle _addr version chain = + separate_chain chain >>= fun (leaf, chain) -> + let prefix = List.map name chain in + let name = prefix @ [ name leaf ] in + 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: inspect top-level-cert of chain. *) + (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) + (* TODO: update policies! *) + Vmm_asn.wire_command_of_cert version leaf >>| fun wire -> + (name, wire) diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index b72e093..8880c37 100644 --- a/src/vmm_tls.mli +++ b/src/vmm_tls.mli @@ -1,5 +1,5 @@ -val read_tls : Tls_lwt.Unix.t -> - (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t -val write_tls : - Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t +val handle : + 'a -> Vmm_commands.version -> + X509.t list -> + (string list * Vmm_commands.t, [> `Msg of string ]) Result.result diff --git a/src/vmm_tls_lwt.ml b/src/vmm_tls_lwt.ml new file mode 100644 index 0000000..4bd3daf --- /dev/null +++ b/src/vmm_tls_lwt.ml @@ -0,0 +1,64 @@ +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix + +let read_tls t = + let rec r_n buf off tot = + let l = tot - off in + if l = 0 then + Lwt.return (Ok ()) + else + Lwt.catch (fun () -> + Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function + | 0 -> + Logs.err (fun m -> m "TLS: end of file") ; + Lwt.return (Error `Eof) + | x when x == l -> Lwt.return (Ok ()) + | x when x < l -> r_n buf (off + x) tot + | _ -> + Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ; + Lwt.return (Error `Toomuch)) + (function + | Tls_lwt.Tls_failure a -> + Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ; + Lwt.return (Error `Exception) + | e -> + Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ; + Lwt.return (Error `Exception)) + in + let buf = Cstruct.create 4 in + r_n buf 0 4 >>= function + | Error e -> Lwt.return (Error e) + | Ok () -> + let len = Cstruct.BE.get_uint32 buf 0 in + if len > 0l then + let b = Cstruct.create (Int32.to_int len) in + r_n b 0 (Int32.to_int len) >|= function + | Error e -> Error e + | Ok () -> + (* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a" + hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag + Cstruct.hexdump_pp b) ; *) + match Vmm_asn.wire_of_cstruct b with + | Ok w -> Ok w + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s while parsing data" msg) ; + Error `Exception + else + Lwt.return (Error `Eof) + +let write_tls s wire = + let data = Vmm_asn.wire_to_cstruct wire in + let dlen = Cstruct.create 4 in + Cstruct.BE.set_uint32 dlen 0 (Int32.of_int (Cstruct.len data)) ; + let buf = Cstruct.(append dlen data) in + (* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *) + Lwt.catch + (fun () -> Tls_lwt.Unix.write s buf >|= fun () -> Ok ()) + (function + | Tls_lwt.Tls_failure a -> + Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ; + Lwt.return (Error `Exception) + | e -> + Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ; + Lwt.return (Error `Exception)) diff --git a/src/vmm_tls_lwt.mli b/src/vmm_tls_lwt.mli new file mode 100644 index 0000000..b72e093 --- /dev/null +++ b/src/vmm_tls_lwt.mli @@ -0,0 +1,5 @@ +val read_tls : Tls_lwt.Unix.t -> + (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t + +val write_tls : + Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t diff --git a/src/vmm_engine.ml b/src/vmm_vmmd.ml similarity index 100% rename from src/vmm_engine.ml rename to src/vmm_vmmd.ml diff --git a/src/vmm_engine.mli b/src/vmm_vmmd.mli similarity index 100% rename from src/vmm_engine.mli rename to src/vmm_vmmd.mli diff --git a/src/vmm_x509.ml b/src/vmm_x509.ml deleted file mode 100644 index 4e3e3d9..0000000 --- a/src/vmm_x509.ml +++ /dev/null @@ -1,32 +0,0 @@ -open Rresult.R.Infix - -open Vmm_core - -let asn_version = `AV2 - -(* let check_policy = - (* get names and static resources *) - List.fold_left (fun acc ca -> - acc >>= fun acc -> - Vmm_asn.delegation_of_cert asn_version ca >>= fun res -> - let name = id ca in - Ok ((name, res) :: acc)) - (Ok []) chain >>= fun policies -> - (* check static policies *) - Logs.debug (fun m -> m "now checking static policies") ; - check_policies vm_config (List.map snd policies) >>= fun () -> -*) - -let handle _addr chain = - separate_chain chain >>= fun (leaf, chain) -> - let prefix = List.map name chain in - let name = prefix @ [ name leaf ] in - 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: inspect top-level-cert of chain. *) - (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) - (* TODO: update policies! *) - Vmm_asn.wire_command_of_cert asn_version leaf >>| fun wire -> - (name, wire) diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index 7363440..bc21c40 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -133,8 +133,8 @@ let add_pid t vmid pid nics = let rec go cnt acc id = if id > 0 && cnt > 0 then match wrap sysctl_ifdata id with - | Some ifd when List.mem ifd.name nics -> - go (pred cnt) ((id, ifd.name) :: acc) (pred id) + | Some ifd when List.mem ifd.Vmm_core.Stats.name nics -> + go (pred cnt) ((id, ifd.Vmm_core.Stats.name) :: acc) (pred id) | _ -> go cnt acc (pred id) else List.rev acc From 89fea934a76655d00f20a8e3ab54de725575f6a1 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Oct 2018 00:13:47 +0200 Subject: [PATCH 45/73] copyright --- src/vmm_asn.ml | 2 +- src/vmm_asn.mli | 2 +- src/vmm_commands.mli | 2 ++ src/vmm_compress.mli | 2 ++ src/vmm_core.mli | 2 ++ src/vmm_lwt.mli | 2 ++ src/vmm_tls.ml | 2 ++ src/vmm_tls.mli | 1 + src/vmm_tls_lwt.mli | 2 ++ src/vmm_trie.ml | 2 ++ src/vmm_trie.mli | 2 ++ src/vmm_vmmd.mli | 1 + 12 files changed, 20 insertions(+), 2 deletions(-) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 1313e91..6c67020 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -1,4 +1,4 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) open Vmm_core open Vmm_commands diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 8fd920d..8dc17e1 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -1,4 +1,4 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) open Vmm_core diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index 430618a..9d6af05 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -1,3 +1,5 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + open Vmm_core (** The type of versions of the grammar defined below. *) diff --git a/src/vmm_compress.mli b/src/vmm_compress.mli index cfceea6..16948cb 100644 --- a/src/vmm_compress.mli +++ b/src/vmm_compress.mli @@ -1,2 +1,4 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + val compress : ?level:int -> string -> string val uncompress : string -> (string, unit) result diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 48c91e5..479c7ef 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -1,3 +1,5 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + val tmpdir : Fpath.t val dbdir : Fpath.t diff --git a/src/vmm_lwt.mli b/src/vmm_lwt.mli index f98809b..ae7445e 100644 --- a/src/vmm_lwt.mli +++ b/src/vmm_lwt.mli @@ -1,3 +1,5 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + val pp_sockaddr : Format.formatter -> Lwt_unix.sockaddr -> unit val pp_process_status : Format.formatter -> Unix.process_status -> unit diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index a7c41df..998cd97 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -1,3 +1,5 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + open Rresult.R.Infix open Vmm_core diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index 8880c37..ebb5e2f 100644 --- a/src/vmm_tls.mli +++ b/src/vmm_tls.mli @@ -1,3 +1,4 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) val handle : 'a -> Vmm_commands.version -> diff --git a/src/vmm_tls_lwt.mli b/src/vmm_tls_lwt.mli index b72e093..39886d6 100644 --- a/src/vmm_tls_lwt.mli +++ b/src/vmm_tls_lwt.mli @@ -1,3 +1,5 @@ +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) + val read_tls : Tls_lwt.Unix.t -> (Vmm_commands.wire, [> `Eof | `Exception | `Toomuch ]) result Lwt.t diff --git a/src/vmm_trie.ml b/src/vmm_trie.ml index ae1559b..9185fb7 100644 --- a/src/vmm_trie.ml +++ b/src/vmm_trie.ml @@ -1,3 +1,5 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + open Astring type 'a t = N of 'a option * 'a t String.Map.t diff --git a/src/vmm_trie.mli b/src/vmm_trie.mli index 2564df1..d0ff91b 100644 --- a/src/vmm_trie.mli +++ b/src/vmm_trie.mli @@ -1,3 +1,5 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + open Vmm_core type 'a t diff --git a/src/vmm_vmmd.mli b/src/vmm_vmmd.mli index 3f4fd2f..867bd3e 100644 --- a/src/vmm_vmmd.mli +++ b/src/vmm_vmmd.mli @@ -1,3 +1,4 @@ +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) type 'a t From 6467b9d54fc83cce50bb4abd98f2e7a409297b13 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Oct 2018 00:14:34 +0200 Subject: [PATCH 46/73] remove unused import --- provision/vmm_sign.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/provision/vmm_sign.ml b/provision/vmm_sign.ml index 26ece81..4ac30d9 100644 --- a/provision/vmm_sign.ml +++ b/provision/vmm_sign.ml @@ -4,8 +4,6 @@ open Vmm_provision open Rresult.R.Infix -open Astring - let sign dbname cacert key csr days = let ri = X509.CA.info csr in Logs.app (fun m -> m "signing certificate with subject %s" From 698ccea4d0f4c55cf7869d8375db31f5c744acf3 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Oct 2018 00:18:29 +0200 Subject: [PATCH 47/73] 4.07 travis --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index b8ac43c..509515a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,5 +9,6 @@ env: matrix: - OCAML_VERSION=4.05 - OCAML_VERSION=4.06 + - OCAML_VERSION=4.07 notifications: email: false From 04367421bf1dc8c4095bb01edc62959ba5a9512d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Oct 2018 01:07:12 +0200 Subject: [PATCH 48/73] since argument for log_subscribe and console_subscribe --- app/vmm_console.ml | 11 ++++++++--- app/vmm_log.ml | 12 ++++++++---- app/vmmc.ml | 24 +++++++++++++++++++----- src/vmm_asn.ml | 14 +++++++------- src/vmm_commands.ml | 12 ++++++++---- src/vmm_commands.mli | 4 ++-- src/vmm_core.ml | 2 +- 7 files changed, 53 insertions(+), 26 deletions(-) diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 1fb787d..7bb03ba 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -80,7 +80,7 @@ let add_fifo id = | None -> Error (`Msg "opening") -let subscribe s id = +let subscribe s id since = let name = Vmm_core.string_of_id id in Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ; match String.Map.find name !t with @@ -88,7 +88,11 @@ let subscribe s id = active := String.Map.add name s !active ; Lwt.return (Ok "waiing for VM") | Some r -> - let entries = Vmm_ring.read r in + let entries = + match since with + | None -> Vmm_ring.read r + | Some ts -> Vmm_ring.read_history r ts + in Logs.debug (fun m -> m "found %d history" (List.length entries)) ; Lwt_list.iter_s (fun (i, v) -> let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in @@ -114,7 +118,8 @@ let handle s addr () = else match cmd with | `Console_add -> add_fifo header.Vmm_commands.id - | `Console_subscribe -> subscribe s header.Vmm_commands.id) >>= (function + | `Console_subscribe ts -> subscribe s header.Vmm_commands.id ts) + >>= (function | Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg)) | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; diff --git a/app/vmm_log.ml b/app/vmm_log.ml index bc6bc73..5578e2e 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -55,8 +55,12 @@ let write_to_file file = let tree = ref Vmm_trie.empty -let send_history s ring id = - let elements = Vmm_ring.read ring in +let send_history s ring id ts = + let elements = + match ts with + | None -> Vmm_ring.read ring + | Some since -> Vmm_ring.read_history ring since + in let res = List.fold_left (fun acc (_, x) -> let cs = Cstruct.of_string x in @@ -112,7 +116,7 @@ let handle mvar ring s addr () = Lwt.return_unit end else begin match lc with - | `Log_subscribe -> + | `Log_subscribe ts -> let tree', ret = Vmm_trie.insert hdr.Vmm_commands.id s !tree in tree := tree' ; (match ret with @@ -124,7 +128,7 @@ let handle mvar ring s addr () = Logs.err (fun m -> m "error while sending reply for subscribe") ; Lwt.return_unit | Ok () -> - send_history s ring hdr.Vmm_commands.id >>= function + send_history s ring hdr.Vmm_commands.id ts >>= function | Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit diff --git a/app/vmmc.ml b/app/vmmc.ml index 5904d32..d0d2889 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -103,11 +103,14 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc in jump opt_socket name (`Vm_cmd cmd) -let console _ opt_socket name = jump opt_socket name (`Console_cmd `Console_subscribe) +let console _ opt_socket name since = + jump opt_socket name (`Console_cmd (`Console_subscribe since)) -let stats _ opt_socket name = jump opt_socket name (`Stats_cmd `Stats_subscribe) +let stats _ opt_socket name = + jump opt_socket name (`Stats_cmd `Stats_subscribe) -let event_log _ opt_socket name = jump opt_socket name (`Log_cmd `Log_subscribe) +let event_log _ opt_socket name since = + jump opt_socket name (`Log_cmd (`Log_subscribe since)) let help _ _ man_format cmds = function | None -> `Help (`Pager, None) @@ -265,13 +268,24 @@ let create_cmd = Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), Term.info "create" ~doc ~man +let timestamp_c = + let parse s = match Ptime.of_rfc3339 s with + | Ok (t, _, _) -> `Ok t + | Error _ -> `Error "couldn't parse timestamp" + in + (parse, Ptime.pp_rfc3339 ()) + +let since = + let doc = "Since" in + Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc) + let console_cmd = let doc = "console of a VM" in let man = [`S "DESCRIPTION"; `P "Shows console output of a VM."] in - Term.(ret (const console $ setup_log $ socket $ vm_name)), + Term.(ret (const console $ setup_log $ socket $ vm_name $ since)), Term.info "console" ~doc ~man let stats_cmd = @@ -289,7 +303,7 @@ let log_cmd = [`S "DESCRIPTION"; `P "Shows event log of VM."] in - Term.(ret (const event_log $ setup_log $ socket $ opt_vmname)), + Term.(ret (const event_log $ setup_log $ socket $ opt_vmname $ since)), Term.info "log" ~doc ~man let help_cmd = diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 6c67020..c1f6ec2 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -90,15 +90,15 @@ let image = let console_cmd = let f = function | `C1 () -> `Console_add - | `C2 () -> `Console_subscribe + | `C2 ts -> `Console_subscribe ts and g = function | `Console_add -> `C1 () - | `Console_subscribe -> `C2 () + | `Console_subscribe ts -> `C2 ts in Asn.S.map f g @@ Asn.S.(choice2 (explicit 0 null) - (explicit 1 null)) + (explicit 1 (sequence (single (optional ~label:"since" utc_time))))) (* TODO is this good? *) let int64 = @@ -246,12 +246,12 @@ let log_event = let log_cmd = let f = function - | () -> `Log_subscribe + | ts -> `Log_subscribe ts and g = function - | `Log_subscribe -> () + | `Log_subscribe ts -> ts in Asn.S.map f g @@ - Asn.S.null + Asn.S.(sequence (single (optional ~label:"since" utc_time))) let vm_config = let f (cpuid, requested_memory, block_device, network, vmimage, argv) = @@ -426,7 +426,7 @@ let wire = (explicit 2 utf8_string) (explicit 3 data)))) -let wire_of_cstruct, (wire_to_cstruct : Vmm_commands.wire -> Cstruct.t) = projections_of wire +let wire_of_cstruct, wire_to_cstruct = projections_of wire let log_entry = Asn.S.(sequence2 diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index 03b486f..533c607 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -21,12 +21,14 @@ let version_eq a b = type console_cmd = [ | `Console_add - | `Console_subscribe + | `Console_subscribe of Ptime.t option ] let pp_console_cmd ppf = function | `Console_add -> Fmt.string ppf "console add" - | `Console_subscribe -> Fmt.string ppf "console subscribe" + | `Console_subscribe ts -> + Fmt.pf ppf "console subscribe since %a" + Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts type stats_cmd = [ | `Stats_add of int * string list @@ -40,11 +42,13 @@ let pp_stats_cmd ppf = function | `Stats_subscribe -> Fmt.string ppf "stat subscribe" type log_cmd = [ - | `Log_subscribe + | `Log_subscribe of Ptime.t option ] let pp_log_cmd ppf = function - | `Log_subscribe -> Fmt.string ppf "log subscribe" + | `Log_subscribe ts -> + Fmt.pf ppf "log subscribe since %a" + Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts type vm_cmd = [ | `Vm_info diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index 9d6af05..175e8d0 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -13,7 +13,7 @@ val pp_version : version Fmt.t type console_cmd = [ | `Console_add - | `Console_subscribe + | `Console_subscribe of Ptime.t option ] type stats_cmd = [ @@ -23,7 +23,7 @@ type stats_cmd = [ ] type log_cmd = [ - | `Log_subscribe + | `Log_subscribe of Ptime.t option ] type vm_cmd = [ diff --git a/src/vmm_core.ml b/src/vmm_core.ml index c43a348..f04437f 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -214,7 +214,7 @@ module Stats = struct type vmm = (string * int64) list let pp_vmm ppf vmm = - Fmt.(list ~sep:(unit "@,") (pair ~sep:(unit ": ") string int64)) ppf vmm + Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) ppf vmm type ifdata = { name : string ; From cdae37b0bf2833af514f865f6b1e0953a9b428a3 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 24 Oct 2018 01:10:35 +0200 Subject: [PATCH 49/73] interface for vmm_ring --- src/albatross.mllib | 3 ++- src/vmm_ring.mli | 9 +++++++++ 2 files changed, 11 insertions(+), 1 deletion(-) create mode 100644 src/vmm_ring.mli diff --git a/src/albatross.mllib b/src/albatross.mllib index 42c6b00..54e58a8 100644 --- a/src/albatross.mllib +++ b/src/albatross.mllib @@ -8,4 +8,5 @@ Vmm_core Vmm_resources Vmm_trie Vmm_unix -Vmm_compress \ No newline at end of file +Vmm_compress +Vmm_ring diff --git a/src/vmm_ring.mli b/src/vmm_ring.mli new file mode 100644 index 0000000..14dc7ec --- /dev/null +++ b/src/vmm_ring.mli @@ -0,0 +1,9 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + +type t + +val create : ?size:int -> unit -> t + +val write : t -> Ptime.t * string -> unit +val read : t -> (Ptime.t * string) list +val read_history : t -> Ptime.t -> (Ptime.t * string) list From b55281d1e57fd5128d41177fa97ade9eb7cccecc Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 25 Oct 2018 00:42:52 +0200 Subject: [PATCH 50/73] include version in log_entries on disk, read log file on startup (and write events to ring store) --- app/vmm_log.ml | 54 ++++++++++++++++++++++++++++++++++--------------- src/vmm_asn.ml | 27 +++++++++++++++++++++++++ src/vmm_asn.mli | 4 ++++ 3 files changed, 69 insertions(+), 16 deletions(-) diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 5578e2e..8667225 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -12,6 +12,9 @@ open Lwt.Infix let my_version = `AV2 +let entry_to_ring (ts, event) = + (ts, Cstruct.to_string (Vmm_asn.log_entry_to_cstruct (ts, event))) + let broadcast prefix data t = Lwt_list.fold_left_s (fun t (id, s) -> Vmm_lwt.write_wire s data >|= function @@ -29,27 +32,45 @@ let write_complete s cs = in w 0 +let read_from_file file = + Lwt_unix.stat file >>= fun stat -> + let size = stat.Lwt_unix.st_size in + Lwt_unix.openfile file Lwt_unix.[O_RDONLY] 0 >>= fun fd -> + let buf = Bytes.create size in + let rec read off = + Lwt_unix.read fd buf off (size - off) >>= fun bytes -> + if bytes + off = size then + Lwt.return_unit + else + read (bytes + off) + in + read 0 >>= fun () -> + let logs = Vmm_asn.logs_of_disk my_version (Cstruct.of_bytes buf) in + Vmm_lwt.safe_close fd >|= fun () -> + List.rev logs + let write_to_file file = let mvar = Lwt_mvar.create_empty () in - let rec write_loop ?(retry = true) ?data ?fd () = + let rec write_loop ?(retry = true) ?log_entry ?fd () = match fd with | None when retry -> Lwt_unix.openfile file Lwt_unix.[O_APPEND;O_CREAT;O_WRONLY] 0o600 >>= fun fd -> - write_loop ~retry:false ?data ~fd () + write_loop ~retry:false ?log_entry ~fd () | None -> Logs.err (fun m -> m "retry is false, exiting") ; Lwt.return_unit | Some fd -> - (match data with + (match log_entry with | None -> Lwt_mvar.take mvar - | Some d -> Lwt.return d) >>= fun data -> + | Some l -> Lwt.return l) >>= fun log_entry -> + let data = Vmm_asn.log_to_disk my_version log_entry in Lwt.catch (fun () -> write_complete fd data >|= fun () -> (true, None, Some fd)) (fun e -> Logs.err (fun m -> m "exception %s while writing" (Printexc.to_string e)) ; Vmm_lwt.safe_close fd >|= fun () -> - (retry, Some data, None)) >>= fun (retry, data, fd) -> - write_loop ~retry ?data ?fd () + (retry, Some log_entry, None)) >>= fun (retry, log_entry, fd) -> + write_loop ~retry ?log_entry ?fd () in mvar, write_loop @@ -63,8 +84,7 @@ let send_history s ring id ts = in let res = List.fold_left (fun acc (_, x) -> - let cs = Cstruct.of_string x in - match Vmm_asn.log_entry_of_cstruct cs with + match Vmm_asn.log_entry_of_cstruct (Cstruct.of_string x) with | Ok (ts, event) -> let sub = Vmm_core.Log.name event in if Vmm_core.is_sub_id ~super:id ~sub @@ -80,12 +100,10 @@ let send_history s ring id ts = let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event))) | Error e -> Lwt.return (Error e)) - (Ok ()) res + (Ok ()) (List.rev res) let handle mvar ring s addr () = Logs.info (fun m -> m "handling connection from %a" Vmm_lwt.pp_sockaddr addr) ; - let str = Fmt.strf "%a: CONNECT\n" (Ptime.pp_human ()) (Ptime_clock.now ()) in - Lwt_mvar.put mvar (Cstruct.of_string str) >>= fun () -> let rec loop () = Vmm_lwt.read_wire s >>= function | Error (`Msg e) -> @@ -94,17 +112,16 @@ let handle mvar ring s addr () = | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit - | Ok (hdr, `Data (`Log_data (ts, event))) -> + | Ok (hdr, `Data (`Log_data entry)) -> if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin Logs.warn (fun m -> m "unsupported version") ; Lwt.return_unit end else begin - let data = Vmm_asn.log_entry_to_cstruct (ts, event) in - Vmm_ring.write ring (ts, Cstruct.to_string data) ; - Lwt_mvar.put mvar data >>= fun () -> + Vmm_ring.write ring (entry_to_ring entry) ; + Lwt_mvar.put mvar entry >>= fun () -> let data' = let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id = hdr.Vmm_commands.id } in - (header, `Data (`Log_data (ts, event))) + (header, `Data (`Log_data entry)) in broadcast hdr.Vmm_commands.id data' !tree >>= fun tree' -> tree := tree' ; @@ -152,7 +169,12 @@ let jump _ file sock = Lwt_unix.(bind s (ADDR_UNIX sock)) >>= fun () -> Lwt_unix.listen s 1 ; let ring = Vmm_ring.create () in + read_from_file file >>= fun entries -> + List.iter (Vmm_ring.write ring) (List.map entry_to_ring entries) ; let mvar, writer = write_to_file file in + let start = Ptime_clock.now (), `Startup in + Lwt_mvar.put mvar start >>= fun () -> + Vmm_ring.write ring (entry_to_ring start) ; let rec loop () = Lwt_unix.accept s >>= fun (cs, addr) -> Lwt.async (handle mvar ring cs addr) ; diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index c1f6ec2..cde00f6 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -435,6 +435,33 @@ let log_entry = let log_entry_of_cstruct, log_entry_to_cstruct = projections_of log_entry +let log_disk = + Asn.S.(sequence2 + (required ~label:"version" version) + (required ~label:"entry" log_entry)) + +let log_disk_of_cstruct, log_disk_to_cstruct = projections_of log_disk + +let log_to_disk version entry = + log_disk_to_cstruct (version, entry) + +let logs_of_disk version buf = + let rec next acc buf = + match Asn.decode (Asn.codec Asn.der log_disk) buf with + | Ok ((version', entry), cs) -> + let acc' = + if Vmm_commands.version_eq version version' then + entry :: acc + else + acc + in + next acc' cs + | Error (`Parse msg) -> + Logs.warn (fun m -> m "parse error %s while parsing log" msg) ; + acc (* ignore *) + in + next [] buf + type cert_extension = version * t let cert_extension = diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 8dc17e1..6310794 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -17,6 +17,10 @@ val log_entry_to_cstruct : Log.t -> Cstruct.t val log_entry_of_cstruct : Cstruct.t -> (Log.t, [> `Msg of string ]) result +val log_to_disk : Vmm_commands.version -> Log.t -> Cstruct.t + +val logs_of_disk : Vmm_commands.version -> Cstruct.t -> Log.t list + type cert_extension = Vmm_commands.version * Vmm_commands.t val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result From 992e1b0a2bf52074fdfd228b4f336ed04781c69d Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 25 Oct 2018 16:02:04 +0200 Subject: [PATCH 51/73] - Vmm_ring is now polymorph (alows to store log_entry :D) - Vmm_console/log/stats do not read multiple times console_add loops console_subscribe terminates (a stream of messages is sent) log data stream loops log_subscribe terminates (a stream of data is sent) stat_add loops stat_remove loops stat_subscribe terminates (a stream of stats is sent) terminates means: reads once more, and closes socket after second read returned loop processes further incoming data --- app/vmm_console.ml | 87 ++++++++++++++++++++++---------------- app/vmm_log.ml | 95 ++++++++++++++++++++++-------------------- src/vmm_ring.ml | 12 +++--- src/vmm_ring.mli | 10 ++--- stats/vmm_stats.ml | 57 +++++++++++-------------- stats/vmm_stats_lwt.ml | 44 +++++++++++-------- 6 files changed, 163 insertions(+), 142 deletions(-) diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 7bb03ba..16ac1ea 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -71,38 +71,42 @@ let add_fifo id = let name = Vmm_core.string_of_id id in open_fifo name >|= function | Some f -> - let ring = Vmm_ring.create () in - Logs.debug (fun m -> m "inserting %s" name) ; + let ring = Vmm_ring.create "" () in + Logs.debug (fun m -> m "inserting fifo %s" name) ; let map = String.Map.add name ring !t in t := map ; Lwt.async (read_console name ring f) ; - Ok "reading" + Ok () | None -> Error (`Msg "opening") -let subscribe s id since = +let subscribe s id = let name = Vmm_core.string_of_id id in - Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ; + Logs.debug (fun m -> m "attempting to subscribe %a" Vmm_core.pp_id id) ; match String.Map.find name !t with | None -> active := String.Map.add name s !active ; - Lwt.return (Ok "waiing for VM") + Lwt.return (None, "waiting for VM") | Some r -> - let entries = - match since with - | None -> Vmm_ring.read r - | Some ts -> Vmm_ring.read_history r ts - in - Logs.debug (fun m -> m "found %d history" (List.length entries)) ; - Lwt_list.iter_s (fun (i, v) -> - let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in - Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >|= fun _ -> ()) - entries >>= fun () -> (match String.Map.find name !active with | None -> Lwt.return_unit | Some s -> Vmm_lwt.safe_close s) >|= fun () -> active := String.Map.add name s !active ; - Ok "attached" + (Some r, "subscribed") + +let send_history s r id since = + let entries = + match since with + | None -> Vmm_ring.read r + | Some ts -> Vmm_ring.read_history r ts + in + Logs.debug (fun m -> m "%a found %d history" Vmm_core.pp_id id (List.length entries)) ; + Lwt_list.iter_s (fun (i, v) -> + let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in + Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >>= function + | Ok () -> Lwt.return_unit + | Error _ -> Vmm_lwt.safe_close s) + entries let handle s addr () = Logs.info (fun m -> m "handling connection %a" Vmm_lwt.pp_sockaddr addr) ; @@ -112,26 +116,39 @@ let handle s addr () = Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit | Ok (header, `Command (`Console_cmd cmd)) -> - begin - (if not (Vmm_commands.version_eq header.Vmm_commands.version my_version) then - Lwt.return (Error (`Msg "ignoring data with bad version")) - else - match cmd with - | `Console_add -> add_fifo header.Vmm_commands.id - | `Console_subscribe ts -> subscribe s header.Vmm_commands.id ts) - >>= (function - | Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg)) - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while processing command: %s" msg) ; - Vmm_lwt.write_wire s (header, `Failure msg)) >>= function - | Ok () -> loop () - | Error _ -> - Logs.err (fun m -> m "exception while writing to socket") ; - Lwt.return_unit + if not (Vmm_commands.version_eq header.Vmm_commands.version my_version) then begin + Logs.err (fun m -> m "ignoring data with bad version") ; + Lwt.return_unit + end else begin + let name = header.Vmm_commands.id in + match cmd with + | `Console_add -> + begin + add_fifo name >>= fun res -> + let reply = match res with + | Ok () -> `Success `Empty + | Error (`Msg msg) -> `Failure msg + in + Vmm_lwt.write_wire s (header, reply) >>= function + | Ok () -> loop () + | Error _ -> + Logs.err (fun m -> m "error while writing") ; + Lwt.return_unit + end + | `Console_subscribe ts -> + subscribe s name >>= fun (ring, res) -> + Vmm_lwt.write_wire s (header, `Success (`String res)) >>= function + | Error _ -> Vmm_lwt.safe_close s + | Ok () -> + (match ring with + | None -> Lwt.return_unit + | Some r -> send_history s r name ts) >>= fun () -> + (* now we wait for the next read and terminate*) + Vmm_lwt.read_wire s >|= fun _ -> () end | Ok wire -> - Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ; - loop () + Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire wire) ; + Lwt.return () in loop () >>= fun () -> Vmm_lwt.safe_close s >|= fun () -> diff --git a/app/vmm_log.ml b/app/vmm_log.ml index 8667225..6bac67f 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -12,12 +12,9 @@ open Lwt.Infix let my_version = `AV2 -let entry_to_ring (ts, event) = - (ts, Cstruct.to_string (Vmm_asn.log_entry_to_cstruct (ts, event))) - -let broadcast prefix data t = +let broadcast prefix wire t = Lwt_list.fold_left_s (fun t (id, s) -> - Vmm_lwt.write_wire s data >|= function + Vmm_lwt.write_wire s wire >|= function | Ok () -> t | Error `Exception -> Vmm_trie.remove id t) t (Vmm_trie.collect prefix t) @@ -83,14 +80,11 @@ let send_history s ring id ts = | Some since -> Vmm_ring.read_history ring since in let res = - List.fold_left (fun acc (_, x) -> - match Vmm_asn.log_entry_of_cstruct (Cstruct.of_string x) with - | Ok (ts, event) -> - let sub = Vmm_core.Log.name event in - if Vmm_core.is_sub_id ~super:id ~sub - then (ts, event) :: acc - else acc - | _ -> acc) + List.fold_left (fun acc (ts, event) -> + let sub = Vmm_core.Log.name event in + if Vmm_core.is_sub_id ~super:id ~sub + then (ts, event) :: acc + else acc) [] elements in (* just need a wrapper in tag = Log.Data, id = reqid *) @@ -102,31 +96,42 @@ let send_history s ring id ts = | Error e -> Lwt.return (Error e)) (Ok ()) (List.rev res) -let handle mvar ring s addr () = - Logs.info (fun m -> m "handling connection from %a" Vmm_lwt.pp_sockaddr addr) ; +let handle_data mvar ring hdr entry = + if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin + Logs.warn (fun m -> m "unsupported version") ; + Lwt.return_unit + end else begin + Vmm_ring.write ring entry ; + Lwt_mvar.put mvar entry >>= fun () -> + let data' = (hdr, `Data (`Log_data entry)) in + broadcast hdr.Vmm_commands.id data' !tree >|= fun tree' -> + tree := tree' + end + +let read_data mvar ring s = let rec loop () = Vmm_lwt.read_wire s >>= function - | Error (`Msg e) -> - Logs.err (fun m -> m "error while reading %s" e) ; - loop () | Error _ -> - Logs.err (fun m -> m "exception while reading") ; + Logs.err (fun m -> m "error while reading") ; Lwt.return_unit | Ok (hdr, `Data (`Log_data entry)) -> - if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin - Logs.warn (fun m -> m "unsupported version") ; - Lwt.return_unit - end else begin - Vmm_ring.write ring (entry_to_ring entry) ; - Lwt_mvar.put mvar entry >>= fun () -> - let data' = - let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id = hdr.Vmm_commands.id } in - (header, `Data (`Log_data entry)) - in - broadcast hdr.Vmm_commands.id data' !tree >>= fun tree' -> - tree := tree' ; - loop () - end + handle_data mvar ring hdr entry >>= fun () -> + loop () + | Ok wire -> + Logs.warn (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire wire) ; + Lwt.return_unit + in + loop () + +let handle mvar ring s addr () = + Logs.info (fun m -> m "handling connection from %a" Vmm_lwt.pp_sockaddr addr) ; + Vmm_lwt.read_wire s >>= begin function + | Error _ -> + Logs.err (fun m -> m "error while reading") ; + Lwt.return_unit + | Ok (hdr, `Data (`Log_data entry)) -> + handle_data mvar ring hdr entry >>= fun () -> + read_data mvar ring s | Ok (hdr, `Command (`Log_cmd lc)) -> if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin Logs.warn (fun m -> m "unsupported version") ; @@ -141,23 +146,21 @@ let handle mvar ring s addr () = | Some s' -> Vmm_lwt.safe_close s') >>= fun () -> let out = `Success `Empty in Vmm_lwt.write_wire s (hdr, out) >>= function - | Error _ -> - Logs.err (fun m -> m "error while sending reply for subscribe") ; + | Error _ -> Logs.err (fun m -> m "error while sending reply for subscribe") ; Lwt.return_unit | Ok () -> send_history s ring hdr.Vmm_commands.id ts >>= function - | Error _ -> - Logs.err (fun m -> m "error while sending history") ; - Lwt.return_unit - | Ok () -> loop () (* TODO no need to loop ;) *) + | Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit + | Ok () -> + (* command processing is finished, but we leave the socket open + until read returns (either with a message we ignore or a failure from the closed connection) *) + Vmm_lwt.read_wire s >|= fun _ -> () end | Ok wire -> Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ; - loop () - in - loop () >>= fun () -> + Lwt.return_unit + end >>= fun () -> Vmm_lwt.safe_close s - (* should remove all the s from the tree above *) let jump _ file sock = Sys.(set_signal sigpipe Signal_ignore) ; @@ -168,13 +171,13 @@ let jump _ file sock = let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in Lwt_unix.(bind s (ADDR_UNIX sock)) >>= fun () -> Lwt_unix.listen s 1 ; - let ring = Vmm_ring.create () in + let ring = Vmm_ring.create `Startup () in read_from_file file >>= fun entries -> - List.iter (Vmm_ring.write ring) (List.map entry_to_ring entries) ; + List.iter (Vmm_ring.write ring) entries ; let mvar, writer = write_to_file file in let start = Ptime_clock.now (), `Startup in Lwt_mvar.put mvar start >>= fun () -> - Vmm_ring.write ring (entry_to_ring start) ; + Vmm_ring.write ring start ; let rec loop () = Lwt_unix.accept s >>= fun (cs, addr) -> Lwt.async (handle mvar ring cs addr) ; diff --git a/src/vmm_ring.ml b/src/vmm_ring.ml index f49d6e7..f780e29 100644 --- a/src/vmm_ring.ml +++ b/src/vmm_ring.ml @@ -2,19 +2,19 @@ (* a ring buffer with N strings, dropping old ones *) -type t = { - data : (Ptime.t * string) array ; +type 'a t = { + data : (Ptime.t * 'a) array ; mutable write : int ; size : int ; } -let create ?(size = 1024) () = - { data = Array.make 1024 (Ptime.min, "") ; write = 0 ; size } +let create ?(size = 1024) neutral () = + { data = Array.make 1024 (Ptime.min, neutral) ; write = 0 ; size } let inc t = (succ t.write) mod t.size -let write t v = - Array.set t.data t.write v ; +let write t entry = + Array.set t.data t.write entry ; t.write <- inc t let dec t n = (pred n + t.size) mod t.size diff --git a/src/vmm_ring.mli b/src/vmm_ring.mli index 14dc7ec..4bb8673 100644 --- a/src/vmm_ring.mli +++ b/src/vmm_ring.mli @@ -1,9 +1,9 @@ (* (c) 2018 Hannes Mehnert, all rights reserved *) -type t +type 'a t -val create : ?size:int -> unit -> t +val create : ?size:int -> 'a -> unit -> 'a t -val write : t -> Ptime.t * string -> unit -val read : t -> (Ptime.t * string) list -val read_history : t -> Ptime.t -> (Ptime.t * string) list +val write : 'a t -> Ptime.t * 'a -> unit +val read : 'a t -> (Ptime.t * 'a) list +val read_history : 'a t -> Ptime.t -> (Ptime.t * 'a) list diff --git a/stats/vmm_stats.ml b/stats/vmm_stats.ml index bc21c40..e3fccf5 100644 --- a/stats/vmm_stats.ml +++ b/stats/vmm_stats.ml @@ -170,36 +170,27 @@ let remove_vmids t vmids = List.fold_left remove_vmid t vmids let handle t socket (header, wire) = - let r = - if not (Vmm_commands.version_eq my_version header.Vmm_commands.version) then - Error (`Msg "cannot handle version") - else - match wire with - | `Command (`Stats_cmd cmd) -> - begin - let id = header.Vmm_commands.id in - match cmd with - | `Stats_add (pid, taps) -> - add_pid t id pid taps >>= fun t -> - Ok (t, `Add id, None, Some "added") - | `Stats_remove -> - let t = remove_vmid t id in - Ok (t, `Remove id, None, Some "removed") - | `Stats_subscribe -> - let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in - Ok ({ t with name_sockets }, `None, close, Some "subscribed") - end - | _ -> - Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, wire)) ; - Ok (t, `None, None, None) - in - match r with - | Ok (t, action, close, out) -> - let out = match out with - | None -> None - | Some str -> Some (header, `Success (`String str)) - in - t, action, close, out - | Error (`Msg msg) -> - Logs.err (fun m -> m "error while processing %s" msg) ; - t, `None, None, Some (header, `Failure msg) + if not (Vmm_commands.version_eq my_version header.Vmm_commands.version) then begin + Logs.err (fun m -> m "invalid version %a (mine is %a)" + Vmm_commands.pp_version header.Vmm_commands.version + Vmm_commands.pp_version my_version) ; + Error (`Msg "cannot handle version") + end else + match wire with + | `Command (`Stats_cmd cmd) -> + begin + let id = header.Vmm_commands.id in + match cmd with + | `Stats_add (pid, taps) -> + add_pid t id pid taps >>= fun t -> + Ok (t, `Add id, "added") + | `Stats_remove -> + let t = remove_vmid t id in + Ok (t, `Remove id, "removed") + | `Stats_subscribe -> + let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in + Ok ({ t with name_sockets }, `Close close, "subscribed") + end + | _ -> + Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire (header, wire)) ; + Error (`Msg "unexpected command") diff --git a/stats/vmm_stats_lwt.ml b/stats/vmm_stats_lwt.ml index 532bb11..0763592 100644 --- a/stats/vmm_stats_lwt.ml +++ b/stats/vmm_stats_lwt.ml @@ -23,25 +23,35 @@ let pp_sockaddr ppf = function let handle s addr () = Logs.info (fun m -> m "handling stats connection %a" pp_sockaddr addr) ; - let rec loop acc = + let rec loop pids = Vmm_lwt.read_wire s >>= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error while reading %s" msg) ; loop acc - | Error _ -> Logs.err (fun m -> m "exception while reading") ; Lwt.return acc + | Error _ -> + Logs.err (fun m -> m "exception while reading") ; + Lwt.return pids | Ok wire -> - let t', action, close, out = Vmm_stats.handle !t s wire in - let acc = match action with - | `Add pid -> pid :: acc - | `Remove pid -> List.filter (fun m -> m <> pid) acc - | `None -> acc - in - t := t' ; - (match close with None -> Lwt.return_unit | Some s' -> Vmm_lwt.safe_close s') >>= fun () -> - match out with - | None -> loop acc - | Some out -> - Vmm_lwt.write_wire s out >>= function - | Ok () -> loop acc - | Error _ -> Logs.err (fun m -> m "exception while writing") ; Lwt.return acc + match Vmm_stats.handle !t s wire with + | Error (`Msg msg) -> + Vmm_lwt.write_wire s (fst wire, `Failure msg) >>= fun _ -> + Lwt.return pids + | Ok (t', action, out) -> + t := t' ; + let pids = match action with + | `Add pid -> pid :: pids + | `Remove pid -> List.filter (fun m -> m <> pid) pids + | `Close _ -> pids + in + t := t' ; + Vmm_lwt.write_wire s (fst wire, `Success (`String out)) >>= function + | Ok () -> + (match action with + | `Close (Some s') -> + Vmm_lwt.safe_close s' >>= fun () -> + (* read the next *) + Vmm_lwt.read_wire s >|= fun _ -> pids + | _ -> loop pids) + | Error _ -> + Logs.err (fun m -> m "error while writing") ; + Lwt.return pids in loop [] >>= fun vmids -> Vmm_lwt.safe_close s >|= fun () -> From 85a507db544a25fcbe04829b65e2048fbd1322f7 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 25 Oct 2018 16:27:56 +0200 Subject: [PATCH 52/73] whitelist commands accepted via tls certificate --- src/vmm_tls.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 998cd97..06df530 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -27,6 +27,13 @@ let handle _addr version chain = (List.map X509.common_name_to_string chain)) ; (* TODO: inspect top-level-cert of chain. *) (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) - (* TODO: update policies! *) - Vmm_asn.wire_command_of_cert version leaf >>| fun wire -> - (name, wire) + (* TODO: update policies (parse chain for policy, and apply them)! *) + Vmm_asn.wire_command_of_cert version leaf >>= fun wire -> + (* we only allow some commands via certificate *) + match wire with + | `Console_cmd (`Console_subscribe _) + | `Stats_cmd `Stats_subscribe + | `Log_cmd (`Log_subscribe _) + | `Vm_cmd _ + | `Policy_cmd _ -> Ok (name, wire) (* TODO policy_cmd is special (via delegation chain) *) + | _ -> Error (`Msg "unexpected command") From 01f933702d75f07dd2735feb4b7892bb693e1852 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 25 Oct 2018 16:55:54 +0200 Subject: [PATCH 53/73] move stuff around --- README.md | 19 ++++- _tags | 24 +++--- {provision => app}/vmm_provision.ml | 0 stats/vmm_stats.ml => app/vmm_stats_pure.ml | 0 {stats => app}/vmm_stats_stubs.c | 0 app/vmmc_bistro.ml | 0 app/{vmmc.ml => vmmc_local.ml} | 2 +- app/{vmm_client.ml => vmmc_remote.ml} | 8 +- app/{vmm_console.ml => vmmd_console.ml} | 2 +- app/{vmm_influxdb_stats.ml => vmmd_influx.ml} | 2 +- app/{vmm_log.ml => vmmd_log.ml} | 0 stats/vmm_stats_lwt.ml => app/vmmd_stats.ml | 14 ++-- app/{vmm_tls_endpoint.ml => vmmd_tls.ml} | 2 +- .../vmmp_request.ml | 75 ++++++++++++++++++- provision/vmm_sign.ml => app/vmmp_sign.ml | 52 ++++++++++++- myocamlbuild.ml | 6 +- opam | 11 +-- packaging/create_package.sh | 10 +-- packaging/rc.d/albatross_console | 2 +- packaging/rc.d/albatross_log | 2 +- packaging/rc.d/albatross_stat | 2 +- pkg/META | 5 -- pkg/pkg.ml | 23 +++--- provision/vmm_gen_ca.ml | 50 ------------- provision/vmm_req_vm.ml | 73 ------------------ src/albatross.mllib | 12 --- src/vmm_asn.ml | 16 +--- src/vmm_asn.mli | 3 - src/vmm_core.ml | 10 --- src/vmm_core.mli | 4 - src/vmm_tls.ml | 25 ++++++- src/vmm_tls.mli | 3 + stats/libvmm_stats_stubs.clib | 1 - 33 files changed, 231 insertions(+), 227 deletions(-) rename {provision => app}/vmm_provision.ml (100%) rename stats/vmm_stats.ml => app/vmm_stats_pure.ml (100%) rename {stats => app}/vmm_stats_stubs.c (100%) create mode 100644 app/vmmc_bistro.ml rename app/{vmmc.ml => vmmc_local.ml} (99%) rename app/{vmm_client.ml => vmmc_remote.ml} (89%) rename app/{vmm_console.ml => vmmd_console.ml} (99%) rename app/{vmm_influxdb_stats.ml => vmmd_influx.ml} (99%) rename app/{vmm_log.ml => vmmd_log.ml} (100%) rename stats/vmm_stats_lwt.ml => app/vmmd_stats.ml (93%) rename app/{vmm_tls_endpoint.ml => vmmd_tls.ml} (99%) rename provision/vmm_req_delegation.ml => app/vmmp_request.ml (52%) rename provision/vmm_sign.ml => app/vmmp_sign.ml (62%) delete mode 100644 provision/vmm_gen_ca.ml delete mode 100644 provision/vmm_req_vm.ml delete mode 100644 src/albatross.mllib delete mode 100644 stats/libvmm_stats_stubs.clib diff --git a/README.md b/README.md index 9c7b89d..47b41ab 100644 --- a/README.md +++ b/README.md @@ -1,9 +1,22 @@ -# Albatross: Managing virtual machines +# Albatross: orchestrate and manage MirageOS unikernels [![Build Status](https://travis-ci.org/hannesm/albatross.svg?branch=master)](https://travis-ci.org/hannesm/albatross) -A set of binaries to manage, provision, and deploy virtual machine images. This -is very much work in progress, don't expect anything stable. +A set of binaries to manage, provision, and deploy MirageOS unikernels. +Some daemons are supposed to run in the host system, communicating via Unix domain sockets: +- `vmmd`: privileged to create and destroy unikernels (also creates tap devices and attaches these to bridges) +- `vmmd_console`: reads the console output of unikernels (via a fifo passed from `vmmd`) +- `vmmd_log`: event log +- `vmmd_stats`: statistics (`getrusage`, ifstat, BHyve debug counters) gathering +- `vmmd_tls`: authenticates and proxies commands carried by a client certificate +- `vmmd_influx`: reports statistics from stats to influx listener + +Command-line applications for local and remote management are provided as well +- `vmmc_local`: executes a command locally via Unix domain sockets +- `vmmc_remote`: connects to `vmm_tls_endpoint` and executes command +- `vmmc_bistro`: command line utility to execute a command remotely: request, sign, remote (do not use in production, requires CA key on host) +- `vmmp_request`: creates a certificate signing request containing a command +- `vmmp_sign`: signs a certificate signing request Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation and an overview. diff --git a/_tags b/_tags index 07bee85..5080875 100644 --- a/_tags +++ b/_tags @@ -1,20 +1,24 @@ true : bin_annot, safe_string, principal, color(always) true : warn(+A-4-44-48) -true : package(rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration cstruct) +true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decompress asn1-combinators) "src" : include -: package(decompress) -: package(asn1-combinators) : package(lwt lwt.unix) : package(lwt tls.lwt) : package(x509) +: package(ptime.clock.os) -: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix decompress) -: package(nocrypto tls.lwt nocrypto.lwt) -: package(tls.lwt) -: package(nocrypto tls.lwt nocrypto.lwt) +: package(lwt.unix cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt ipaddr.unix) +: package(ptime.clock.os) +: package(ptime.clock.os) +: package(ptime.clock.os) +: package(tls.lwt ptime.clock.os) +: link_vmm_stats, package(asn1-combinators) -: package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty asn1-combinators nocrypto.unix lwt decompress) +: package(nocrypto tls.lwt nocrypto.lwt) + +: package(nocrypto.unix ptime.clock.os x509) +: package(nocrypto.unix ptime.clock.os x509) + +: package(nocrypto.unix ptime.clock.os x509) -: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt decompress) -: link_vmm_stats, package(cmdliner logs.fmt fmt.cli logs.cli fmt.tty lwt.unix lwt decompress) diff --git a/provision/vmm_provision.ml b/app/vmm_provision.ml similarity index 100% rename from provision/vmm_provision.ml rename to app/vmm_provision.ml diff --git a/stats/vmm_stats.ml b/app/vmm_stats_pure.ml similarity index 100% rename from stats/vmm_stats.ml rename to app/vmm_stats_pure.ml diff --git a/stats/vmm_stats_stubs.c b/app/vmm_stats_stubs.c similarity index 100% rename from stats/vmm_stats_stubs.c rename to app/vmm_stats_stubs.c diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml new file mode 100644 index 0000000..e69de29 diff --git a/app/vmmc.ml b/app/vmmc_local.ml similarity index 99% rename from app/vmmc.ml rename to app/vmmc_local.ml index d0d2889..5816b4f 100644 --- a/app/vmmc.ml +++ b/app/vmmc_local.ml @@ -326,7 +326,7 @@ let default_cmd = `P "$(tname) connects to vmmd via a local socket" ] in Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), - Term.info "vmmc" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] diff --git a/app/vmm_client.ml b/app/vmmc_remote.ml similarity index 89% rename from app/vmm_client.ml rename to app/vmmc_remote.ml index 1083b08..5572a8f 100644 --- a/app/vmm_client.ml +++ b/app/vmmc_remote.ml @@ -14,6 +14,12 @@ let client cas host port cert priv_key = let auth = if Sys.is_directory cas then `Ca_dir cas else `Ca_file cas in X509_lwt.authenticator auth >>= fun authenticator -> Lwt.catch (fun () -> + (* TODO TLS certificate verification and gethostbyname: + - allow IP address and hostname + - if IP is specified, use it (and no TLS name verification - or SubjAltName with IP?) + - if hostname is specified + - no ip: gethostbyname + - ip: connecto to ip and verify hostname *) Lwt_unix.gethostbyname host >>= fun host_entry -> let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in @@ -88,7 +94,7 @@ let cmd = `P "$(tname) connects to a server and initiates a TLS handshake" ] in Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination), - Term.info "vmm_client" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "vmmd_remote" ~version:"%%VERSION_NUM%%" ~doc ~man let () = match Term.eval cmd diff --git a/app/vmm_console.ml b/app/vmmd_console.ml similarity index 99% rename from app/vmm_console.ml rename to app/vmmd_console.ml index 16ac1ea..9f025ae 100644 --- a/app/vmm_console.ml +++ b/app/vmmd_console.ml @@ -189,6 +189,6 @@ let socket = let cmd = Term.(ret (const jump $ setup_log $ socket)), - Term.info "vmm_console" ~version:"%%VERSION_NUM%%" + Term.info "vmmd_console" ~version:"%%VERSION_NUM%%" let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/app/vmm_influxdb_stats.ml b/app/vmmd_influx.ml similarity index 99% rename from app/vmm_influxdb_stats.ml rename to app/vmmd_influx.ml index f53ce3c..2170fec 100644 --- a/app/vmm_influxdb_stats.ml +++ b/app/vmmd_influx.ml @@ -328,7 +328,7 @@ let cmd = `P "$(tname) connects to a vmm stats socket, pulls statistics and pushes them via TCP to influxdb" ] in Term.(pure run_client $ setup_log $ socket $ influx $ opt_vmname), - Term.info "vmm_influxdb_stats" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "vmmd_influx" ~version:"%%VERSION_NUM%%" ~doc ~man let () = match Term.eval cmd diff --git a/app/vmm_log.ml b/app/vmmd_log.ml similarity index 100% rename from app/vmm_log.ml rename to app/vmmd_log.ml diff --git a/stats/vmm_stats_lwt.ml b/app/vmmd_stats.ml similarity index 93% rename from stats/vmm_stats_lwt.ml rename to app/vmmd_stats.ml index 0763592..dfe28d9 100644 --- a/stats/vmm_stats_lwt.ml +++ b/app/vmmd_stats.ml @@ -14,7 +14,9 @@ open Lwt.Infix -let t = ref (Vmm_stats.empty ()) +open Vmm_stats_pure + +let t = ref (empty ()) let pp_sockaddr ppf = function | Lwt_unix.ADDR_UNIX str -> Fmt.pf ppf "unix domain socket %s" str @@ -29,7 +31,7 @@ let handle s addr () = Logs.err (fun m -> m "exception while reading") ; Lwt.return pids | Ok wire -> - match Vmm_stats.handle !t s wire with + match handle !t s wire with | Error (`Msg msg) -> Vmm_lwt.write_wire s (fst wire, `Failure msg) >>= fun _ -> Lwt.return pids @@ -56,17 +58,17 @@ let handle s addr () = loop [] >>= fun vmids -> Vmm_lwt.safe_close s >|= fun () -> Logs.warn (fun m -> m "disconnect, dropping %d vms!" (List.length vmids)) ; - let t' = Vmm_stats.remove_vmids !t vmids in + let t' = remove_vmids !t vmids in t := t' let rec timer interval () = - let t', outs = Vmm_stats.tick !t in + let t', outs = tick !t in t := t' ; Lwt_list.iter_p (fun (s, name, stat) -> Vmm_lwt.write_wire s stat >>= function | Ok () -> Lwt.return_unit | Error `Exception -> - t := Vmm_stats.remove_entry !t name ; + t := remove_entry !t name ; Vmm_lwt.safe_close s) outs >>= fun () -> Lwt_unix.sleep interval >>= fun () -> @@ -113,6 +115,6 @@ let interval = let cmd = Term.(ret (const jump $ setup_log $ socket $ interval)), - Term.info "vmm_stats" ~version:"%%VERSION_NUM%%" + Term.info "vmmd_stats" ~version:"%%VERSION_NUM%%" let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/app/vmm_tls_endpoint.ml b/app/vmmd_tls.ml similarity index 99% rename from app/vmm_tls_endpoint.ml rename to app/vmmd_tls.ml index cb1a230..6694efe 100644 --- a/app/vmm_tls_endpoint.ml +++ b/app/vmmd_tls.ml @@ -167,6 +167,6 @@ let port = let cmd = Term.(ret (const jump $ setup_log $ cacert $ cert $ key $ port)), - Term.info "vmm_tls_endpoint" ~version:"%%VERSION_NUM%%" + Term.info "vmmd_tls" ~version:"%%VERSION_NUM%%" let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/provision/vmm_req_delegation.ml b/app/vmmp_request.ml similarity index 52% rename from provision/vmm_req_delegation.ml rename to app/vmmp_request.ml index dcdd32e..caa9110 100644 --- a/provision/vmm_req_delegation.ml +++ b/app/vmmp_request.ml @@ -1,5 +1,78 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) +open Vmm_provision + +open Rresult.R.Infix + +open Vmm_asn + +let vm_csr key name image cpuid requested_memory argv block_device network force compression = + let vm_config = + let vmimage = match compression with + | 0 -> `Hvt_amd64, image + | level -> + let img = Vmm_compress.compress ~level (Cstruct.to_string image) in + `Hvt_amd64_compressed, Cstruct.of_string img + and argv = match argv with [] -> None | xs -> Some xs + in + Vmm_core.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } + in + let cmd = if force then `Vm_force_create vm_config else `Vm_create vm_config in + let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, `Vm_cmd cmd))) ] + and name = [ `CN name ] + in + X509.CA.request name ~extensions:[`Extensions exts] key + +let jump _ name key image mem cpu args block net force compression = + Nocrypto_entropy_unix.initialize () ; + match + priv_key key name >>= fun key -> + (Bos.OS.File.read (Fpath.v image) >>= fun s -> + Ok (Cstruct.of_string s)) >>= fun image -> + let csr = vm_csr key name image cpu mem args block net force compression in + let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in + Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc) + with + | Ok () -> `Ok () + | Error (`Msg m) -> `Error (false, m) + +open Cmdliner + +let cpu = + let doc = "CPUid" in + Arg.(required & pos 3 (some int) None & info [] ~doc) + +let image = + let doc = "Image file to provision" in + Arg.(required & pos 1 (some file) None & info [] ~doc) + +let args = + let doc = "Boot arguments" in + Arg.(value & opt_all string [] & info [ "arg" ] ~doc) + +let block = + let doc = "Block device name" in + Arg.(value & opt (some string) None & info [ "block" ] ~doc) + +let net = + let doc = "Network device" in + Arg.(value & opt_all string [] & info [ "net" ] ~doc) + +let force = + let doc = "Force creation (destroy VM with same name if it exists)" in + Arg.(value & flag & info [ "force" ] ~doc) + +let compress_level = + let doc = "Compression level (0 for no compression)" in + Arg.(value & opt int 4 & info [ "compression-level" ] ~doc) + +let cmd = + Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)), + Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" + +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 +(* (c) 2017 Hannes Mehnert, all rights reserved *) + open Vmm_provision open Vmm_asn @@ -77,6 +150,6 @@ let bridge = let cmd = Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)), - Term.info "vmm_req_delegation" ~version:"%%VERSION_NUM%%" + Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/provision/vmm_sign.ml b/app/vmmp_sign.ml similarity index 62% rename from provision/vmm_sign.ml rename to app/vmmp_sign.ml index 4ac30d9..6737d72 100644 --- a/provision/vmm_sign.ml +++ b/app/vmmp_sign.ml @@ -67,6 +67,56 @@ let key = let cmd = Term.(ret (const jump $ setup_log $ db $ cacert $ key $ csr $ days)), - Term.info "vmm_sign" ~version:"%%VERSION_NUM%%" + Term.info "vmmp_sign" ~version:"%%VERSION_NUM%%" + +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 +(* (c) 2017 Hannes Mehnert, all rights reserved *) + +open Vmm_provision + +open Rresult.R.Infix + +let s_exts = + [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) + ; (true, `Basic_constraints (false, None)) + ; (true, `Ext_key_usage [`Server_auth]) ] + +let jump _ name db days sname sdays = + Nocrypto_entropy_unix.initialize () ; + match + priv_key ~bits:4096 None name >>= fun key -> + let name = [ `CN name ] in + let csr = X509.CA.request name key in + sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () -> + priv_key None sname >>= fun skey -> + let sname = [ `CN sname ] in + let csr = X509.CA.request sname skey in + sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays) + with + | Ok () -> `Ok () + | Error (`Msg e) -> `Error (false, e) + + +open Cmdliner + +let days = + let doc = "Number of days" in + Arg.(value & opt int 3650 & info [ "days" ] ~doc) + +let db = + let doc = "Database" in + Arg.(required & pos 1 (some string) None & info [] ~doc) + +let sname = + let doc = "Server name" in + Arg.(value & opt string "server" & info [ "server" ] ~doc) + +let sday = + let doc = "Server validity" in + Arg.(value & opt int 365 & info [ "server-days" ] ~doc) + +let cmd = + Term.(ret (const jump $ setup_log $ nam $ db $ days $ sname $ sday)), + Term.info "vmmp_sign" ~version:"%%VERSION_NUM%%" let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 7f9eb76..2093954 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -19,8 +19,8 @@ let () = flag ["link"; "library"; "ocaml"; "native"; "use_vmm_stats"] (S ([A "-cclib"; A "-lvmm_stats_stubs"])); flag ["link"; "ocaml"; "link_vmm_stats"] - (S ([A "stats/libvmm_stats_stubs.a"] @ vmm_lib)); - dep ["link"; "ocaml"; "use_vmm_stats"] ["stats/libvmm_stats_stubs.a"]; - dep ["link"; "ocaml"; "link_vmm_stats"] ["stats/libvmm_stats_stubs.a"]; + (S ([A "app/libvmm_stats_stubs.a"] @ vmm_lib)); + dep ["link"; "ocaml"; "use_vmm_stats"] ["app/libvmm_stats_stubs.a"]; + dep ["link"; "ocaml"; "link_vmm_stats"] ["app/libvmm_stats_stubs.a"]; | _ -> () end diff --git a/opam b/opam index 79e236f..6d8816a 100644 --- a/opam +++ b/opam @@ -1,12 +1,12 @@ -opam-version: "1.2" +opam-version: "2.0" maintainer: "Hannes Mehnert " authors: ["Hannes Mehnert "] -homepage: "https://github.com/hannesm/vmm" -dev-repo: "https://github.com/hannesm/vmm.git" -bug-reports: "https://github.com/hannesm/vmm/issues" -available: [ ocaml-version >= "4.05.0"] +homepage: "https://github.com/hannesm/albatross" +dev-repo: "git+https://github.com/hannesm/albatross.git" +bug-reports: "https://github.com/hannesm/albatross/issues" depends: [ + "ocaml" {>= "4.05.0"} "ocamlfind" {build} "ocamlbuild" {build} "topkg" {build} @@ -32,3 +32,4 @@ depends: [ build: [ [ "ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%" "--tests" "false" ] ] +synopsis: "Albatross - orchestrate and manage MirageOS unikernels" diff --git a/packaging/create_package.sh b/packaging/create_package.sh index b54f753..a54e5ff 100755 --- a/packaging/create_package.sh +++ b/packaging/create_package.sh @@ -23,15 +23,15 @@ for f in albatross_log \ do install -U $basedir/packaging/rc.d/$f $rootdir/usr/local/etc/rc.d/$f; done # stage albatross app binaries -for f in vmmd vmm_log vmm_console; do +for f in vmmd vmmd_log vmmd_console; do install -U $basedir/_build/app/$f.native \ $rootdir/usr/local/libexec/albatross/$f; done -install -U $basedir/_build/stats/vmm_stats_lwt.native \ - $rootdir/usr/local/libexec/albatross/vmm_stats_lwt +install -U $basedir/_build/app/vmmd_stats.native \ + $rootdir/usr/local/libexec/albatross/vmmd_stats -install -U $basedir/_build/app/vmmc.native \ - $rootdir/usr/local/sbin/vmmc +install -U $basedir/_build/app/vmm_local.native \ + $rootdir/usr/local/sbin/vmm_local # create +MANIFEST flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + | diff --git a/packaging/rc.d/albatross_console b/packaging/rc.d/albatross_console index 7b3df7b..ef8845f 100755 --- a/packaging/rc.d/albatross_console +++ b/packaging/rc.d/albatross_console @@ -29,7 +29,7 @@ start_cmd="albatross_console_start" : ${albatross_console_user:="albatross"} pidfile="/var/run/albatross_console.pid" -procname="/usr/local/libexec/albatross/vmm_console" +procname="/usr/local/libexec/albatross/vmmd_console" albatross_console_start () { /usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_console_user}" \ diff --git a/packaging/rc.d/albatross_log b/packaging/rc.d/albatross_log index e49b02e..f44b2ea 100755 --- a/packaging/rc.d/albatross_log +++ b/packaging/rc.d/albatross_log @@ -30,7 +30,7 @@ start_precmd="albatross_log_precmd" : ${albatross_log_user:="albatross"} pidfile="/var/run/albatross_log.pid" -procname="/usr/local/libexec/albatross/vmm_log" +procname="/usr/local/libexec/albatross/vmmd_log" logfile="/var/log/albatross" albatross_log_precmd () { diff --git a/packaging/rc.d/albatross_stat b/packaging/rc.d/albatross_stat index 04b215d..305f6cc 100755 --- a/packaging/rc.d/albatross_stat +++ b/packaging/rc.d/albatross_stat @@ -29,7 +29,7 @@ start_cmd="albatross_stat_start" : ${albatross_stat_user:="albatross"} pidfile="/var/run/albatross_stat.pid" -procname="/usr/local/libexec/albatross/vmm_stats_lwt" +procname="/usr/local/libexec/albatross/vmmd_stats" albatross_stat_start () { /usr/sbin/daemon -S -p "${pidfile}" -u "${albatross_stat_user}" \ diff --git a/pkg/META b/pkg/META index 9f42198..29b861c 100644 --- a/pkg/META +++ b/pkg/META @@ -1,7 +1,2 @@ description = "VM Manager" version = "%%VERSION_NUM%%" -requires = "rresult logs ipaddr x509 tls bos hex ptime ptime.clock.os astring duration asn1-combinators lwt tls.lwt decompress" -archive(byte) = "vmm.cma" -archive(native) = "vmm.cmxa" -plugin(byte) = "vmm.cma" -plugin(native) = "vmm.cmxs" diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 0d66ebe..97a095f 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -6,18 +6,15 @@ open Topkg let () = Pkg.describe "albatross" @@ fun _ -> Ok [ - Pkg.mllib "src/albatross.mllib" ; Pkg.bin "app/vmmd" ; - Pkg.bin "app/vmm_console" ; - Pkg.bin "app/vmm_log" ; - Pkg.bin "app/vmm_client" ; - Pkg.bin "app/vmm_tls_endpoint" ; - Pkg.bin "app/vmmc" ; - Pkg.bin "provision/vmm_req_delegation" ; - Pkg.bin "provision/vmm_req_vm" ; - Pkg.bin "provision/vmm_sign" ; - Pkg.bin "provision/vmm_gen_ca" ; - (* Pkg.clib "stats/libvmm_stats_stubs.clib" ; *) - Pkg.bin "stats/vmm_stats_lwt" ; - Pkg.bin "app/vmm_influxdb_stats" ; + Pkg.bin "app/vmmd_console" ; + Pkg.bin "app/vmmd_log" ; + Pkg.bin "app/vmmd_stats" ; + Pkg.bin "app/vmmd_tls" ; + Pkg.bin "app/vmmd_influx" ; + Pkg.bin "app/vmmc_local" ; + Pkg.bin "app/vmmc_remote" ; + Pkg.bin "app/vmmc_bistro" ; + Pkg.bin "app/vmmp_request" ; + Pkg.bin "app/vmmp_sign" ; ] diff --git a/provision/vmm_gen_ca.ml b/provision/vmm_gen_ca.ml deleted file mode 100644 index 738cceb..0000000 --- a/provision/vmm_gen_ca.ml +++ /dev/null @@ -1,50 +0,0 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -open Vmm_provision - -open Rresult.R.Infix - -let s_exts = - [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) - ; (true, `Basic_constraints (false, None)) - ; (true, `Ext_key_usage [`Server_auth]) ] - -let jump _ name db days sname sdays = - Nocrypto_entropy_unix.initialize () ; - match - priv_key ~bits:4096 None name >>= fun key -> - let name = [ `CN name ] in - let csr = X509.CA.request name key in - sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () -> - priv_key None sname >>= fun skey -> - let sname = [ `CN sname ] in - let csr = X509.CA.request sname skey in - sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays) - with - | Ok () -> `Ok () - | Error (`Msg e) -> `Error (false, e) - - -open Cmdliner - -let days = - let doc = "Number of days" in - Arg.(value & opt int 3650 & info [ "days" ] ~doc) - -let db = - let doc = "Database" in - Arg.(required & pos 1 (some string) None & info [] ~doc) - -let sname = - let doc = "Server name" in - Arg.(value & opt string "server" & info [ "server" ] ~doc) - -let sday = - let doc = "Server validity" in - Arg.(value & opt int 365 & info [ "server-days" ] ~doc) - -let cmd = - Term.(ret (const jump $ setup_log $ nam $ db $ days $ sname $ sday)), - Term.info "vmm_gen_ca" ~version:"%%VERSION_NUM%%" - -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/provision/vmm_req_vm.ml b/provision/vmm_req_vm.ml deleted file mode 100644 index f5cde5f..0000000 --- a/provision/vmm_req_vm.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -open Vmm_provision - -open Rresult.R.Infix - -open Vmm_asn - -let vm_csr key name image cpuid requested_memory argv block_device network force compression = - let vm_config = - let vmimage = match compression with - | 0 -> `Hvt_amd64, image - | level -> - let img = Vmm_compress.compress ~level (Cstruct.to_string image) in - `Hvt_amd64_compressed, Cstruct.of_string img - and argv = match argv with [] -> None | xs -> Some xs - in - Vmm_core.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } - in - let cmd = if force then `Vm_force_create vm_config else `Vm_create vm_config in - let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, `Vm_cmd cmd))) ] - and name = [ `CN name ] - in - X509.CA.request name ~extensions:[`Extensions exts] key - -let jump _ name key image mem cpu args block net force compression = - Nocrypto_entropy_unix.initialize () ; - match - priv_key key name >>= fun key -> - (Bos.OS.File.read (Fpath.v image) >>= fun s -> - Ok (Cstruct.of_string s)) >>= fun image -> - let csr = vm_csr key name image cpu mem args block net force compression in - let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in - Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc) - with - | Ok () -> `Ok () - | Error (`Msg m) -> `Error (false, m) - -open Cmdliner - -let cpu = - let doc = "CPUid" in - Arg.(required & pos 3 (some int) None & info [] ~doc) - -let image = - let doc = "Image file to provision" in - Arg.(required & pos 1 (some file) None & info [] ~doc) - -let args = - let doc = "Boot arguments" in - Arg.(value & opt_all string [] & info [ "arg" ] ~doc) - -let block = - let doc = "Block device name" in - Arg.(value & opt (some string) None & info [ "block" ] ~doc) - -let net = - let doc = "Network device" in - Arg.(value & opt_all string [] & info [ "net" ] ~doc) - -let force = - let doc = "Force creation (destroy VM with same name if it exists)" in - Arg.(value & flag & info [ "force" ] ~doc) - -let compress_level = - let doc = "Compression level (0 for no compression)" in - Arg.(value & opt int 4 & info [ "compression-level" ] ~doc) - -let cmd = - Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)), - Term.info "vmm_req_vm" ~version:"%%VERSION_NUM%%" - -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/src/albatross.mllib b/src/albatross.mllib deleted file mode 100644 index 54e58a8..0000000 --- a/src/albatross.mllib +++ /dev/null @@ -1,12 +0,0 @@ -Vmm_asn -Vmm_lwt -Vmm_tls_lwt -Vmm_tls -Vmm_vmmd -Vmm_commands -Vmm_core -Vmm_resources -Vmm_trie -Vmm_unix -Vmm_compress -Vmm_ring diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index cde00f6..834504f 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -440,14 +440,16 @@ let log_disk = (required ~label:"version" version) (required ~label:"entry" log_entry)) -let log_disk_of_cstruct, log_disk_to_cstruct = projections_of log_disk +let log_disk_of_cstruct, log_disk_to_cstruct = + let c = Asn.codec Asn.der log_disk in + (Asn.decode c, Asn.encode c) let log_to_disk version entry = log_disk_to_cstruct (version, entry) let logs_of_disk version buf = let rec next acc buf = - match Asn.decode (Asn.codec Asn.der log_disk) buf with + match log_disk_of_cstruct buf with | Ok ((version', entry), cs) -> let acc' = if Vmm_commands.version_eq version version' then @@ -471,13 +473,3 @@ let cert_extension = let cert_extension_of_cstruct, cert_extension_to_cstruct = projections_of cert_extension - -let wire_command_of_cert version cert = - match X509.Extension.unsupported cert oid with - | None -> R.error_msgf "albatross OID is not present in certificate (%a)" Asn.OID.pp oid - | Some (_, data) -> - cert_extension_of_cstruct data >>= fun (v, wire) -> - if not (version_eq v version) then - R.error_msgf "unexpected version %a (expected %a)" pp_version v pp_version version - else - Ok wire diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 6310794..2b4c48e 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -25,6 +25,3 @@ type cert_extension = Vmm_commands.version * Vmm_commands.t val cert_extension_of_cstruct : Cstruct.t -> (cert_extension, [> `Msg of string ]) result val cert_extension_to_cstruct : cert_extension -> Cstruct.t - -val wire_command_of_cert : Vmm_commands.version -> X509.t -> - (Vmm_commands.t, [> `Msg of string ]) result diff --git a/src/vmm_core.ml b/src/vmm_core.ml index f04437f..63abb84 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -177,16 +177,6 @@ let translate_tap vm tap = | [ (_, b) ] -> Some b | _ -> None -let name cert = X509.common_name_to_string cert - -(* this separates the leaf and top-level certificate from the chain, - and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA') - in which subCA' signed leaf *) -let separate_chain = function - | [] -> Error (`Msg "empty chain") - | [ leaf ] -> Ok (leaf, []) - | leaf :: xs -> Ok (leaf, List.rev xs) - module Stats = struct type rusage = { utime : (int64 * int) ; diff --git a/src/vmm_core.mli b/src/vmm_core.mli index 479c7ef..a464914 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -80,10 +80,6 @@ type vm = { val pp_vm : vm Fmt.t val translate_tap : vm -> string -> string option -val name : X509.t -> string - -val separate_chain : 'a list -> ('a * 'a list, [> `Msg of string ]) result - module Stats : sig type rusage = { utime : int64 * int; diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 06df530..2000cb7 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -1,8 +1,29 @@ (* (c) 2018 Hannes Mehnert, all rights reserved *) +open Rresult open Rresult.R.Infix -open Vmm_core +let name cert = X509.common_name_to_string cert + +(* this separates the leaf and top-level certificate from the chain, + and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA') + in which subCA' signed leaf *) +let separate_chain = function + | [] -> Error (`Msg "empty chain") + | [ leaf ] -> Ok (leaf, []) + | leaf :: xs -> Ok (leaf, List.rev xs) + +let wire_command_of_cert version cert = + match X509.Extension.unsupported cert Vmm_asn.oid with + | None -> R.error_msgf "albatross OID is not present in certificate (%a)" Asn.OID.pp Vmm_asn.oid + | Some (_, data) -> + Vmm_asn.cert_extension_of_cstruct data >>= fun (v, wire) -> + if not (Vmm_commands.version_eq v version) then + R.error_msgf "unexpected version %a (expected %a)" + Vmm_commands.pp_version v + Vmm_commands.pp_version version + else + Ok wire (* let check_policy = (* get names and static resources *) @@ -28,7 +49,7 @@ let handle _addr version chain = (* TODO: inspect top-level-cert of chain. *) (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) (* TODO: update policies (parse chain for policy, and apply them)! *) - Vmm_asn.wire_command_of_cert version leaf >>= fun wire -> + wire_command_of_cert version leaf >>= fun wire -> (* we only allow some commands via certificate *) match wire with | `Console_cmd (`Console_subscribe _) diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index ebb5e2f..6505d41 100644 --- a/src/vmm_tls.mli +++ b/src/vmm_tls.mli @@ -1,5 +1,8 @@ (* (c) 2018 Hannes Mehnert, all rights reserved *) +val wire_command_of_cert : Vmm_commands.version -> X509.t -> + (Vmm_commands.t, [> `Msg of string ]) result + val handle : 'a -> Vmm_commands.version -> X509.t list -> diff --git a/stats/libvmm_stats_stubs.clib b/stats/libvmm_stats_stubs.clib deleted file mode 100644 index 209b378..0000000 --- a/stats/libvmm_stats_stubs.clib +++ /dev/null @@ -1 +0,0 @@ -vmm_stats_stubs.o From aa051d62cde3c2880873b30e166e6cec713abb16 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 26 Oct 2018 00:43:37 +0200 Subject: [PATCH 54/73] vmmd_log: send ack on data receive --- app/vmmd_log.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/app/vmmd_log.ml b/app/vmmd_log.ml index 6bac67f..09f1b2a 100644 --- a/app/vmmd_log.ml +++ b/app/vmmd_log.ml @@ -96,11 +96,12 @@ let send_history s ring id ts = | Error e -> Lwt.return (Error e)) (Ok ()) (List.rev res) -let handle_data mvar ring hdr entry = +let handle_data s mvar ring hdr entry = if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin Logs.warn (fun m -> m "unsupported version") ; Lwt.return_unit end else begin + Vmm_lwt.write_wire s (hdr, `Success `Empty) >>= fun _ -> Vmm_ring.write ring entry ; Lwt_mvar.put mvar entry >>= fun () -> let data' = (hdr, `Data (`Log_data entry)) in @@ -115,7 +116,7 @@ let read_data mvar ring s = Logs.err (fun m -> m "error while reading") ; Lwt.return_unit | Ok (hdr, `Data (`Log_data entry)) -> - handle_data mvar ring hdr entry >>= fun () -> + handle_data s mvar ring hdr entry >>= fun () -> loop () | Ok wire -> Logs.warn (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire wire) ; @@ -130,7 +131,7 @@ let handle mvar ring s addr () = Logs.err (fun m -> m "error while reading") ; Lwt.return_unit | Ok (hdr, `Data (`Log_data entry)) -> - handle_data mvar ring hdr entry >>= fun () -> + handle_data s mvar ring hdr entry >>= fun () -> read_data mvar ring s | Ok (hdr, `Command (`Log_cmd lc)) -> if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin From a60f866f70c6108d5f09d433613a8f0180919724 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 26 Oct 2018 01:11:41 +0200 Subject: [PATCH 55/73] fewer lists, read replies (to sockets) in vmmd --- app/vmm_cli.ml | 11 ++++ app/vmmd.ml | 143 ++++++++++++++++++++++++----------------------- src/vmm_vmmd.ml | 21 +++---- src/vmm_vmmd.mli | 6 +- 4 files changed, 97 insertions(+), 84 deletions(-) create mode 100644 app/vmm_cli.ml diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml new file mode 100644 index 0000000..3612518 --- /dev/null +++ b/app/vmm_cli.ml @@ -0,0 +1,11 @@ +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 ()) diff --git a/app/vmmd.ml b/app/vmmd.ml index 83e1fba..bb39ae4 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -1,5 +1,7 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) +open Vmm_cli + type stats = { start : Ptime.t ; vm_created : int ; @@ -20,54 +22,36 @@ let version = `AV2 let state = ref (Vmm_vmmd.init version) -let create c_fd process cont = - Vmm_lwt.read_wire c_fd >>= function +let create process cont = + let await, wakeme = Lwt.wait () in + match cont !state await with | Error (`Msg msg) -> - Logs.err (fun m -> m "error %s while reading from console" msg) ; + Logs.err (fun m -> m "create continuation failed %s" msg) ; Lwt.return_unit - | Error _ -> - Logs.err (fun m -> m "error while reading from console") ; - Lwt.return_unit - | Ok (header, wire) -> - if not (Vmm_commands.version_eq version header.Vmm_commands.version) then begin - Logs.err (fun m -> m "invalid version while reading from console") ; - Lwt.return_unit - end else - match wire with - | `Command _ -> - Logs.err (fun m -> m "console returned a command") ; - Lwt.return_unit - | `Failure f -> - Logs.err (fun m -> m "console failed with %s" f) ; - Lwt.return_unit - | `Data _ -> - Logs.err (fun m -> m "console replied with data") ; - Lwt.return_unit - | `Success _msg -> - (* assert hdr.id = id! *) - let await, wakeme = Lwt.wait () in - match cont !state await with - | Error (`Msg msg) -> - Logs.err (fun m -> m "create continuation failed %s" msg) ; - Lwt.return_unit - | Ok (state'', out, name, vm) -> - state := state'' ; - s := { !s with vm_created = succ !s.vm_created } ; - Lwt.async (fun () -> - Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> - let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in - s := { !s with vm_destroyed = succ !s.vm_destroyed } ; - state := state' ; - process out' >|= fun () -> - Lwt.wakeup wakeme ()) ; - process out >>= fun () -> - let state', out = Vmm_vmmd.setup_stats !state name vm in - state := state' ; - process out (* TODO: need to read from stats socket! *) + | Ok (state'', out, name, vm) -> + state := state'' ; + s := { !s with vm_created = succ !s.vm_created } ; + Lwt.async (fun () -> + Vmm_lwt.wait_and_clear vm.Vmm_core.pid vm.Vmm_core.stdout >>= fun r -> + let state', out' = Vmm_vmmd.handle_shutdown !state name vm r in + s := { !s with vm_destroyed = succ !s.vm_destroyed } ; + state := state' ; + (process out' >|= function + | Error (`Msg msg) -> + Logs.err (fun m -> m "error %s on handling shutdown" msg) + | Ok () -> ()) >|= fun () -> + Lwt.wakeup wakeme ()) ; + (process out >|= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error %s while setting up stats and logging" msg) + | Ok () -> ()) >>= fun () -> + let state', out = Vmm_vmmd.setup_stats !state name vm in + state := state' ; + process [ out ] >|= function + | Error (`Msg msg) -> Logs.err (fun m -> m "error %s sending information to stats" msg) + | Ok () -> () -let handle out c_fd fd addr = +let handle out fd addr = (* out is for `Log | `Stat | `Cons (including reconnect semantics) *) - (* need to handle data out (+ die on write failure) *) Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ; (* now we need to read a packet and handle it (1) @@ -81,12 +65,16 @@ let handle out c_fd fd addr = -- Lwt effects happen (stats, logs, wait_and_clear) -- (2) goto (1) *) - let process xs = - Lwt_list.iter_p (function - | #Vmm_vmmd.service_out as o -> out o - | `Data cs -> + let process wires = + Lwt_list.fold_left_s (fun r data -> + match r, data with + | Ok (), (#Vmm_vmmd.service_out as o) -> out o + | Ok (), `Data wire -> (* rather: terminate connection *) - Vmm_lwt.write_wire fd cs >|= fun _ -> ()) xs + Vmm_lwt.write_wire fd wire >|= fun _ -> + Ok () + | Error e, _ -> Lwt.return (Error e)) + (Ok ()) wires in Logs.debug (fun m -> m "now reading") ; (Vmm_lwt.read_wire fd >>= function @@ -97,20 +85,24 @@ let handle out c_fd fd addr = Logs.debug (fun m -> m "read sth") ; let state', data, next = Vmm_vmmd.handle_command !state wire in state := state' ; - process data >>= fun () -> - match next with - | `End -> Lwt.return_unit - | `Wait (task, out) -> task >>= fun () -> process out + process data >>= function + | Error (`Msg msg) -> Logs.err (fun m -> m "received error %s" msg) ; Lwt.return_unit + | Ok () -> match next with + | `End -> Lwt.return_unit + | `Wait (task, out) -> + task >>= fun () -> + process [ out ] >|= fun _ -> + () | `Wait_and_create (task, next) -> task >>= fun () -> let state', data, n = next !state in state := state' ; - process data >>= fun () -> + process data >>= fun _ -> (match n with | `End -> Lwt.return_unit - | `Create cont -> create c_fd process cont) + | `Create cont -> create process cont) | `Create cont -> - create c_fd process cont + create process cont (* data contained a write to console, we need to wait for its reply first *) ) >>= fun () -> Vmm_lwt.safe_close fd @@ -172,33 +164,42 @@ let jump _ = create_mbox `Stats >>= fun s -> (create_mbox `Log >|= function | None -> invalid_arg "cannot connect to log socket" - | Some l -> l) >>= fun (l, _l_fd) -> + | Some l -> l) >>= fun (l, l_fd) -> + let write_reply (header, cmd) mvar fd = + Lwt_mvar.put mvar (header, cmd) >>= fun () -> + Vmm_lwt.read_wire fd >|= function + | Ok (header', reply) -> + if not Vmm_commands.(version_eq header.version header'.version) then + Error (`Msg "wrong version in reply") + else if not Vmm_commands.(Int64.equal header.sequence header'.sequence) then + Error (`Msg "wrong id in reply") + else begin match reply with + | `Success _ -> Ok () + | `Failure msg -> Error (`Msg msg) + | _ -> Error (`Msg "unexpected data") + end + | Error _ -> Error (`Msg "error in read") + in let out = function - | `Stat data -> (match s with None -> Lwt.return_unit | Some (s, _s_fd) -> Lwt_mvar.put s data) - | `Log data -> Lwt_mvar.put l data - | `Cons data -> Lwt_mvar.put c data + | `Stat wire -> + begin match s with + | None -> Lwt.return (Ok ()) + | Some (s, s_fd) -> write_reply wire s s_fd + end + | `Log wire -> write_reply wire l l_fd + | `Cons wire -> write_reply wire c c_fd in Lwt.async stats_loop ; let rec loop () = Lwt_unix.accept ss >>= fun (fd, addr) -> Lwt_unix.set_close_on_exec fd ; - Lwt.async (fun () -> handle out c_fd fd addr) ; + Lwt.async (fun () -> handle out fd addr) ; loop () in loop ()) -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) - open Cmdliner -let setup_log = - Term.(const setup_log - $ Fmt_cli.style_renderer () - $ Logs_cli.level ()) - let cmd = Term.(ret (const jump $ setup_log)), Term.info "vmmd" ~version:"%%VERSION_NUM%%" diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index 4a089e7..8976260 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -57,7 +57,8 @@ let handle_create t hdr vm_config = let header = Vmm_commands.{ version = t.wire_version ; sequence = t.console_counter ; id = name } in (header, `Command (`Console_cmd `Console_add)) in - Ok ({ t with console_counter = Int64.succ t.console_counter }, [ `Cons cons_out ], + Ok ({ t with console_counter = Int64.succ t.console_counter }, + [ `Cons cons_out ], `Create (fun t task -> (* actually execute the vm *) Vmm_unix.exec name vm_config taps >>= fun vm -> @@ -73,7 +74,7 @@ let setup_stats t name vm = let stat_out = `Stats_add (vm.pid, vm.taps) in let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let t = { t with stats_counter = Int64.succ t.stats_counter } in - t, [ `Stat (header, `Command (`Stats_cmd stat_out)) ] + t, `Stat (header, `Command (`Stats_cmd stat_out)) let handle_shutdown t name vm r = (match Vmm_unix.shutdown name vm with @@ -92,9 +93,9 @@ let handle_command t (header, payload) = | Ok x -> x | Error (`Msg msg) -> Logs.debug (fun m -> m "error while processing command: %s" msg) ; - let out = `Failure msg in - (t, [ `Data (header, out) ], `End) + (t, [ `Data (header, `Failure msg) ], `End) in + let reply x = `Data (header, `Success x) in msg_to_err ( let id = header.Vmm_commands.id in match payload with @@ -103,11 +104,11 @@ let handle_command t (header, payload) = | `Policy_remove -> Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ; let resources = Vmm_resources.remove t.resources id in - Ok ({ t with resources }, [ `Data (header, `Success (`String "removed policy")) ], `End) + Ok ({ t with resources }, [ reply (`String "removed policy") ], `End) | `Policy_add policy -> Logs.debug (fun m -> m "insert policy %a" pp_id id) ; Vmm_resources.insert_policy t.resources id policy >>= fun resources -> - Ok ({ t with resources }, [ `Data (header, `Success (`String "added policy")) ], `End) + Ok ({ t with resources }, [ reply (`String "added policy") ], `End) | `Policy_info -> begin Logs.debug (fun m -> m "policy %a" pp_id id) ; @@ -122,7 +123,7 @@ let handle_command t (header, payload) = Logs.debug (fun m -> m "policies: couldn't find %a" pp_id id) ; Error (`Msg "policy: not found") | _ -> - Ok (t, [ `Data (header, `Success (`Policies policies)) ], `End) + Ok (t, [ reply (`Policies policies) ], `End) end end | `Command (`Vm_cmd vc) -> @@ -140,7 +141,7 @@ let handle_command t (header, payload) = Logs.debug (fun m -> m "info: couldn't find %a" pp_id id) ; Error (`Msg "info: not found") | _ -> - Ok (t, [ `Data (header, `Success (`Vms vms)) ], `End) + Ok (t, [ reply (`Vms vms) ], `End) end | `Vm_create vm_config -> handle_create t header vm_config @@ -168,9 +169,9 @@ let handle_command t (header, payload) = Vmm_unix.destroy vm ; let id_str = string_of_id id in let out, next = - let s = [ `Data (header, `Success (`String "destroyed vm")) ] in + let s = reply (`String "destroyed vm") in match String.Map.find_opt id_str t.tasks with - | None -> s, `End + | None -> [ s ], `End | Some t -> [], `Wait (t, s) in let tasks = String.Map.remove id_str t.tasks in diff --git a/src/vmm_vmmd.mli b/src/vmm_vmmd.mli index 867bd3e..1c42cbe 100644 --- a/src/vmm_vmmd.mli +++ b/src/vmm_vmmd.mli @@ -17,11 +17,11 @@ val handle_shutdown : 'a t -> Vmm_core.id -> Vmm_core.vm -> val handle_command : 'a t -> Vmm_commands.wire -> 'a t * out list * - [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result + [ `Create of 'c t -> 'c -> ('c t * out list * Vmm_core.id * Vmm_core.vm, [> `Msg of string ]) result | `End - | `Wait of 'a * out list + | `Wait of 'a * out | `Wait_and_create of 'a * ('a t -> 'a t * out list * [ `Create of 'd t -> 'd -> ('d t * out list * Vmm_core.id * Vmm_core.vm, [> Rresult.R.msg ]) result | `End ]) ] -val setup_stats : 'a t -> Vmm_core.id -> Vmm_core.vm -> 'a t * out list +val setup_stats : 'a t -> Vmm_core.id -> Vmm_core.vm -> 'a t * out From cc29ddc98c2fca545201a122419bd6849a35e933 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 26 Oct 2018 20:58:00 +0200 Subject: [PATCH 56/73] minor packaging fixes --- packaging/create_package.sh | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/packaging/create_package.sh b/packaging/create_package.sh index a54e5ff..c0c7eab 100755 --- a/packaging/create_package.sh +++ b/packaging/create_package.sh @@ -23,15 +23,12 @@ for f in albatross_log \ do install -U $basedir/packaging/rc.d/$f $rootdir/usr/local/etc/rc.d/$f; done # stage albatross app binaries -for f in vmmd vmmd_log vmmd_console; do +for f in vmmd vmmd_log vmmd_console vmmd_stats; do install -U $basedir/_build/app/$f.native \ $rootdir/usr/local/libexec/albatross/$f; done -install -U $basedir/_build/app/vmmd_stats.native \ - $rootdir/usr/local/libexec/albatross/vmmd_stats - -install -U $basedir/_build/app/vmm_local.native \ - $rootdir/usr/local/sbin/vmm_local +install -U $basedir/_build/app/vmmc_local.native \ + $rootdir/usr/local/sbin/vmmc_local # create +MANIFEST flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + | From 7bbfb2e9fa9830ef3f377ec190945f5ff65a452a Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 26 Oct 2018 21:35:40 +0200 Subject: [PATCH 57/73] use vmm_cli --- app/vmm_cli.ml | 45 +++++++++++++++++++++++++++++++ app/vmmc_local.ml | 64 ++++++++------------------------------------- app/vmmc_remote.ml | 32 +++-------------------- app/vmmd.ml | 3 --- app/vmmd_console.ml | 15 +++-------- app/vmmd_influx.ml | 39 +++------------------------ app/vmmd_log.ml | 20 ++++---------- app/vmmd_stats.ml | 18 +++---------- app/vmmd_tls.ml | 13 +-------- app/vmmp_request.ml | 27 ++----------------- 10 files changed, 78 insertions(+), 198 deletions(-) diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml index 3612518..88dd2ec 100644 --- a/app/vmm_cli.ml +++ b/app/vmm_cli.ml @@ -9,3 +9,48 @@ let setup_log = Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + +let host_port : (string * int) Arg.converter = + let parse s = + match Astring.String.cut ~sep:":" s with + | None -> `Error "broken: no port specified" + | Some (hostname, port) -> + try + `Ok (hostname, int_of_string port) + with + Not_found -> `Error "failed to parse port" + in + parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p + +let bridge = + let parse s = + match Astring.String.cuts ~sep:"/" s with + | [ name ; fst ; lst ; gw ; nm ] -> + begin match Ipaddr.V4.(of_string fst, of_string lst, of_string gw) with + | Some fst, Some lst, Some gw -> + (try + let nm = int_of_string nm in + if nm > 0 && nm <= 32 then + let net = Ipaddr.V4.Prefix.make nm gw in + if Ipaddr.V4.Prefix.mem fst net && Ipaddr.V4.Prefix.mem lst net then + `Ok (`External (name, fst, lst, gw, nm)) + else + `Error "first or last IP are not in subnet" + else + `Error "netmask must be > 0 and <= 32" + with Failure _ -> `Error "couldn't parse netmask") + | _ -> `Error "couldn't parse IP address" + end + | [ name ] -> `Ok (`Internal name) + | _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')" + in + (parse, Vmm_core.pp_bridge) + +let vm_c = + let parse s = `Ok (Vmm_core.id_of_string s) + in + (parse, Vmm_core.pp_id) + +let opt_vm_name = + let doc = "name of virtual machine." in + Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc) diff --git a/app/vmmc_local.ml b/app/vmmc_local.ml index 5816b4f..a741c71 100644 --- a/app/vmmc_local.ml +++ b/app/vmmc_local.ml @@ -117,21 +117,12 @@ let help _ _ man_format cmds = function | Some t when List.mem t cmds -> `Help (man_format, Some t) | Some _ -> List.iter print_endline cmds; `Ok () -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) - open Cmdliner - -let setup_log = - Term.(const setup_log - $ Fmt_cli.style_renderer () - $ Logs_cli.level ()) +open Vmm_cli let socket = let doc = "Socket to connect to" in - Arg.(value & opt (some string) None & info [ "s" ; "socket" ] ~doc) + Arg.(value & opt (some string) None & info [ "socket" ] ~doc) let force = let doc = "force VM creation." in @@ -141,11 +132,6 @@ let image = let doc = "File of virtual machine image." in Arg.(required & pos 1 (some file) None & info [] ~doc) -let vm_c = - let parse s = `Ok (Vmm_core.id_of_string s) - in - (parse, Vmm_core.pp_id) - let vm_name = let doc = "Name virtual machine." in Arg.(required & pos 0 (some vm_c) None & info [] ~doc) @@ -159,17 +145,13 @@ let destroy_cmd = Term.(ret (const destroy $ setup_log $ socket $ vm_name)), Term.info "destroy" ~doc ~man -let opt_vmname = - let doc = "Name virtual machine." in - Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc) - let remove_policy_cmd = let doc = "removes a policy" in let man = [`S "DESCRIPTION"; `P "Removes a policy."] in - Term.(ret (const remove_policy $ setup_log $ socket $ opt_vmname)), + Term.(ret (const remove_policy $ setup_log $ socket $ opt_vm_name)), Term.info "remove_policy" ~doc ~man let info_cmd = @@ -178,7 +160,7 @@ let info_cmd = [`S "DESCRIPTION"; `P "Shows information about VMs."] in - Term.(ret (const info_ $ setup_log $ socket $ opt_vmname)), + Term.(ret (const info_ $ setup_log $ socket $ opt_vm_name)), Term.info "info" ~doc ~man let policy_cmd = @@ -187,11 +169,11 @@ let policy_cmd = [`S "DESCRIPTION"; `P "Shows information about policies."] in - Term.(ret (const policy $ setup_log $ socket $ opt_vmname)), + Term.(ret (const policy $ setup_log $ socket $ opt_vm_name)), Term.info "policy" ~doc ~man let cpus = - let doc = "CPUids to allow" in + let doc = "CPUs to allow" in Arg.(value & opt_all int [] & info [ "cpu" ] ~doc) let vms = @@ -206,33 +188,9 @@ let mem = let doc = "Memory to allow" in Arg.(value & opt int 512 & info [ "mem" ] ~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 doc = "Bridge to allow" in + Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc) let add_policy_cmd = let doc = "Add a policy" in @@ -240,7 +198,7 @@ let add_policy_cmd = [`S "DESCRIPTION"; `P "Adds a policy."] in - Term.(ret (const add_policy $ setup_log $ socket $ opt_vmname $ vms $ mem $ cpus $ block $ bridge)), + Term.(ret (const add_policy $ setup_log $ socket $ opt_vm_name $ vms $ mem $ cpus $ block $ bridge)), Term.info "add_policy" ~doc ~man let cpu = @@ -294,7 +252,7 @@ let stats_cmd = [`S "DESCRIPTION"; `P "Shows statistics of VMs."] in - Term.(ret (const stats $ setup_log $ socket $ opt_vmname)), + Term.(ret (const stats $ setup_log $ socket $ opt_vm_name)), Term.info "stats" ~doc ~man let log_cmd = @@ -303,7 +261,7 @@ let log_cmd = [`S "DESCRIPTION"; `P "Shows event log of VM."] in - Term.(ret (const event_log $ setup_log $ socket $ opt_vmname $ since)), + Term.(ret (const event_log $ setup_log $ socket $ opt_vm_name $ since)), Term.info "log" ~doc ~man let help_cmd = diff --git a/app/vmmc_remote.ml b/app/vmmc_remote.ml index 5572a8f..5a717db 100644 --- a/app/vmmc_remote.ml +++ b/app/vmmc_remote.ml @@ -23,7 +23,6 @@ let client cas host port cert priv_key = Lwt_unix.gethostbyname host >>= fun host_entry -> let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in - Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ -> X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert -> let certificates = `Single cert in @@ -43,33 +42,8 @@ let run_client _ cas cert key (host, port) = Sys.(set_signal sigpipe Signal_ignore) ; Lwt_main.run (client cas host port cert key) -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 +open Vmm_cli let cas = let doc = "The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY." in @@ -88,13 +62,13 @@ let destination = ~doc:"the destination hostname:port to connect to") let cmd = - let doc = "VMM TLS client" in + let doc = "VMM remote TLS client" in let man = [ `S "DESCRIPTION" ; `P "$(tname) connects to a server and initiates a TLS handshake" ] in Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination), - Term.info "vmmd_remote" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "vmmc_remote" ~version:"%%VERSION_NUM%%" ~doc ~man let () = match Term.eval cmd diff --git a/app/vmmd.ml b/app/vmmd.ml index bb39ae4..300d209 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -51,7 +51,6 @@ let create process cont = | Ok () -> () let handle out fd addr = - (* out is for `Log | `Stat | `Cons (including reconnect semantics) *) Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ; (* now we need to read a packet and handle it (1) @@ -152,8 +151,6 @@ let rec stats_loop () = Lwt_unix.sleep 600. >>= fun () -> stats_loop () -(* TODO nobody reads stat and log file descriptors - that's likely a bad idea! - - create_mbox could after take & write do a read and check for failures! *) let jump _ = Sys.(set_signal sigpipe Signal_ignore) ; Lwt_main.run diff --git a/app/vmmd_console.ml b/app/vmmd_console.ml index 9f025ae..96a5383 100644 --- a/app/vmmd_console.ml +++ b/app/vmmd_console.ml @@ -170,22 +170,13 @@ let jump _ file = in loop ()) -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) - open Cmdliner -let setup_log = - Term.(const setup_log - $ Fmt_cli.style_renderer () - $ Logs_cli.level ()) +open Vmm_cli let socket = - let doc = "Socket to listen on" in - let sock = Vmm_core.socket_path `Console in - Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) + let doc = "socket to use" in + Arg.(value & opt string (Vmm_core.socket_path `Console) & info [ "socket" ] ~doc) let cmd = Term.(ret (const jump $ setup_log $ socket)), diff --git a/app/vmmd_influx.ml b/app/vmmd_influx.ml index 2170fec..22812bf 100644 --- a/app/vmmd_influx.ml +++ b/app/vmmd_influx.ml @@ -279,55 +279,24 @@ let run_client _ socket (influxhost, influxport) vm = Sys.(set_signal sigpipe Signal_ignore) ; Lwt_main.run (client socket influxhost influxport vm) -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) - open Cmdliner - -let setup_log = - Term.(const setup_log - $ Fmt_cli.style_renderer () - $ Logs_cli.level ()) - -let host_port : (string * int) Arg.converter = - let parse s = - match String.cut ~sep:":" s with - | None -> `Error "broken: no port specified" - | Some (hostname, port) -> - try - `Ok (hostname, int_of_string port) - with - Not_found -> `Error "failed to parse port" - in - parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p +open Vmm_cli let socket = - let doc = "Stat socket to connect onto" in - let sock = Vmm_core.socket_path `Stats in - Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) + let doc = "socket to use" in + Arg.(value & opt string (Vmm_core.socket_path `Stats) & info [ "socket" ] ~doc) let influx = Arg.(required & pos 0 (some host_port) None & info [] ~docv:"influx" ~doc:"the influx hostname:port to connect to") -let vm_c = - let parse s = `Ok (Vmm_core.id_of_string s) - in - (parse, Vmm_core.pp_id) - -let opt_vmname = - let doc = "Name virtual machine." in - Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc) - let cmd = let doc = "VMM InfluxDB connector" in let man = [ `S "DESCRIPTION" ; `P "$(tname) connects to a vmm stats socket, pulls statistics and pushes them via TCP to influxdb" ] in - Term.(pure run_client $ setup_log $ socket $ influx $ opt_vmname), + Term.(pure run_client $ setup_log $ socket $ influx $ opt_vm_name), Term.info "vmmd_influx" ~version:"%%VERSION_NUM%%" ~doc ~man let () = diff --git a/app/vmmd_log.ml b/app/vmmd_log.ml index 09f1b2a..969b688 100644 --- a/app/vmmd_log.ml +++ b/app/vmmd_log.ml @@ -71,8 +71,6 @@ let write_to_file file = in mvar, write_loop -let tree = ref Vmm_trie.empty - let send_history s ring id ts = let elements = match ts with @@ -96,6 +94,8 @@ let send_history s ring id ts = | Error e -> Lwt.return (Error e)) (Ok ()) (List.rev res) +let tree = ref Vmm_trie.empty + let handle_data s mvar ring hdr entry = if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin Logs.warn (fun m -> m "unsupported version") ; @@ -187,22 +187,12 @@ let jump _ file sock = Lwt.pick [ loop () ; writer () ]) ; `Ok () -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) - open Cmdliner - -let setup_log = - Term.(const setup_log - $ Fmt_cli.style_renderer () - $ Logs_cli.level ()) +open Vmm_cli let socket = - let doc = "Socket to listen on" in - let sock = Vmm_core.socket_path `Log in - Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) + let doc = "socket to use" in + Arg.(value & opt string (Vmm_core.socket_path `Log) & info [ "socket" ] ~doc) let file = let doc = "File to write the log to" in diff --git a/app/vmmd_stats.ml b/app/vmmd_stats.ml index dfe28d9..4f0e909 100644 --- a/app/vmmd_stats.ml +++ b/app/vmmd_stats.ml @@ -92,26 +92,16 @@ let jump _ file interval = in loop ()) -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) - open Cmdliner - -let setup_log = - Term.(const setup_log - $ Fmt_cli.style_renderer () - $ Logs_cli.level ()) +open Vmm_cli let socket = - let doc = "Socket to listen on" in - let sock = Vmm_core.socket_path `Stats in - Arg.(value & opt string sock & info [ "s" ; "socket" ] ~doc) + let doc = "socket to use" in + Arg.(value & opt string (Vmm_core.socket_path `Stats) & info [ "socket" ] ~doc) let interval = let doc = "Interval between statistics gatherings (in seconds)" in - Arg.(value & opt int 10 & info [ "internval" ] ~doc) + Arg.(value & opt int 10 & info [ "interval" ] ~doc) let cmd = Term.(ret (const jump $ setup_log $ socket $ interval)), diff --git a/app/vmmd_tls.ml b/app/vmmd_tls.ml index 6694efe..8de112f 100644 --- a/app/vmmd_tls.ml +++ b/app/vmmd_tls.ml @@ -135,19 +135,8 @@ let jump _ cacert cert priv_key port = 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 ()) - -(* TODO needs CRL as well, plus socket(s) *) +open Vmm_cli let cacert = let doc = "CA certificate" in diff --git a/app/vmmp_request.ml b/app/vmmp_request.ml index caa9110..8bb98c6 100644 --- a/app/vmmp_request.ml +++ b/app/vmmp_request.ml @@ -107,6 +107,7 @@ let jump _ name key vms mem cpus block bridges = | Error (`Msg m) -> `Error (false, m) open Cmdliner +open Vmm_cli let cpus = let doc = "CPUids to provision" in @@ -120,33 +121,9 @@ 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) + Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc) let cmd = Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)), From 1d999e47bfe6a2302812ea031b380a0ff7c607a4 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 26 Oct 2018 23:23:17 +0200 Subject: [PATCH 58/73] . --- app/vmmp_sign.ml | 44 +++++++++++++++++++++++++++++--------------- 1 file changed, 29 insertions(+), 15 deletions(-) diff --git a/app/vmmp_sign.ml b/app/vmmp_sign.ml index 6737d72..0a509eb 100644 --- a/app/vmmp_sign.ml +++ b/app/vmmp_sign.ml @@ -4,16 +4,24 @@ open Vmm_provision open Rresult.R.Infix -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 *) - (* TODO: check delegation! *) +let l_exts = + [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) + ; (true, `Basic_constraints (false, None)) + ; (true, `Ext_key_usage [`Client_auth]) ] + +let d_exts ?len () = + [ (true, (`Basic_constraints (true, len))) + ; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ] + +let s_exts = + [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) + ; (true, `Basic_constraints (false, None)) + ; (true, `Ext_key_usage [`Server_auth]) ] + +let albatross_extension csr = let req_exts = match - List.find (function `Extensions _ -> true | _ -> false) ri.X509.CA.extensions + List.find (function `Extensions _ -> true | _ -> false) X509.CA.((info csr).extensions) with | exception Not_found -> [] | `Extensions x -> x @@ -25,7 +33,18 @@ let sign dbname cacert key csr days = | _ -> false) req_exts with - | [ (_, `Unsupported (_, v)) as ext ] -> + | [ (_, `Unsupported (_, v)) as ext ] -> Ok (ext, v) + | _ -> Error (`Msg "couldn't find albatross extension in CSR") + +let sign dbname cacert key csr days = + let ri = X509.CA.info csr in + Logs.app (fun m -> m "signing certificate with subject %s" + (X509.distinguished_name_to_string ri.X509.CA.subject)) ; + let issuer = X509.subject cacert in + (* TODO: handle version mismatch of the delegation cert specially here *) + (* TODO: check delegation! *) + match albatross_extension csr with + | Ok (ext, v) -> Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) -> (if Vmm_commands.version_eq version asn_version then Ok () @@ -35,7 +54,7 @@ let sign dbname cacert key csr days = Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ; Ok (ext :: l_exts) >>= fun extensions -> sign ~dbname extensions issuer key csr (Duration.of_day days) - | _ -> Error (`Msg "none or multiple albatross extensions found") + | Error e -> Error e let jump _ db cacert cakey csrname days = Nocrypto_entropy_unix.initialize () ; @@ -76,11 +95,6 @@ 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 From 8f02d8263dc3e8664435e9e30a40b922de2d95a8 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 02:03:27 +0200 Subject: [PATCH 59/73] wip: vmmc_bistro --- _tags | 1 + app/vmm_provision.ml | 19 --- app/vmmc_bistro.ml | 333 +++++++++++++++++++++++++++++++++++++++++++ app/vmmd_log.ml | 16 +-- app/vmmp_request.ml | 74 +++++----- app/vmmp_sign.ml | 1 + src/vmm_lwt.ml | 25 ++++ src/vmm_lwt.mli | 2 + src/vmm_tls.ml | 15 +- 9 files changed, 412 insertions(+), 74 deletions(-) diff --git a/_tags b/_tags index 5080875..c992ea9 100644 --- a/_tags +++ b/_tags @@ -16,6 +16,7 @@ true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decomp : link_vmm_stats, package(asn1-combinators) : package(nocrypto tls.lwt nocrypto.lwt) +: package(nocrypto tls.lwt nocrypto.lwt) : package(nocrypto.unix ptime.clock.os x509) : package(nocrypto.unix ptime.clock.os x509) diff --git a/app/vmm_provision.ml b/app/vmm_provision.ml index 100ad6a..c079c15 100644 --- a/app/vmm_provision.ml +++ b/app/vmm_provision.ml @@ -2,20 +2,6 @@ let asn_version = `AV2 -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 timestamps validity = let now = Ptime_clock.now () in match Ptime.add_span now (Ptime.Span.of_int_s (Duration.to_sec validity)) with @@ -93,11 +79,6 @@ let priv_key ?(bits = 2048) fn name = open Cmdliner -let setup_log = - Term.(const setup_log - $ Fmt_cli.style_renderer () - $ Logs_cli.level ()) - let nam = let doc = "Name to provision" in Arg.(required & pos 0 (some string) None & info [] ~doc) diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml index e69de29..ecda976 100644 --- a/app/vmmc_bistro.ml +++ b/app/vmmc_bistro.ml @@ -0,0 +1,333 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix + +open Astring + +open Vmm_core + +let version = `AV2 + +let process fd = + Vmm_tls_lwt.read_tls fd >|= function + | Error _ -> + Error (`Msg "read or parse error") + | Ok (header, reply) -> + if Vmm_commands.version_eq header.Vmm_commands.version version then begin + Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) ; + Ok () + end else begin + Logs.err (fun m -> m "version not equal") ; + Error (`Msg "version not equal") + end + +let connect socket_path = + let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.set_close_on_exec c ; + Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> + c + +let read fd = + (* now we busy read and process output *) + let rec loop () = + process fd >>= function + | Error e -> Lwt.return (Error e) + | Ok () -> loop () + in + loop () + +let key_ids pub issuer = + let auth = (Some (X509.key_id issuer), [], None) in + [ (false, `Subject_key_id (X509.key_id pub)) ; (false, `Authority_key_id auth) ] + +let timestamps validity = + let now = Ptime_clock.now () in + match Ptime.add_span now (Ptime.Span.of_int_s validity) with + | None -> invalid_arg "span too big - reached end of ptime" + | Some exp -> (now, exp) + +let handle (host, port) cert key ca id (cmd : Vmm_commands.t) = + Vmm_lwt.read_from_file cert >>= fun cert_cs -> + let cert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 cert_cs in + Vmm_lwt.read_from_file key >>= fun key_cs -> + let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in + let tmpkey = Nocrypto.Rsa.generate 4096 in + let name = string_of_id id in + let extensions = + [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) + ; (true, `Basic_constraints (false, None)) + ; (true, `Ext_key_usage [`Client_auth]) ; + (false, `Unsupported (Vmm_asn.oid, Vmm_asn.cert_extension_to_cstruct (version, cmd))) ] in + let csr = + let name = [ `CN name ] in + X509.CA.request name ~extensions:[`Extensions extensions] (`RSA tmpkey) + in + let mycert = + let valid_from, valid_until = timestamps 300 in + let extensions = + let capub = match key with `RSA key -> Nocrypto.Rsa.pub_of_priv key in + extensions @ key_ids (X509.CA.info csr).X509.CA.public_key (`RSA capub) + in + let issuer = X509.subject cert in + X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer + in + let certificates = `Single ([ mycert ; cert ], tmpkey) in + X509_lwt.authenticator (`Ca_file ca) >>= fun authenticator -> + Lwt_unix.gethostbyname host >>= fun host_entry -> + let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in + let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in + Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ -> + let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in + Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t -> + read t + +let jump endp cert key ca name cmd = + match + Lwt_main.run (handle endp cert key ca name cmd) + with + | Ok () -> `Ok () + | Error (`Msg m) -> `Error (false, m) + +let info_ _ endp cert key ca name = jump endp cert key ca name (`Vm_cmd `Vm_info) + +let policy _ endp cert key ca name = jump endp cert key ca name (`Policy_cmd `Policy_info) + +let remove_policy _ endp cert key ca name = + jump endp cert key ca name (`Policy_cmd `Policy_remove) + +let add_policy _ endp cert key ca name vms memory cpus block bridges = + let bridges = match bridges with + | xs -> + let add m v = + let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in + String.Map.add n v m + in + List.fold_left add String.Map.empty xs + and cpuids = IS.of_list cpus + in + let policy = { vms ; cpuids ; memory ; block ; bridges } in + jump endp cert key ca name (`Policy_cmd (`Policy_add policy)) + +let destroy _ endp cert key ca name = + jump endp cert key ca name (`Vm_cmd `Vm_destroy) + +let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network = + let image' = match Bos.OS.File.read (Fpath.v image) with + | Ok data -> data + | Error (`Msg s) -> invalid_arg s + in + let argv = match boot_params with + | [] -> None + | xs -> Some xs + (* TODO we could do the compression btw *) + and vmimage = `Hvt_amd64, Cstruct.of_string image' + in + let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in + let cmd = + if force then + `Vm_force_create vm_config + else + `Vm_create vm_config + in + jump endp cert key ca name (`Vm_cmd cmd) + +let console _ endp cert key ca name since = + jump endp cert key ca name (`Console_cmd (`Console_subscribe since)) + +let stats _ endp cert key ca name = + jump endp cert key ca name (`Stats_cmd `Stats_subscribe) + +let event_log _ endp cert key ca name since = + jump endp cert key ca name (`Log_cmd (`Log_subscribe since)) + +let help _ _ man_format cmds = function + | None -> `Help (`Pager, None) + | Some t when List.mem t cmds -> `Help (man_format, Some t) + | Some _ -> List.iter print_endline cmds; `Ok () + +open Cmdliner +open Vmm_cli + +let server_ca = + let doc = "The certificate authority used to verify the remote server." in + Arg.(value & opt string "cacert.pem" & info [ "server-ca" ] ~doc) + +let ca_cert = + let doc = "The certificate authority used to issue the certificate" in + Arg.(value & opt string "ca.pem" & info [ "ca" ] ~doc) + +let ca_key = + let doc = "The private key of the signing certificate authority" in + Arg.(value & opt string "ca.key" & info [ "ca-key" ] ~doc) + +let destination = + Arg.(required & pos 0 (some host_port) None & info [] ~docv:"destination" + ~doc:"the destination hostname:port to connect to") + +let force = + let doc = "force VM creation." in + Arg.(value & flag & info [ "f" ; "force" ] ~doc) + +let image = + let doc = "File of virtual machine image." in + Arg.(required & pos 2 (some file) None & info [] ~doc) + +let vm_name = + let doc = "Name virtual machine." in + Arg.(required & pos 1 (some vm_c) None & info [] ~doc) + +let destroy_cmd = + let doc = "destroys a virtual machine" in + let man = + [`S "DESCRIPTION"; + `P "Destroy a virtual machine."] + in + Term.(ret (const destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name)), + Term.info "destroy" ~doc ~man + +let remove_policy_cmd = + let doc = "removes a policy" in + let man = + [`S "DESCRIPTION"; + `P "Removes a policy."] + in + Term.(ret (const remove_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), + Term.info "remove_policy" ~doc ~man + +let info_cmd = + let doc = "information about VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows information about VMs."] + in + Term.(ret (const info_ $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), + Term.info "info" ~doc ~man + +let policy_cmd = + let doc = "active policies" in + let man = + [`S "DESCRIPTION"; + `P "Shows information about policies."] + in + Term.(ret (const policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), + Term.info "policy" ~doc ~man + +let cpus = + let doc = "CPUs to allow" in + Arg.(value & opt_all int [] & info [ "cpu" ] ~doc) + +let vms = + let doc = "Number of VMs to allow" in + Arg.(required & pos 0 (some int) None & info [] ~doc) + +let block = + let doc = "Block storage to allow" in + Arg.(value & opt (some int) None & info [ "block" ] ~doc) + +let mem = + let doc = "Memory to allow" in + Arg.(value & opt int 512 & info [ "mem" ] ~doc) + +let bridge = + let doc = "Bridge to allow" in + Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc) + +let add_policy_cmd = + let doc = "Add a policy" in + let man = + [`S "DESCRIPTION"; + `P "Adds a policy."] + in + Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ vms $ mem $ cpus $ block $ bridge)), + Term.info "add_policy" ~doc ~man + +let cpu = + let doc = "CPUid" in + Arg.(value & opt int 0 & info [ "cpu" ] ~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 create_cmd = + let doc = "creates a virtual machine" in + let man = + [`S "DESCRIPTION"; + `P "Creates a virtual machine."] + in + Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), + Term.info "create" ~doc ~man + +let timestamp_c = + let parse s = match Ptime.of_rfc3339 s with + | Ok (t, _, _) -> `Ok t + | Error _ -> `Error "couldn't parse timestamp" + in + (parse, Ptime.pp_rfc3339 ()) + +let since = + let doc = "Since" in + Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc) + +let console_cmd = + let doc = "console of a VM" in + let man = + [`S "DESCRIPTION"; + `P "Shows console output of a VM."] + in + Term.(ret (const console $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ since)), + Term.info "console" ~doc ~man + +let stats_cmd = + let doc = "statistics of VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows statistics of VMs."] + in + Term.(ret (const stats $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), + Term.info "stats" ~doc ~man + +let log_cmd = + let doc = "Event log" in + let man = + [`S "DESCRIPTION"; + `P "Shows event log of VM."] + in + Term.(ret (const event_log $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ since)), + Term.info "log" ~doc ~man + +let help_cmd = + let topic = + let doc = "The topic to get help on. `topics' lists the topics." in + Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) + in + let doc = "display help about vmmc" in + let man = + [`S "DESCRIPTION"; + `P "Prints help about conex commands and subcommands"] + in + Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ topic)), + Term.info "help" ~doc ~man + +let default_cmd = + let doc = "VMM client and go to bistro" in + let man = [ + `S "DESCRIPTION" ; + `P "$(tname) executes the provided subcommand on a remote albatross" ] + in + Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)), + Term.info "vmmc_bistro" ~version:"%%VERSION_NUM%%" ~doc ~man + +let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] + +let () = + match Term.eval_choice default_cmd cmds + with `Ok () -> exit 0 | _ -> exit 1 diff --git a/app/vmmd_log.ml b/app/vmmd_log.ml index 969b688..d668c11 100644 --- a/app/vmmd_log.ml +++ b/app/vmmd_log.ml @@ -30,20 +30,8 @@ let write_complete s cs = w 0 let read_from_file file = - Lwt_unix.stat file >>= fun stat -> - let size = stat.Lwt_unix.st_size in - Lwt_unix.openfile file Lwt_unix.[O_RDONLY] 0 >>= fun fd -> - let buf = Bytes.create size in - let rec read off = - Lwt_unix.read fd buf off (size - off) >>= fun bytes -> - if bytes + off = size then - Lwt.return_unit - else - read (bytes + off) - in - read 0 >>= fun () -> - let logs = Vmm_asn.logs_of_disk my_version (Cstruct.of_bytes buf) in - Vmm_lwt.safe_close fd >|= fun () -> + Vmm_lwt.read_from_file file >|= fun data -> + let logs = Vmm_asn.logs_of_disk my_version data in List.rev logs let write_to_file file = diff --git a/app/vmmp_request.ml b/app/vmmp_request.ml index 8bb98c6..92765d8 100644 --- a/app/vmmp_request.ml +++ b/app/vmmp_request.ml @@ -36,43 +36,8 @@ let jump _ name key image mem cpu args block net force compression = | Ok () -> `Ok () | Error (`Msg m) -> `Error (false, m) -open Cmdliner - -let cpu = - let doc = "CPUid" in - Arg.(required & pos 3 (some int) None & info [] ~doc) - -let image = - let doc = "Image file to provision" in - Arg.(required & pos 1 (some file) None & info [] ~doc) - -let args = - let doc = "Boot arguments" in - Arg.(value & opt_all string [] & info [ "arg" ] ~doc) - -let block = - let doc = "Block device name" in - Arg.(value & opt (some string) None & info [ "block" ] ~doc) - -let net = - let doc = "Network device" in - Arg.(value & opt_all string [] & info [ "net" ] ~doc) - -let force = - let doc = "Force creation (destroy VM with same name if it exists)" in - Arg.(value & flag & info [ "force" ] ~doc) - -let compress_level = - let doc = "Compression level (0 for no compression)" in - Arg.(value & opt int 4 & info [ "compression-level" ] ~doc) - -let cmd = - Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)), - Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" - -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 (* (c) 2017 Hannes Mehnert, all rights reserved *) - +(* open Vmm_provision open Vmm_asn @@ -129,4 +94,41 @@ let cmd = Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)), Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 + *) +open Cmdliner +open Vmm_cli + +let cpu = + let doc = "CPUid" in + Arg.(required & pos 3 (some int) None & info [] ~doc) + +let image = + let doc = "Image file to provision" in + Arg.(required & pos 1 (some file) None & info [] ~doc) + +let args = + let doc = "Boot arguments" in + Arg.(value & opt_all string [] & info [ "arg" ] ~doc) + +let block = + let doc = "Block device name" in + Arg.(value & opt (some string) None & info [ "block" ] ~doc) + +let net = + let doc = "Network device" in + Arg.(value & opt_all string [] & info [ "net" ] ~doc) + +let force = + let doc = "Force creation (destroy VM with same name if it exists)" in + Arg.(value & flag & info [ "force" ] ~doc) + +let compress_level = + let doc = "Compression level (0 for no compression)" in + Arg.(value & opt int 4 & info [ "compression-level" ] ~doc) + +let cmd = + Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)), + Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" + let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/app/vmmp_sign.ml b/app/vmmp_sign.ml index 0a509eb..525d4e3 100644 --- a/app/vmmp_sign.ml +++ b/app/vmmp_sign.ml @@ -71,6 +71,7 @@ let jump _ db cacert cakey csrname days = | Error (`Msg e) -> `Error (false, e) open Cmdliner +open Vmm_cli let csr = let doc = "signing request" in diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml index fc59ec8..d8ab4bc 100644 --- a/src/vmm_lwt.ml +++ b/src/vmm_lwt.ml @@ -105,3 +105,28 @@ let safe_close fd = Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) + +let read_from_file file = + Lwt.catch (fun () -> + Lwt_unix.stat file >>= fun stat -> + let size = stat.Lwt_unix.st_size in + Lwt_unix.openfile file Lwt_unix.[O_RDONLY] 0 >>= fun fd -> + Lwt.catch (fun () -> + let buf = Bytes.create size in + let rec read off = + Lwt_unix.read fd buf off (size - off) >>= fun bytes -> + if bytes + off = size then + Lwt.return_unit + else + read (bytes + off) + in + read 0 >>= fun () -> + safe_close fd >|= fun () -> + Cstruct.of_bytes buf) + (fun e -> + Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ; + safe_close fd >|= fun () -> + Cstruct.empty)) + (fun e -> + Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ; + Lwt.return Cstruct.empty) diff --git a/src/vmm_lwt.mli b/src/vmm_lwt.mli index ae7445e..c4a9416 100644 --- a/src/vmm_lwt.mli +++ b/src/vmm_lwt.mli @@ -20,3 +20,5 @@ val write_wire : Lwt_unix.file_descr -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t val safe_close : Lwt_unix.file_descr -> unit Lwt.t + +val read_from_file : string -> Cstruct.t Lwt.t diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 2000cb7..581ba25 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -3,7 +3,13 @@ open Rresult open Rresult.R.Infix -let name cert = X509.common_name_to_string cert +(* we skip all non-albatross certificates *) +let name chain = + List.fold_left (fun acc cert -> + match X509.Extension.unsupported cert Vmm_asn.oid with + | None -> acc + | Some _ -> X509.common_name_to_string cert :: acc) + [] chain (* this separates the leaf and top-level certificate from the chain, and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA') @@ -39,13 +45,12 @@ let wire_command_of_cert version cert = *) let handle _addr version chain = - separate_chain chain >>= fun (leaf, chain) -> - let prefix = List.map name chain in - let name = prefix @ [ name leaf ] in + separate_chain chain >>= fun (leaf, rest) -> + let name = name chain in 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)) ; + (List.map X509.common_name_to_string rest)) ; (* TODO: inspect top-level-cert of chain. *) (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) (* TODO: update policies (parse chain for policy, and apply them)! *) From ea6b291ad075a164b16cf892c1d7f4ddf0662df8 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 18:30:02 +0100 Subject: [PATCH 60/73] vmmp_ca work --- README.md | 2 +- _tags | 2 +- app/{vmmp_sign.ml => vmmp_ca.ml} | 115 +++++++++++++++++++------------ pkg/pkg.ml | 2 +- 4 files changed, 74 insertions(+), 47 deletions(-) rename app/{vmmp_sign.ml => vmmp_ca.ml} (57%) diff --git a/README.md b/README.md index 47b41ab..502acc2 100644 --- a/README.md +++ b/README.md @@ -16,7 +16,7 @@ Command-line applications for local and remote management are provided as well - `vmmc_remote`: connects to `vmm_tls_endpoint` and executes command - `vmmc_bistro`: command line utility to execute a command remotely: request, sign, remote (do not use in production, requires CA key on host) - `vmmp_request`: creates a certificate signing request containing a command -- `vmmp_sign`: signs a certificate signing request +- `vmmp_ca`: certificate authority operations: sign, generate (and revoke) Please read [the blog article](https://hannes.nqsb.io/Posts/VMM) for motivation and an overview. diff --git a/_tags b/_tags index c992ea9..484b388 100644 --- a/_tags +++ b/_tags @@ -19,7 +19,7 @@ true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decomp : package(nocrypto tls.lwt nocrypto.lwt) : package(nocrypto.unix ptime.clock.os x509) -: package(nocrypto.unix ptime.clock.os x509) +: package(nocrypto.unix ptime.clock.os x509) : package(nocrypto.unix ptime.clock.os x509) diff --git a/app/vmmp_sign.ml b/app/vmmp_ca.ml similarity index 57% rename from app/vmmp_sign.ml rename to app/vmmp_ca.ml index 525d4e3..9e3d65d 100644 --- a/app/vmmp_sign.ml +++ b/app/vmmp_ca.ml @@ -1,6 +1,4 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -open Vmm_provision +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) open Rresult.R.Infix @@ -46,17 +44,18 @@ let sign dbname cacert key csr days = match albatross_extension csr with | Ok (ext, v) -> Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) -> - (if Vmm_commands.version_eq version asn_version then + (if Vmm_commands.version_eq version version then Ok () else Error (`Msg "unknown version in request")) >>= fun () -> (* TODO l_exts / d_exts trouble *) Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ; Ok (ext :: l_exts) >>= fun extensions -> - sign ~dbname extensions issuer key csr (Duration.of_day days) + Vmm_provision.sign ~dbname extensions issuer key csr (Duration.of_day days) | Error e -> Error e -let jump _ db cacert cakey csrname days = +let sign _ db cacert cakey csrname days = + let days = match days with None -> 1 | Some x -> x in Nocrypto_entropy_unix.initialize () ; match Bos.OS.File.read (Fpath.v cacert) >>= fun cacert -> @@ -70,6 +69,27 @@ let jump _ db cacert cakey csrname days = | Ok () -> `Ok () | Error (`Msg e) -> `Error (false, e) +let help _ man_format cmds = function + | None -> `Help (`Pager, None) + | Some t when List.mem t cmds -> `Help (man_format, Some t) + | Some _ -> List.iter print_endline cmds; `Ok () + +let generate _ name db days sname sdays = + let days = match days with None -> 3650 | Some x -> x in + Nocrypto_entropy_unix.initialize () ; + match + Vmm_provision.priv_key ~bits:4096 None name >>= fun key -> + let name = [ `CN name ] in + let csr = X509.CA.request name key in + Vmm_provision.sign ~certname:"cacert" (d_exts ()) name key csr (Duration.of_day days) >>= fun () -> + Vmm_provision.priv_key None sname >>= fun skey -> + let sname = [ `CN sname ] in + let csr = X509.CA.request sname skey in + Vmm_provision.sign ~dbname:(Fpath.v db) s_exts name key csr (Duration.of_day sdays) + with + | Ok () -> `Ok () + | Error (`Msg e) -> `Error (false, e) + open Cmdliner open Vmm_cli @@ -77,46 +97,13 @@ 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 "vmmp_sign" ~version:"%%VERSION_NUM%%" - -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 -(* (c) 2017 Hannes Mehnert, all rights reserved *) - -open Vmm_provision - -open Rresult.R.Infix - -let 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) + Arg.(value & opt (some int) None & info [ "days" ] ~doc) let db = let doc = "Database" in @@ -130,8 +117,48 @@ let sday = let doc = "Server validity" in Arg.(value & opt int 365 & info [ "server-days" ] ~doc) -let cmd = - Term.(ret (const jump $ setup_log $ nam $ db $ days $ sname $ sday)), - Term.info "vmmp_sign" ~version:"%%VERSION_NUM%%" +let generate_cmd = + let doc = "generates a certificate authority" in + let man = + [`S "DESCRIPTION"; + `P "Generates a certificate authority."] + in + Term.(ret (const generate $ setup_log $ Vmm_provision.nam $ db $ days $ sname $ sday)), + Term.info "generate" ~doc ~man -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 +let sign_cmd = + let doc = "sign a request" in + let man = + [`S "DESCRIPTION"; + `P "Signs the certificate signing request."] + in + Term.(ret (const sign $ setup_log $ db $ Vmm_provision.cacert $ key $ csr $ days)), + Term.info "sign" ~doc ~man + +let help_cmd = + let topic = + let doc = "The topic to get help on. `topics' lists the topics." in + Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) + in + let doc = "display help about vmmp_sign" in + let man = + [`S "DESCRIPTION"; + `P "Prints help about commands and subcommands"] + in + Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ topic)), + Term.info "help" ~doc ~man + +let default_cmd = + let doc = "VMM " in + let man = [ + `S "DESCRIPTION" ; + `P "$(tname) executes the provided subcommand on a remote albatross" ] + in + Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)), + Term.info "vmmp_ca" ~version:"%%VERSION_NUM%%" ~doc ~man + +let cmds = [ help_cmd ; sign_cmd ; generate_cmd ; (* TODO revoke_cmd *)] + +let () = + match Term.eval_choice default_cmd cmds + with `Ok () -> exit 0 | _ -> exit 1 diff --git a/pkg/pkg.ml b/pkg/pkg.ml index 97a095f..d9df305 100644 --- a/pkg/pkg.ml +++ b/pkg/pkg.ml @@ -16,5 +16,5 @@ let () = Pkg.bin "app/vmmc_remote" ; Pkg.bin "app/vmmc_bistro" ; Pkg.bin "app/vmmp_request" ; - Pkg.bin "app/vmmp_sign" ; + Pkg.bin "app/vmmp_ca" ; ] From 5e921d73453983e9746cefd197a17bf5e517d905 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 19:04:24 +0100 Subject: [PATCH 61/73] skip empty common names in vmm_tls --- src/vmm_core.ml | 2 +- src/vmm_resources.ml | 7 +++++++ src/vmm_resources.mli | 3 +++ src/vmm_tls.ml | 8 +++++++- 4 files changed, 18 insertions(+), 2 deletions(-) diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 63abb84..43243ee 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -61,7 +61,7 @@ let domain id = match List.rev id with | [] -> [] let pp_id ppf ids = - Fmt.(pf ppf "%a" (list ~sep:(unit ".") string) ids) + Fmt.(pf ppf "(%d)%a" (List.length ids) (list ~sep:(unit ".") string) ids) let pp_is ppf is = Fmt.pf ppf "%a" Fmt.(list ~sep:(unit ",") int) (IS.elements is) diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index e9459d8..abb37f1 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -27,6 +27,13 @@ type entry = type t = entry Vmm_trie.t +let pp ppf t = + Vmm_trie.fold [] t + (fun id ele () -> match ele with + | Vm vm -> Fmt.pf ppf "vm %a: %a@." pp_id id pp_vm_config vm.config + | Policy p -> Fmt.pf ppf "policy %a: %a@." pp_id id pp_policy p) + () + let empty = Vmm_trie.empty let remove t name = Vmm_trie.remove name t diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index d41d64a..aa5a162 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -39,3 +39,6 @@ val remove : t -> Vmm_core.id -> t val fold : t -> Vmm_core.id -> (Vmm_core.id -> Vmm_core.vm -> 'a -> 'a) -> (Vmm_core.id -> Vmm_core.policy -> 'a -> 'a) -> 'a -> 'a + +(** [pp] is a pretty printer for [t]. *) +val pp : t Fmt.t diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 581ba25..df68224 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -8,7 +8,13 @@ let name chain = List.fold_left (fun acc cert -> match X509.Extension.unsupported cert Vmm_asn.oid with | None -> acc - | Some _ -> X509.common_name_to_string cert :: acc) + | Some _ -> + let data = X509.common_name_to_string cert in + (* if the common name is empty, skip [useful for vmmc_bistro at least] + TODO: document properly and investigate potential security issue with + multi-tenant system (likely ca should ensure to never sign a delegation + with empty common name) *) + if data = "" then acc else data :: acc) [] chain (* this separates the leaf and top-level certificate from the chain, From 296b7a9b01f166ee2917904ee460602b538be797 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 19:19:38 +0100 Subject: [PATCH 62/73] vmmd_tls: close sockets appropriately --- app/vmmd_tls.ml | 14 ++++++++++---- src/vmm_tls_lwt.ml | 5 +++++ src/vmm_tls_lwt.mli | 2 ++ 3 files changed, 17 insertions(+), 4 deletions(-) diff --git a/app/vmmd_tls.ml b/app/vmmd_tls.ml index 8de112f..49f8b8c 100644 --- a/app/vmmd_tls.ml +++ b/app/vmmd_tls.ml @@ -30,12 +30,12 @@ let client_auth ca tls addr = | Tls_lwt.Tls_alert a -> Logs.err (fun m -> m "TLS ALERT %s" (Tls.Packet.alert_type_to_string a)) | Tls_lwt.Tls_failure f -> Logs.err (fun m -> m "TLS FAILURE %s" (Tls.Engine.string_of_failure f)) | exn -> Logs.err (fun m -> m "%s" (Printexc.to_string exn))) ; - Tls_lwt.Unix.close tls >>= fun () -> + Vmm_tls_lwt.close tls >>= fun () -> Lwt.fail e) >>= fun () -> (match Tls_lwt.Unix.epoch tls with | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain | `Error -> - Tls_lwt.Unix.close tls >>= fun () -> + Vmm_tls_lwt.close tls >>= fun () -> Lwt.fail_with "error while getting epoch") let read fd tls = @@ -63,7 +63,9 @@ let process fd tls = let handle ca (tls, addr) = client_auth ca tls addr >>= fun chain -> match Vmm_tls.handle addr my_version chain with - | Error (`Msg m) -> Lwt.fail_with m + | Error (`Msg m) -> + Vmm_tls_lwt.close tls >>= fun () -> + Lwt.fail_with m | Ok (name, cmd) -> let sock, next = Vmm_commands.endpoint cmd in connect (Vmm_core.socket_path sock) >>= fun fd -> @@ -73,11 +75,15 @@ let handle ca (tls, addr) = (header, `Command cmd) in Vmm_lwt.write_wire fd wire >>= function - | Error `Exception -> Lwt.return (Error (`Msg "couldn't write")) + | Error `Exception -> + Vmm_tls_lwt.close tls >>= fun () -> + Vmm_lwt.safe_close fd >>= fun () -> + Lwt.return (Error (`Msg "couldn't write")) | Ok () -> (match next with | `Read -> read fd tls | `End -> process fd tls) >>= fun res -> + Vmm_tls_lwt.close tls >>= fun () -> Vmm_lwt.safe_close fd >|= fun () -> res diff --git a/src/vmm_tls_lwt.ml b/src/vmm_tls_lwt.ml index 4bd3daf..51c74d9 100644 --- a/src/vmm_tls_lwt.ml +++ b/src/vmm_tls_lwt.ml @@ -62,3 +62,8 @@ let write_tls s wire = | e -> Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ; Lwt.return (Error `Exception)) + +let close tls = + Lwt.catch + (fun () -> Tls_lwt.Unix.close tls) + (fun _ -> Lwt.return_unit) diff --git a/src/vmm_tls_lwt.mli b/src/vmm_tls_lwt.mli index 39886d6..bf6762d 100644 --- a/src/vmm_tls_lwt.mli +++ b/src/vmm_tls_lwt.mli @@ -5,3 +5,5 @@ val read_tls : Tls_lwt.Unix.t -> val write_tls : Tls_lwt.Unix.t -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t + +val close : Tls_lwt.Unix.t -> unit Lwt.t From 7b8f2cf80283c0ddf876c5d8a20b7312433b727a Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 19:41:06 +0100 Subject: [PATCH 63/73] add policy does nothing when received policy is equal to stored one --- src/vmm_core.ml | 26 ++++++++++++++++++++++++++ src/vmm_core.mli | 6 ++++++ src/vmm_resources.ml | 4 ++++ src/vmm_resources.mli | 3 +++ src/vmm_vmmd.ml | 11 +++++++++-- 5 files changed, 48 insertions(+), 2 deletions(-) diff --git a/src/vmm_core.ml b/src/vmm_core.ml index 43243ee..1edf505 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -70,6 +70,20 @@ type bridge = [ | `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int ] +let eq_int (a : int) (b : int) = a = b + +let eq_bridge b1 b2 = match b1, b2 with + | `Internal a, `Internal a' -> String.equal a a' + | `External (name, ip_start, ip_end, ip_gw, netmask), + `External (name', ip_start', ip_end', ip_gw', netmask') -> + let eq_ip a b = Ipaddr.V4.compare a b = 0 in + String.equal name name' && + eq_ip ip_start ip_start' && + eq_ip ip_end ip_end' && + eq_ip ip_gw ip_gw' && + eq_int netmask netmask' + | _ -> false + let pp_bridge ppf = function | `Internal name -> Fmt.pf ppf "%s (internal)" name | `External (name, l, h, gw, nm) -> @@ -84,6 +98,18 @@ type policy = { bridges : bridge String.Map.t ; } +let eq_policy p1 p2 = + let eq_opt a b = match a, b with + | None, None -> true + | Some a, Some b -> eq_int a b + | _ -> false + in + eq_int p1.vms p2.vms && + IS.equal p1.cpuids p2.cpuids && + eq_int p1.memory p2.memory && + eq_opt p1.block p2.block && + String.Map.equal eq_bridge p1.bridges p2.bridges + let pp_policy ppf res = Fmt.pf ppf "policy: %d vms %a cpus %d MB memory %a MB block bridges: %a" res.vms pp_is res.cpuids res.memory diff --git a/src/vmm_core.mli b/src/vmm_core.mli index a464914..0db3d44 100644 --- a/src/vmm_core.mli +++ b/src/vmm_core.mli @@ -30,6 +30,9 @@ val pp_id : id Fmt.t type bridge = [ `External of string * Ipaddr.V4.t * Ipaddr.V4.t * Ipaddr.V4.t * int | `Internal of string ] + +val eq_bridge : bridge -> bridge -> bool + val pp_bridge : bridge Fmt.t type policy = { @@ -39,6 +42,9 @@ type policy = { block : int option; bridges : bridge Astring.String.Map.t; } + +val eq_policy : policy -> policy -> bool + val pp_policy : policy Fmt.t val sub_bridges : bridge Astring.String.map -> bridge Astring.String.map -> bool diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index abb37f1..0bfdd3a 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -58,6 +58,10 @@ let find_vm t name = match Vmm_trie.find name t with | Some (Vm vm) -> Some vm | _ -> None +let find_policy t name = match Vmm_trie.find name t with + | Some (Policy p) -> Some p + | _ -> None + let check_vm_policy t name vm = let dom = domain name in let res = resource_usage t dom in diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index aa5a162..607e6eb 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -20,6 +20,9 @@ val empty : t (** [find_vm t id] is either [Some vm] or [None]. *) val find_vm : t -> Vmm_core.id -> Vmm_core.vm option +(** [find_policy t id] is either [Some policy] or [None]. *) +val find_policy : t -> Vmm_core.id -> Vmm_core.policy option + (** [check_vm_policy t vm] checks whether [vm] under [id] in [t] would be allowed under the current policies. *) val check_vm_policy : t -> Vmm_core.id -> Vmm_core.vm_config -> bool diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index 8976260..33e813c 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -107,8 +107,15 @@ let handle_command t (header, payload) = Ok ({ t with resources }, [ reply (`String "removed policy") ], `End) | `Policy_add policy -> Logs.debug (fun m -> m "insert policy %a" pp_id id) ; - Vmm_resources.insert_policy t.resources id policy >>= fun resources -> - Ok ({ t with resources }, [ reply (`String "added policy") ], `End) + let same_policy = match Vmm_resources.find_policy t.resources id with + | None -> false + | Some p' -> eq_policy policy p' + in + if same_policy then + Ok (t, [ reply (`String "no modification of policy") ], `End) + else + Vmm_resources.insert_policy t.resources id policy >>= fun resources -> + Ok ({ t with resources }, [ reply (`String "added policy") ], `End) | `Policy_info -> begin Logs.debug (fun m -> m "policy %a" pp_id id) ; From 8ab37d6b3b1737cf826b54282f514ed324c54df6 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 19:50:48 +0100 Subject: [PATCH 64/73] resources: remove_vm and remove_policy - no need to intertwine into a single remove --- src/vmm_resources.ml | 10 ++++++++-- src/vmm_resources.mli | 7 +++++-- src/vmm_vmmd.ml | 11 ++++++++--- 3 files changed, 21 insertions(+), 7 deletions(-) diff --git a/src/vmm_resources.ml b/src/vmm_resources.ml index 0bfdd3a..4df3791 100644 --- a/src/vmm_resources.ml +++ b/src/vmm_resources.ml @@ -36,8 +36,6 @@ let pp ppf t = let empty = Vmm_trie.empty -let remove t name = Vmm_trie.remove name t - let fold t name f g acc = Vmm_trie.fold name t (fun prefix entry acc -> match entry with @@ -62,6 +60,14 @@ let find_policy t name = match Vmm_trie.find name t with | Some (Policy p) -> Some p | _ -> None +let remove_vm t name = match find_vm t name with + | None -> Error (`Msg "unknown vm") + | Some _ -> Ok (Vmm_trie.remove name t) + +let remove_policy t name = match find_policy t name with + | None -> Error (`Msg "unknown policy") + | Some _ -> Ok (Vmm_trie.remove name t) + let check_vm_policy t name vm = let dom = domain name in let res = resource_usage t dom in diff --git a/src/vmm_resources.mli b/src/vmm_resources.mli index 607e6eb..a0eb877 100644 --- a/src/vmm_resources.mli +++ b/src/vmm_resources.mli @@ -35,8 +35,11 @@ val insert_vm : t -> Vmm_core.id -> Vmm_core.vm -> (t, [> `Msg of string]) resul the new [t] or an error. *) val insert_policy : t -> Vmm_core.id -> Vmm_core.policy -> (t, [> `Msg of string]) result -(** [remove t id] removes [id] from [t]. *) -val remove : t -> Vmm_core.id -> t +(** [remove_vm t id] removes vm [id] from [t]. *) +val remove_vm : t -> Vmm_core.id -> (t, [> `Msg of string ]) result + +(** [remove_policy t id] removes policy [id] from [t]. *) +val remove_policy : t -> Vmm_core.id -> (t, [> `Msg of string ]) result (** [fold t id f g acc] folds [f] and [g] below [id] over [t]. *) val fold : t -> Vmm_core.id -> diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index 33e813c..fd6cead 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -80,7 +80,12 @@ let handle_shutdown t name vm r = (match Vmm_unix.shutdown name vm with | Ok () -> () | Error (`Msg e) -> Logs.warn (fun m -> m "%s while shutdown vm %a" e pp_vm vm)) ; - let resources = Vmm_resources.remove t.resources name in + let resources = match Vmm_resources.remove_vm t.resources name with + | Error (`Msg e) -> + Logs.warn (fun m -> m "%s while removing vm %a from resources" e pp_vm vm) ; + t.resources + | Ok resources -> resources + in let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; id = name } in let tasks = String.Map.remove (string_of_id name) t.tasks in let t = { t with stats_counter = Int64.succ t.stats_counter ; resources ; tasks } in @@ -103,7 +108,7 @@ let handle_command t (header, payload) = begin match pc with | `Policy_remove -> Logs.debug (fun m -> m "remove policy %a" pp_id header.Vmm_commands.id) ; - let resources = Vmm_resources.remove t.resources id in + Vmm_resources.remove_policy t.resources id >>= fun resources -> Ok ({ t with resources }, [ reply (`String "removed policy") ], `End) | `Policy_add policy -> Logs.debug (fun m -> m "insert policy %a" pp_id id) ; @@ -153,7 +158,7 @@ let handle_command t (header, payload) = | `Vm_create vm_config -> handle_create t header vm_config | `Vm_force_create vm_config -> - let resources = Vmm_resources.remove t.resources id in + Vmm_resources.remove_vm t.resources id >>= fun resources -> if Vmm_resources.check_vm_policy resources id vm_config then begin match Vmm_resources.find_vm t.resources id with | None -> handle_create t header vm_config From 6677e3f1cb42b7c05bce092a90da3373687a3940 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 20:49:42 +0100 Subject: [PATCH 65/73] close on exit for vmmd.sock --- app/vmmd.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/app/vmmd.ml b/app/vmmd.ml index 300d209..74597f8 100644 --- a/app/vmmd.ml +++ b/app/vmmd.ml @@ -142,6 +142,7 @@ let server_socket sock = | true -> Lwt_unix.unlink name | false -> Lwt.return_unit) >>= fun () -> let s = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.set_close_on_exec s ; Lwt_unix.(bind s (ADDR_UNIX name)) >|= fun () -> Lwt_unix.listen s 1 ; s From 40519afbb7b21bcb6dc4a0d75ae72fc72e7511ec Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 20:50:10 +0100 Subject: [PATCH 66/73] issue policy_add commands by vmmd_tls for certificate chain --- app/vmmd_tls.ml | 68 ++++++++++++++++++++++++++++---------- src/vmm_tls.ml | 86 +++++++++++++++++++++++++++++++++---------------- src/vmm_tls.mli | 5 +-- 3 files changed, 113 insertions(+), 46 deletions(-) diff --git a/app/vmmd_tls.ml b/app/vmmd_tls.ml index 49f8b8c..2d5cc65 100644 --- a/app/vmmd_tls.ml +++ b/app/vmmd_tls.ml @@ -55,6 +55,7 @@ let process fd tls = Vmm_lwt.read_wire fd >>= function | Error _ -> Lwt.return (Error (`Msg "read error")) | Ok wire -> + (* TODO check version *) Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ; Vmm_tls_lwt.write_tls tls wire >|= function | Ok () -> Ok () @@ -66,26 +67,59 @@ let handle ca (tls, addr) = | Error (`Msg m) -> Vmm_tls_lwt.close tls >>= fun () -> Lwt.fail_with m - | Ok (name, cmd) -> + | Ok (name, policies, cmd) -> let sock, next = Vmm_commands.endpoint cmd in connect (Vmm_core.socket_path sock) >>= fun fd -> - let wire = - let header = Vmm_commands.{version = my_version ; sequence = !command ; id = name } in - command := Int64.succ !command ; - (header, `Command cmd) - in - Vmm_lwt.write_wire fd wire >>= function - | Error `Exception -> - Vmm_tls_lwt.close tls >>= fun () -> - Vmm_lwt.safe_close fd >>= fun () -> - Lwt.return (Error (`Msg "couldn't write")) + (match sock with + | `Vmmd -> + Lwt_list.fold_left_s (fun r (id, policy) -> + match r with + | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) + | Ok () -> + Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.pp_id id Vmm_core.pp_policy policy) ; + let header = Vmm_commands.{version = my_version ; sequence = !command ; id } in + command := Int64.succ !command ; + Vmm_lwt.write_wire fd (header, `Command (`Policy_cmd (`Policy_add policy))) >>= function + | Error `Exception -> Lwt.return (Error (`Msg "failed to write policy")) + | Ok () -> + Vmm_lwt.read_wire fd >|= function + | Error _ -> Error (`Msg "read error") + | Ok (_, `Success _) -> Ok () + | Ok _ -> + (* TODO check version *) + Error (`Msg ("expected success, received something else when adding policy"))) + (Ok ()) policies + | _ -> Lwt.return (Ok ())) >>= function + | Error (`Msg msg) -> + begin + Logs.debug (fun m -> m "error while applying policies %s" msg) ; + let wire = + let header = Vmm_commands.{version = my_version ; sequence = 0L ; id = name } in + header, `Failure msg + in + Vmm_tls_lwt.write_tls tls wire >>= fun _ -> + Vmm_tls_lwt.close tls >>= fun () -> + Vmm_lwt.safe_close fd >>= fun () -> + Lwt.fail_with msg + end | Ok () -> - (match next with - | `Read -> read fd tls - | `End -> process fd tls) >>= fun res -> - Vmm_tls_lwt.close tls >>= fun () -> - Vmm_lwt.safe_close fd >|= fun () -> - res + let wire = + let header = Vmm_commands.{version = my_version ; sequence = !command ; id = name } in + command := Int64.succ !command ; + (header, `Command cmd) + in + Vmm_lwt.write_wire fd wire >>= function + | Error `Exception -> + Vmm_tls_lwt.close tls >>= fun () -> + Vmm_lwt.safe_close fd >>= fun () -> + Lwt.return (Error (`Msg "couldn't write")) + | Ok () -> + (match next with + | `Read -> read fd tls + | `End -> process fd tls) >>= fun res -> + Vmm_tls_lwt.close tls >>= fun () -> + Vmm_lwt.safe_close fd >|= fun () -> + res let server_socket port = let open Lwt_unix in diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index df68224..864d010 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -4,17 +4,22 @@ open Rresult open Rresult.R.Infix (* we skip all non-albatross certificates *) +let cert_name cert = + match X509.Extension.unsupported cert Vmm_asn.oid with + | None -> None + | Some _ -> + let data = X509.common_name_to_string cert in + (* if the common name is empty, skip [useful for vmmc_bistro at least] + TODO: document properly and investigate potential security issue with + multi-tenant system (likely ca should ensure to never sign a delegation + with empty common name) *) + if data = "" then None else Some data + let name chain = List.fold_left (fun acc cert -> - match X509.Extension.unsupported cert Vmm_asn.oid with + match cert_name cert with | None -> acc - | Some _ -> - let data = X509.common_name_to_string cert in - (* if the common name is empty, skip [useful for vmmc_bistro at least] - TODO: document properly and investigate potential security issue with - multi-tenant system (likely ca should ensure to never sign a delegation - with empty common name) *) - if data = "" then acc else data :: acc) + | Some data -> data :: acc) [] chain (* this separates the leaf and top-level certificate from the chain, @@ -27,15 +32,15 @@ let separate_chain = function let wire_command_of_cert version cert = match X509.Extension.unsupported cert Vmm_asn.oid with - | None -> R.error_msgf "albatross OID is not present in certificate (%a)" Asn.OID.pp Vmm_asn.oid + | None -> Error `Not_present | Some (_, data) -> - Vmm_asn.cert_extension_of_cstruct data >>= fun (v, wire) -> - if not (Vmm_commands.version_eq v version) then - R.error_msgf "unexpected version %a (expected %a)" - Vmm_commands.pp_version v - Vmm_commands.pp_version version - else - Ok wire + match Vmm_asn.cert_extension_of_cstruct data with + | Error (`Msg p) -> Error (`Parse p) + | Ok (v, wire) -> + if not (Vmm_commands.version_eq v version) then + Error (`Version v) + else + Ok wire (* let check_policy = (* get names and static resources *) @@ -50,6 +55,26 @@ let wire_command_of_cert version cert = check_policies vm_config (List.map snd policies) >>= fun () -> *) +let extract_policies version chain = + List.fold_left (fun acc cert -> + match acc, wire_command_of_cert version cert with + | Error e, _ -> Error e + | Ok acc, Error `Not_present -> Ok acc + | Ok _, Error (`Parse msg) -> Error (`Msg msg) + | Ok _, Error (`Version received) -> + R.error_msgf "unexpected version %a (expected %a)" + Vmm_commands.pp_version received + Vmm_commands.pp_version version + | Ok (prefix, acc), Ok (`Policy_cmd (`Policy_add p)) -> + let name = match cert_name cert with + | None -> prefix + | Some x -> x :: prefix + in + Ok (name, (name, p) :: acc) + | _, Ok wire -> + R.error_msgf "unexpected wire %a" Vmm_commands.pp wire) + (Ok ([], [])) chain + let handle _addr version chain = separate_chain chain >>= fun (leaf, rest) -> let name = name chain in @@ -57,15 +82,22 @@ let handle _addr version chain = (X509.common_name_to_string leaf) Fmt.(list ~sep:(unit " -> ") string) (List.map X509.common_name_to_string rest)) ; - (* TODO: inspect top-level-cert of chain. *) + extract_policies version rest >>= fun (_, policies) -> (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) - (* TODO: update policies (parse chain for policy, and apply them)! *) - wire_command_of_cert version leaf >>= fun wire -> - (* we only allow some commands via certificate *) - match wire with - | `Console_cmd (`Console_subscribe _) - | `Stats_cmd `Stats_subscribe - | `Log_cmd (`Log_subscribe _) - | `Vm_cmd _ - | `Policy_cmd _ -> Ok (name, wire) (* TODO policy_cmd is special (via delegation chain) *) - | _ -> Error (`Msg "unexpected command") + match wire_command_of_cert version leaf with + | Error (`Parse p) -> Error (`Msg p) + | Error (`Not_present) -> + Error (`Msg "leaf certificate does not contain an albatross extension") + | Error (`Version received) -> + R.error_msgf "unexpected version %a (expected %a)" + Vmm_commands.pp_version received + Vmm_commands.pp_version version + | Ok wire -> + (* we only allow some commands via certificate *) + match wire with + | `Console_cmd (`Console_subscribe _) + | `Stats_cmd `Stats_subscribe + | `Log_cmd (`Log_subscribe _) + | `Vm_cmd _ + | `Policy_cmd `Policy_info -> Ok (name, policies, wire) + | _ -> Error (`Msg "unexpected command") diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index 6505d41..61b5674 100644 --- a/src/vmm_tls.mli +++ b/src/vmm_tls.mli @@ -1,9 +1,10 @@ (* (c) 2018 Hannes Mehnert, all rights reserved *) val wire_command_of_cert : Vmm_commands.version -> X509.t -> - (Vmm_commands.t, [> `Msg of string ]) result + (Vmm_commands.t, [> `Parse of string | `Not_present | `Version of Vmm_commands.version ]) result val handle : 'a -> Vmm_commands.version -> X509.t list -> - (string list * Vmm_commands.t, [> `Msg of string ]) Result.result + (string list * (Vmm_core.id * Vmm_core.policy) list * Vmm_commands.t, + [> `Msg of string ]) Result.result From 34291dbe65c17d37171fe1bfaaf1d7f2fc2e8cc0 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 22:14:39 +0100 Subject: [PATCH 67/73] vmmp_request --- app/vmm_cli.ml | 93 ++++++++++++++++- app/vmmc_bistro.ml | 105 +++---------------- app/vmmc_local.ml | 104 +++---------------- app/vmmp_request.ml | 246 ++++++++++++++++++++++++++------------------ src/vmm_tls.ml | 13 --- src/vmm_tls.mli | 2 +- 6 files changed, 264 insertions(+), 299 deletions(-) diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml index 88dd2ec..e177ff5 100644 --- a/app/vmm_cli.ml +++ b/app/vmm_cli.ml @@ -1,8 +1,40 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + +open Astring +open Vmm_core + let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); Logs.set_level level; Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) +let create_vm force image cpuid requested_memory argv block_device network compression = + let open Rresult.R.Infix in + (Bos.OS.File.read (Fpath.v image) >>= fun s -> + Ok (Cstruct.of_string s)) >>| fun image -> + let vmimage = match compression with + | 0 -> `Hvt_amd64, image + | level -> + let img = Vmm_compress.compress ~level (Cstruct.to_string image) in + `Hvt_amd64_compressed, Cstruct.of_string img + and argv = match argv with [] -> None | xs -> Some xs + in + let vm_config = { cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } in + if force then `Vm_force_create vm_config else `Vm_create vm_config + +let policy vms memory cpus block bridges = + let bridges = match bridges with + | xs -> + let add m v = + let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in + String.Map.add n v m + in + List.fold_left add String.Map.empty xs + and cpuids = IS.of_list cpus + in + { vms ; cpuids ; memory ; block ; bridges } + + open Cmdliner let setup_log = @@ -44,13 +76,68 @@ let bridge = | [ name ] -> `Ok (`Internal name) | _ -> `Error "couldn't parse bridge (either 'name' or 'name/fstIP/lstIP/gwIP/netmask')" in - (parse, Vmm_core.pp_bridge) + (parse, pp_bridge) let vm_c = - let parse s = `Ok (Vmm_core.id_of_string s) + let parse s = `Ok (id_of_string s) in - (parse, Vmm_core.pp_id) + (parse, pp_id) let opt_vm_name = let doc = "name of virtual machine." in Arg.(value & opt vm_c [] & info [ "n" ; "name"] ~doc) + +let compress_level = + let doc = "Compression level (0 for no compression)" in + Arg.(value & opt int 4 & info [ "compression-level" ] ~doc) + +let force = + let doc = "force VM creation." in + Arg.(value & flag & info [ "f" ; "force" ] ~doc) + +let cpus = + let doc = "CPUs to allow" in + Arg.(value & opt_all int [] & info [ "cpu" ] ~doc) + +let vms = + let doc = "Number of VMs to allow" in + Arg.(required & pos 0 (some int) None & info [] ~doc) + +let block_size = + let doc = "Block storage to allow" in + Arg.(value & opt (some int) None & info [ "block" ] ~doc) + +let mem = + let doc = "Memory to allow" in + Arg.(value & opt int 512 & info [ "mem" ] ~doc) + +let bridge = + let doc = "Bridge to allow" in + Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc) + +let cpu = + let doc = "CPUid" in + Arg.(value & opt int 0 & info [ "cpu" ] ~doc) + +let args = + let doc = "Boot arguments" in + Arg.(value & opt_all string [] & info [ "arg" ] ~doc) + +let block = + let doc = "Block device name" in + Arg.(value & opt (some string) None & info [ "block" ] ~doc) + +let net = + let doc = "Network device" in + Arg.(value & opt_all string [] & info [ "net" ] ~doc) + +let timestamp_c = + let parse s = match Ptime.of_rfc3339 s with + | Ok (t, _, _) -> `Ok t + | Error _ -> `Error "couldn't parse timestamp" + in + (parse, Ptime.pp_rfc3339 ()) + +let since = + let doc = "Since" in + Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc) diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml index ecda976..54c3972 100644 --- a/app/vmmc_bistro.ml +++ b/app/vmmc_bistro.ml @@ -2,10 +2,6 @@ open Lwt.Infix -open Astring - -open Vmm_core - let version = `AV2 let process fd = @@ -52,7 +48,7 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) = Vmm_lwt.read_from_file key >>= fun key_cs -> let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in let tmpkey = Nocrypto.Rsa.generate 4096 in - let name = string_of_id id in + let name = Vmm_core.string_of_id id in let extensions = [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) ; (true, `Basic_constraints (false, None)) @@ -88,48 +84,26 @@ let jump endp cert key ca name cmd = | Ok () -> `Ok () | Error (`Msg m) -> `Error (false, m) -let info_ _ endp cert key ca name = jump endp cert key ca name (`Vm_cmd `Vm_info) +let info_ _ endp cert key ca name = + jump endp cert key ca name (`Vm_cmd `Vm_info) -let policy _ endp cert key ca name = jump endp cert key ca name (`Policy_cmd `Policy_info) +let info_policy _ endp cert key ca name = + jump endp cert key ca name (`Policy_cmd `Policy_info) let remove_policy _ endp cert key ca name = jump endp cert key ca name (`Policy_cmd `Policy_remove) let add_policy _ endp cert key ca name vms memory cpus block bridges = - let bridges = match bridges with - | xs -> - let add m v = - let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in - String.Map.add n v m - in - List.fold_left add String.Map.empty xs - and cpuids = IS.of_list cpus - in - let policy = { vms ; cpuids ; memory ; block ; bridges } in - jump endp cert key ca name (`Policy_cmd (`Policy_add policy)) + let p = Vmm_cli.policy vms memory cpus block bridges in + jump endp cert key ca name (`Policy_cmd (`Policy_add p)) let destroy _ endp cert key ca name = jump endp cert key ca name (`Vm_cmd `Vm_destroy) -let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network = - let image' = match Bos.OS.File.read (Fpath.v image) with - | Ok data -> data - | Error (`Msg s) -> invalid_arg s - in - let argv = match boot_params with - | [] -> None - | xs -> Some xs - (* TODO we could do the compression btw *) - and vmimage = `Hvt_amd64, Cstruct.of_string image' - in - let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in - let cmd = - if force then - `Vm_force_create vm_config - else - `Vm_create vm_config - in - jump endp cert key ca name (`Vm_cmd cmd) +let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network compression = + match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with + | Ok cmd -> jump endp cert key ca name (`Vm_cmd cmd) + | Error (`Msg msg) -> `Error (false, msg) let console _ endp cert key ca name since = jump endp cert key ca name (`Console_cmd (`Console_subscribe since)) @@ -164,10 +138,6 @@ let destination = Arg.(required & pos 0 (some host_port) None & info [] ~docv:"destination" ~doc:"the destination hostname:port to connect to") -let force = - let doc = "force VM creation." in - Arg.(value & flag & info [ "f" ; "force" ] ~doc) - let image = let doc = "File of virtual machine image." in Arg.(required & pos 2 (some file) None & info [] ~doc) @@ -209,74 +179,27 @@ let policy_cmd = [`S "DESCRIPTION"; `P "Shows information about policies."] in - Term.(ret (const policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), + Term.(ret (const info_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), Term.info "policy" ~doc ~man -let cpus = - let doc = "CPUs to allow" in - Arg.(value & opt_all int [] & info [ "cpu" ] ~doc) - -let vms = - let doc = "Number of VMs to allow" in - Arg.(required & pos 0 (some int) None & info [] ~doc) - -let block = - let doc = "Block storage to allow" in - Arg.(value & opt (some int) None & info [ "block" ] ~doc) - -let mem = - let doc = "Memory to allow" in - Arg.(value & opt int 512 & info [ "mem" ] ~doc) - -let bridge = - let doc = "Bridge to allow" in - Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc) - let add_policy_cmd = let doc = "Add a policy" in let man = [`S "DESCRIPTION"; `P "Adds a policy."] in - Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ vms $ mem $ cpus $ block $ bridge)), + Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)), Term.info "add_policy" ~doc ~man -let cpu = - let doc = "CPUid" in - Arg.(value & opt int 0 & info [ "cpu" ] ~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 create_cmd = let doc = "creates a virtual machine" in let man = [`S "DESCRIPTION"; `P "Creates a virtual machine."] in - Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), + Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net $ compress_level)), Term.info "create" ~doc ~man -let timestamp_c = - let parse s = match Ptime.of_rfc3339 s with - | Ok (t, _, _) -> `Ok t - | Error _ -> `Error "couldn't parse timestamp" - in - (parse, Ptime.pp_rfc3339 ()) - -let since = - let doc = "Since" in - Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc) - let console_cmd = let doc = "console of a VM" in let man = diff --git a/app/vmmc_local.ml b/app/vmmc_local.ml index a741c71..4ab4e60 100644 --- a/app/vmmc_local.ml +++ b/app/vmmc_local.ml @@ -2,10 +2,6 @@ open Lwt.Infix -open Astring - -open Vmm_core - let version = `AV2 let process fd = @@ -62,46 +58,23 @@ let jump opt_socket name cmd = let info_ _ opt_socket name = jump opt_socket name (`Vm_cmd `Vm_info) -let policy _ opt_socket name = jump opt_socket name (`Policy_cmd `Policy_info) +let info_policy _ opt_socket name = + jump opt_socket name (`Policy_cmd `Policy_info) let remove_policy _ opt_socket name = jump opt_socket name (`Policy_cmd `Policy_remove) let add_policy _ opt_socket name vms memory cpus block bridges = - let bridges = match bridges with - | xs -> - let add m v = - let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in - String.Map.add n v m - in - List.fold_left add String.Map.empty xs - and cpuids = IS.of_list cpus - in - let policy = { vms ; cpuids ; memory ; block ; bridges } in - jump opt_socket name (`Policy_cmd (`Policy_add policy)) + let p = Vmm_cli.policy vms memory cpus block bridges in + jump opt_socket name (`Policy_cmd (`Policy_add p)) let destroy _ opt_socket name = jump opt_socket name (`Vm_cmd `Vm_destroy) -let create _ opt_socket force name image cpuid requested_memory boot_params block_device network = - let image' = match Bos.OS.File.read (Fpath.v image) with - | Ok data -> data - | Error (`Msg s) -> invalid_arg s - in - let argv = match boot_params with - | [] -> None - | xs -> Some xs - (* TODO we could do the compression btw *) - and vmimage = `Hvt_amd64, Cstruct.of_string image' - in - let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in - let cmd = - if force then - `Vm_force_create vm_config - else - `Vm_create vm_config - in - jump opt_socket name (`Vm_cmd cmd) +let create _ opt_socket force name image cpuid requested_memory boot_params block_device network compression = + match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with + | Ok cmd -> jump opt_socket name (`Vm_cmd cmd) + | Error (`Msg msg) -> `Error (false, msg) let console _ opt_socket name since = jump opt_socket name (`Console_cmd (`Console_subscribe since)) @@ -124,10 +97,6 @@ let socket = let doc = "Socket to connect to" in Arg.(value & opt (some string) None & info [ "socket" ] ~doc) -let force = - let doc = "force VM creation." in - Arg.(value & flag & info [ "f" ; "force" ] ~doc) - let image = let doc = "File of virtual machine image." in Arg.(required & pos 1 (some file) None & info [] ~doc) @@ -169,74 +138,27 @@ let policy_cmd = [`S "DESCRIPTION"; `P "Shows information about policies."] in - Term.(ret (const policy $ setup_log $ socket $ opt_vm_name)), + Term.(ret (const info_policy $ setup_log $ socket $ opt_vm_name)), Term.info "policy" ~doc ~man -let cpus = - let doc = "CPUs to allow" in - Arg.(value & opt_all int [] & info [ "cpu" ] ~doc) - -let vms = - let doc = "Number of VMs to allow" in - Arg.(required & pos 0 (some int) None & info [] ~doc) - -let block = - let doc = "Block storage to allow" in - Arg.(value & opt (some int) None & info [ "block" ] ~doc) - -let mem = - let doc = "Memory to allow" in - Arg.(value & opt int 512 & info [ "mem" ] ~doc) - -let bridge = - let doc = "Bridge to allow" in - Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc) - let add_policy_cmd = let doc = "Add a policy" in let man = [`S "DESCRIPTION"; `P "Adds a policy."] in - Term.(ret (const add_policy $ setup_log $ socket $ opt_vm_name $ vms $ mem $ cpus $ block $ bridge)), + Term.(ret (const add_policy $ setup_log $ socket $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)), Term.info "add_policy" ~doc ~man -let cpu = - let doc = "CPUid" in - Arg.(value & opt int 0 & info [ "cpu" ] ~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 create_cmd = let doc = "creates a virtual machine" in let man = [`S "DESCRIPTION"; `P "Creates a virtual machine."] in - Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), + Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net $ compress_level)), Term.info "create" ~doc ~man -let timestamp_c = - let parse s = match Ptime.of_rfc3339 s with - | Ok (t, _, _) -> `Ok t - | Error _ -> `Error "couldn't parse timestamp" - in - (parse, Ptime.pp_rfc3339 ()) - -let since = - let doc = "Since" in - Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc) - let console_cmd = let doc = "console of a VM" in let man = @@ -272,13 +194,13 @@ let help_cmd = let doc = "display help about vmmc" in let man = [`S "DESCRIPTION"; - `P "Prints help about conex commands and subcommands"] + `P "Prints help about albatross local client commands and subcommands"] in Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ topic)), Term.info "help" ~doc ~man let default_cmd = - let doc = "VMM client" in + let doc = "VMM local client" in let man = [ `S "DESCRIPTION" ; `P "$(tname) connects to vmmd via a local socket" ] diff --git a/app/vmmp_request.ml b/app/vmmp_request.ml index 92765d8..094e584 100644 --- a/app/vmmp_request.ml +++ b/app/vmmp_request.ml @@ -1,134 +1,180 @@ -(* (c) 2017 Hannes Mehnert, all rights reserved *) +(* (c) 2017, 2018 Hannes Mehnert, all rights reserved *) open Vmm_provision +open Vmm_asn open Rresult.R.Infix -open Vmm_asn +let version = `AV2 -let vm_csr key name image cpuid requested_memory argv block_device network force compression = - let vm_config = - let vmimage = match compression with - | 0 -> `Hvt_amd64, image - | level -> - let img = Vmm_compress.compress ~level (Cstruct.to_string image) in - `Hvt_amd64_compressed, Cstruct.of_string img - and argv = match argv with [] -> None | xs -> Some xs - in - Vmm_core.{ cpuid ; requested_memory ; block_device ; network ; argv ; vmimage } - in - let cmd = if force then `Vm_force_create vm_config else `Vm_create vm_config in - let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, `Vm_cmd cmd))) ] +let csr priv name cmd = + let exts = [ (false, `Unsupported (oid, cert_extension_to_cstruct (version, cmd))) ] and name = [ `CN name ] in - X509.CA.request name ~extensions:[`Extensions exts] key + X509.CA.request name ~extensions:[`Extensions exts] priv -let jump _ name key image mem cpu args block net force compression = +let jump id cmd = Nocrypto_entropy_unix.initialize () ; + let name = Vmm_core.string_of_id id in match - priv_key key name >>= fun key -> - (Bos.OS.File.read (Fpath.v image) >>= fun s -> - Ok (Cstruct.of_string s)) >>= fun image -> - let csr = vm_csr key name image cpu mem args block net force compression in + priv_key None name >>= fun priv -> + let csr = csr priv name cmd in let enc = X509.Encoding.Pem.Certificate_signing_request.to_pem_cstruct1 csr in Bos.OS.File.write Fpath.(v name + ".req") (Cstruct.to_string enc) with | Ok () -> `Ok () | Error (`Msg m) -> `Error (false, m) -(* (c) 2017 Hannes Mehnert, all rights reserved *) -(* -open Vmm_provision -open Vmm_asn +let info_ _ name = jump name (`Vm_cmd `Vm_info) -open Rresult.R.Infix +let info_policy _ name = + jump name (`Policy_cmd `Policy_info) -open Astring +let remove_policy _ name = + jump name (`Policy_cmd `Policy_remove) -let subca_csr key name cpus memory vms block bridges = - let cpuids = Vmm_core.IS.of_list cpus - and bridges = List.fold_left (fun acc b -> match b with - | `Internal name -> String.Map.add name b acc - | `External (name, _, _, _, _) -> String.Map.add name b acc) - String.Map.empty bridges - in - let policy = Vmm_core.{ vms ; cpuids ; memory ; block ; bridges } in - let cmd = `Policy_cmd (`Policy_add policy) in - let exts = - [ (false, `Unsupported (oid, cert_extension_to_cstruct (asn_version, cmd))) ] - and name = [ `CN name ] - in - X509.CA.request name ~extensions:[`Extensions exts] key +let add_policy _ name vms memory cpus block bridges = + let p = Vmm_cli.policy vms memory cpus block bridges in + jump name (`Policy_cmd (`Policy_add p)) -let 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) +let destroy _ name = + jump name (`Vm_cmd `Vm_destroy) + +let create _ force name image cpuid requested_memory boot_params block_device network compression = + match Vmm_cli.create_vm force image cpuid requested_memory boot_params block_device network compression with + | Ok cmd -> jump name (`Vm_cmd cmd) + | Error (`Msg msg) -> `Error (false, msg) + +let console _ name since = + jump name (`Console_cmd (`Console_subscribe since)) + +let stats _ name = + jump name (`Stats_cmd `Stats_subscribe) + +let event_log _ name since = + jump name (`Log_cmd (`Log_subscribe since)) + +let help _ man_format cmds = function + | None -> `Help (`Pager, None) + | Some t when List.mem t cmds -> `Help (man_format, Some t) + | Some _ -> List.iter print_endline cmds; `Ok () open Cmdliner open Vmm_cli -let 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 bridge = - let doc = "Bridge to provision" in - Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc) - -let cmd = - Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)), - Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" - -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 - *) -open Cmdliner -open Vmm_cli - -let cpu = - let doc = "CPUid" in - Arg.(required & pos 3 (some int) None & info [] ~doc) - let image = - let doc = "Image file to provision" in + let doc = "File of virtual machine image." 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 vm_name = + let doc = "Name virtual machine." in + Arg.(required & pos 0 (some vm_c) None & info [] ~doc) -let block = - let doc = "Block device name" in - Arg.(value & opt (some string) None & info [ "block" ] ~doc) +let destroy_cmd = + let doc = "destroys a virtual machine" in + let man = + [`S "DESCRIPTION"; + `P "Destroy a virtual machine."] + in + Term.(ret (const destroy $ setup_log $ vm_name)), + Term.info "destroy" ~doc ~man -let net = - let doc = "Network device" in - Arg.(value & opt_all string [] & info [ "net" ] ~doc) +let remove_policy_cmd = + let doc = "removes a policy" in + let man = + [`S "DESCRIPTION"; + `P "Removes a policy."] + in + Term.(ret (const remove_policy $ setup_log $ opt_vm_name)), + Term.info "remove_policy" ~doc ~man -let force = - let doc = "Force creation (destroy VM with same name if it exists)" in - Arg.(value & flag & info [ "force" ] ~doc) +let info_cmd = + let doc = "information about VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows information about VMs."] + in + Term.(ret (const info_ $ setup_log $ opt_vm_name)), + Term.info "info" ~doc ~man -let compress_level = - let doc = "Compression level (0 for no compression)" in - Arg.(value & opt int 4 & info [ "compression-level" ] ~doc) +let policy_cmd = + let doc = "active policies" in + let man = + [`S "DESCRIPTION"; + `P "Shows information about policies."] + in + Term.(ret (const info_policy $ setup_log $ opt_vm_name)), + Term.info "policy" ~doc ~man -let cmd = - Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)), - Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" +let add_policy_cmd = + let doc = "Add a policy" in + let man = + [`S "DESCRIPTION"; + `P "Adds a policy."] + in + Term.(ret (const add_policy $ setup_log $ opt_vm_name $ vms $ mem $ cpus $ block_size $ bridge)), + Term.info "add_policy" ~doc ~man -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 +let create_cmd = + let doc = "creates a virtual machine" in + let man = + [`S "DESCRIPTION"; + `P "Creates a virtual machine."] + in + Term.(ret (const create $ setup_log $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net $ compress_level)), + Term.info "create" ~doc ~man + +let console_cmd = + let doc = "console of a VM" in + let man = + [`S "DESCRIPTION"; + `P "Shows console output of a VM."] + in + Term.(ret (const console $ setup_log $ vm_name $ since)), + Term.info "console" ~doc ~man + +let stats_cmd = + let doc = "statistics of VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows statistics of VMs."] + in + Term.(ret (const stats $ setup_log $ opt_vm_name)), + Term.info "stats" ~doc ~man + +let log_cmd = + let doc = "Event log" in + let man = + [`S "DESCRIPTION"; + `P "Shows event log of VM."] + in + Term.(ret (const event_log $ setup_log $ opt_vm_name $ since)), + Term.info "log" ~doc ~man + +let help_cmd = + let topic = + let doc = "The topic to get help on. `topics' lists the topics." in + Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) + in + let doc = "display help about vmmc" in + let man = + [`S "DESCRIPTION"; + `P "Prints help about albatross local client commands and subcommands"] + in + Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ topic)), + Term.info "help" ~doc ~man + +let default_cmd = + let doc = "VMM local client" in + let man = [ + `S "DESCRIPTION" ; + `P "$(tname) connects to vmmd via a local socket" ] + in + Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)), + Term.info "vmmc_local" ~version:"%%VERSION_NUM%%" ~doc ~man + +let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] + +let () = + match Term.eval_choice default_cmd cmds + with `Ok () -> exit 0 | _ -> exit 1 diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 864d010..c3bf2cc 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -42,19 +42,6 @@ let wire_command_of_cert version cert = else Ok wire -(* let check_policy = - (* get names and static resources *) - List.fold_left (fun acc ca -> - acc >>= fun acc -> - Vmm_asn.delegation_of_cert asn_version ca >>= fun res -> - let name = id ca in - Ok ((name, res) :: acc)) - (Ok []) chain >>= fun policies -> - (* check static policies *) - Logs.debug (fun m -> m "now checking static policies") ; - check_policies vm_config (List.map snd policies) >>= fun () -> -*) - let extract_policies version chain = List.fold_left (fun acc cert -> match acc, wire_command_of_cert version cert with diff --git a/src/vmm_tls.mli b/src/vmm_tls.mli index 61b5674..cae2c62 100644 --- a/src/vmm_tls.mli +++ b/src/vmm_tls.mli @@ -6,5 +6,5 @@ val wire_command_of_cert : Vmm_commands.version -> X509.t -> val handle : 'a -> Vmm_commands.version -> X509.t list -> - (string list * (Vmm_core.id * Vmm_core.policy) list * Vmm_commands.t, + (Vmm_core.id * (Vmm_core.id * Vmm_core.policy) list * Vmm_commands.t, [> `Msg of string ]) Result.result From d08de432b634cc26c6ca8839573d7dddab7ae574 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 22:28:22 +0100 Subject: [PATCH 68/73] use proper extension --- app/vmmp_ca.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/app/vmmp_ca.ml b/app/vmmp_ca.ml index 9e3d65d..f4e9de8 100644 --- a/app/vmmp_ca.ml +++ b/app/vmmp_ca.ml @@ -39,8 +39,7 @@ let sign dbname cacert key csr days = 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 *) - (* TODO: check delegation! *) + (* TODO: check delegation! verify whitelisted commands!? *) match albatross_extension csr with | Ok (ext, v) -> Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) -> @@ -48,9 +47,12 @@ let sign dbname cacert key csr days = Ok () else Error (`Msg "unknown version in request")) >>= fun () -> - (* TODO l_exts / d_exts trouble *) + let exts = match cmd with + | `Policy_cmd (`Policy_add _) -> d_exts () + | _ -> l_exts + in Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd) ; - Ok (ext :: l_exts) >>= fun extensions -> + Ok (ext :: exts) >>= fun extensions -> Vmm_provision.sign ~dbname extensions issuer key csr (Duration.of_day days) | Error e -> Error e From 947b82f4f037f14396b1d26f1744c8265ff7f105 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 22:29:45 +0100 Subject: [PATCH 69/73] vmm_tls: ensure that add_policy commands carry a non-empty name --- src/vmm_tls.ml | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index c3bf2cc..77264c1 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -6,21 +6,24 @@ open Rresult.R.Infix (* we skip all non-albatross certificates *) let cert_name cert = match X509.Extension.unsupported cert Vmm_asn.oid with - | None -> None - | Some _ -> - let data = X509.common_name_to_string cert in - (* if the common name is empty, skip [useful for vmmc_bistro at least] - TODO: document properly and investigate potential security issue with - multi-tenant system (likely ca should ensure to never sign a delegation - with empty common name) *) - if data = "" then None else Some data + | None -> Ok None + | Some (_, data) -> + let name = X509.common_name_to_string cert in + if name = "" then + match Vmm_asn.cert_extension_of_cstruct data with + | Error (`Msg _) -> Error (`Msg "couldn't parse albatross extension") + | Ok (_, `Policy_cmd (`Policy_add _)) -> Error (`Msg "policy add may not have an empty name") + | _ -> Ok (Some name) + else Ok (Some name) let name chain = List.fold_left (fun acc cert -> - match cert_name cert with - | None -> acc - | Some data -> data :: acc) - [] chain + match acc, cert_name cert with + | Error e, _ -> Error e + | _, Error e -> Error e + | Ok acc, Ok None -> Ok acc + | Ok acc, Ok Some data -> Ok (data :: acc)) + (Ok []) chain (* this separates the leaf and top-level certificate from the chain, and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA') @@ -53,18 +56,17 @@ let extract_policies version chain = Vmm_commands.pp_version received Vmm_commands.pp_version version | Ok (prefix, acc), Ok (`Policy_cmd (`Policy_add p)) -> - let name = match cert_name cert with + (cert_name cert >>| function | None -> prefix - | Some x -> x :: prefix - in - Ok (name, (name, p) :: acc) + | Some x -> x :: prefix) >>| fun name -> + (name, (name, p) :: acc) | _, Ok wire -> R.error_msgf "unexpected wire %a" Vmm_commands.pp wire) (Ok ([], [])) chain let handle _addr version chain = separate_chain chain >>= fun (leaf, rest) -> - let name = name chain in + name chain >>= fun name -> Logs.debug (fun m -> m "leaf is %s, chain %a" (X509.common_name_to_string leaf) Fmt.(list ~sep:(unit " -> ") string) From 0f9375dc29aeda9d7b972afe6641cbdb8df8a035 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 22:39:31 +0100 Subject: [PATCH 70/73] use oid 42 again --- src/vmm_asn.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 834504f..316eeac 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -6,7 +6,7 @@ open Vmm_commands open Rresult open Astring -let oid = Asn.OID.(base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 43) +let oid = Asn.OID.(base 1 3 <| 6 <| 1 <| 4 <| 1 <| 49836 <| 42) open Rresult.R.Infix From 9191d2cf9afb0c03fcec6589f409051b898b2f90 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 22:52:20 +0100 Subject: [PATCH 71/73] drop version AV0, AV1; refactor vmm_asn --- src/vmm_asn.ml | 81 +++++++++++++++++++++----------------------- src/vmm_commands.ml | 6 +--- src/vmm_commands.mli | 2 +- 3 files changed, 40 insertions(+), 49 deletions(-) diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 316eeac..8a6e81f 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -307,13 +307,9 @@ let policy_cmd = let version = let f data = match data with - | 0 -> `AV0 - | 1 -> `AV1 | 2 -> `AV2 | _ -> Asn.S.error (`Parse "unknown version number") and g = function - | `AV0 -> 0 - | `AV1 -> 1 | `AV2 -> 2 in Asn.S.map f g Asn.S.int @@ -376,55 +372,54 @@ let header = (required ~label:"sequence" int64) (required ~label:"id" (sequence_of utf8_string))) -let wire = - let f (header, payload) = - header, - match payload with +let success = + let f = function + | `C1 () -> `Empty + | `C2 str -> `String str + | `C3 policies -> `Policies policies + | `C4 vms -> `Vms vms + and g = function + | `Empty -> `C1 () + | `String s -> `C2 s + | `Policies ps -> `C3 ps + | `Vms vms -> `C4 vms + in + Asn.S.map f g @@ + Asn.S.(choice4 + (explicit 0 null) + (explicit 1 utf8_string) + (explicit 2 (sequence_of + (sequence2 + (required ~label:"name" (sequence_of utf8_string)) + (required ~label:"policy" policy)))) + (explicit 3 (sequence_of + (sequence2 + (required ~label:"name" (sequence_of utf8_string)) + (required ~label:"vm_config" vm_config))))) + +let payload = + let f = function | `C1 cmd -> `Command cmd - | `C2 data -> - let p = match data with - | `C1 () -> `Empty - | `C2 str -> `String str - | `C3 policies -> `Policies policies - | `C4 vms -> `Vms vms - in - `Success p + | `C2 s -> `Success s | `C3 str -> `Failure str | `C4 data -> `Data data - and g (header, payload) = - header, - match payload with + and g = function | `Command cmd -> `C1 cmd - | `Success data -> - let p = match data with - | `Empty -> `C1 () - | `String s -> `C2 s - | `Policies ps -> `C3 ps - | `Vms vms -> `C4 vms - in - `C2 p + | `Success s -> `C2 s | `Failure str -> `C3 str | `Data d -> `C4 d in Asn.S.map f g @@ + Asn.S.(choice4 + (explicit 0 wire_command) + (explicit 1 success) + (explicit 2 utf8_string) + (explicit 3 data)) + +let wire = Asn.S.(sequence2 (required ~label:"header" header) - (required ~label:"payload" - (choice4 - (explicit 0 wire_command) - (explicit 1 (choice4 - (explicit 0 null) - (explicit 1 utf8_string) - (explicit 2 (sequence_of - (sequence2 - (required ~label:"name" (sequence_of utf8_string)) - (required ~label:"policy" policy)))) - (explicit 3 (sequence_of - (sequence2 - (required ~label:"name" (sequence_of utf8_string)) - (required ~label:"vm_config" vm_config)))))) - (explicit 2 utf8_string) - (explicit 3 data)))) + (required ~label:"payload" payload)) let wire_of_cstruct, wire_to_cstruct = projections_of wire diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index 533c607..d760e51 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -3,19 +3,15 @@ (* the wire protocol *) open Vmm_core -type version = [ `AV0 | `AV1 | `AV2 ] +type version = [ `AV2 ] let pp_version ppf v = Fmt.int ppf (match v with - | `AV0 -> 0 - | `AV1 -> 1 | `AV2 -> 2) let version_eq a b = match a, b with - | `AV0, `AV0 -> true - | `AV1, `AV1 -> true | `AV2, `AV2 -> true | _ -> false diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index 175e8d0..d9c773b 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -3,7 +3,7 @@ open Vmm_core (** The type of versions of the grammar defined below. *) -type version = [ `AV0 | `AV1 | `AV2 ] +type version = [ `AV2 ] (** [version_eq a b] is true if [a] and [b] are equal. *) val version_eq : version -> version -> bool From 2b85c65dd8855472ddeb07fd12f635cbb4d01d24 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 23:06:15 +0100 Subject: [PATCH 72/73] minor fixes from testing: do not require vm to be present for force-create, fix id generation in vmm_tls, use 32mb memory for unikernels by default --- app/vmm_cli.ml | 4 ++++ app/vmmc_bistro.ml | 2 +- app/vmmc_local.ml | 2 +- app/vmmp_request.ml | 2 +- src/vmm_tls.ml | 2 +- src/vmm_vmmd.ml | 6 +++++- 6 files changed, 13 insertions(+), 5 deletions(-) diff --git a/app/vmm_cli.ml b/app/vmm_cli.ml index e177ff5..6f2d892 100644 --- a/app/vmm_cli.ml +++ b/app/vmm_cli.ml @@ -119,6 +119,10 @@ let cpu = let doc = "CPUid" in Arg.(value & opt int 0 & info [ "cpu" ] ~doc) +let vm_mem = + let doc = "Memory to assign" in + Arg.(value & opt int 32 & info [ "mem" ] ~doc) + let args = let doc = "Boot arguments" in Arg.(value & opt_all string [] & info [ "arg" ] ~doc) diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml index 54c3972..76cc3db 100644 --- a/app/vmmc_bistro.ml +++ b/app/vmmc_bistro.ml @@ -197,7 +197,7 @@ let create_cmd = [`S "DESCRIPTION"; `P "Creates a virtual machine."] in - Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net $ compress_level)), + Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level)), Term.info "create" ~doc ~man let console_cmd = diff --git a/app/vmmc_local.ml b/app/vmmc_local.ml index 4ab4e60..683b2f6 100644 --- a/app/vmmc_local.ml +++ b/app/vmmc_local.ml @@ -156,7 +156,7 @@ let create_cmd = [`S "DESCRIPTION"; `P "Creates a virtual machine."] in - Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net $ compress_level)), + Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level)), Term.info "create" ~doc ~man let console_cmd = diff --git a/app/vmmp_request.ml b/app/vmmp_request.ml index 094e584..5d030e0 100644 --- a/app/vmmp_request.ml +++ b/app/vmmp_request.ml @@ -121,7 +121,7 @@ let create_cmd = [`S "DESCRIPTION"; `P "Creates a virtual machine."] in - Term.(ret (const create $ setup_log $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net $ compress_level)), + Term.(ret (const create $ setup_log $ force $ vm_name $ image $ cpu $ vm_mem $ args $ block $ net $ compress_level)), Term.info "create" ~doc ~man let console_cmd = diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 77264c1..7e8696b 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -13,7 +13,7 @@ let cert_name cert = match Vmm_asn.cert_extension_of_cstruct data with | Error (`Msg _) -> Error (`Msg "couldn't parse albatross extension") | Ok (_, `Policy_cmd (`Policy_add _)) -> Error (`Msg "policy add may not have an empty name") - | _ -> Ok (Some name) + | _ -> Ok None else Ok (Some name) let name chain = diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index fd6cead..ffcc7fd 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -158,7 +158,11 @@ let handle_command t (header, payload) = | `Vm_create vm_config -> handle_create t header vm_config | `Vm_force_create vm_config -> - Vmm_resources.remove_vm t.resources id >>= fun resources -> + let resources = + match Vmm_resources.remove_vm t.resources id with + | Error _ -> t.resources + | Ok r -> r + in if Vmm_resources.check_vm_policy resources id vm_config then begin match Vmm_resources.find_vm t.resources id with | None -> handle_create t header vm_config From bd669dbe44034fc43cf9a8d4e90a87fadf78e68f Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 28 Oct 2018 23:18:07 +0100 Subject: [PATCH 73/73] packaging --- packaging/create_package.sh | 7 ++++--- packaging/rc.d/albatross_x | 11 ++++++----- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/packaging/create_package.sh b/packaging/create_package.sh index c0c7eab..7424bc1 100755 --- a/packaging/create_package.sh +++ b/packaging/create_package.sh @@ -23,12 +23,13 @@ for f in albatross_log \ do install -U $basedir/packaging/rc.d/$f $rootdir/usr/local/etc/rc.d/$f; done # stage albatross app binaries -for f in vmmd vmmd_log vmmd_console vmmd_stats; do +for f in vmmd vmmd_log vmmd_console vmmd_stats vmmd_influx vmmd_tls; do install -U $basedir/_build/app/$f.native \ $rootdir/usr/local/libexec/albatross/$f; done -install -U $basedir/_build/app/vmmc_local.native \ - $rootdir/usr/local/sbin/vmmc_local +for f in vmmc_local vmmc_remote vmmc_bistro vmmp_ca vmmp_request; do + install -U $basedir/_build/app/$f.native \ + $rootdir/usr/local/sbin/$f; done # create +MANIFEST flatsize=$(find "$rootdir" -type f -exec stat -f %z {} + | diff --git a/packaging/rc.d/albatross_x b/packaging/rc.d/albatross_x index 0cfa493..257110b 100755 --- a/packaging/rc.d/albatross_x +++ b/packaging/rc.d/albatross_x @@ -39,14 +39,14 @@ albatross_x_start () { _ALL) for _vm in $albatross_x_vms; do eval _create_args=\"\$albatross_x_args_${_vm}\" - /usr/local/sbin/vmmc create $_vm $_create_args + /usr/local/sbin/vmmc_local create $_vm $_create_args done return ;; esac for _vm in $@; do eval _create_args=\"\$albatross_x_args_${_vm}\" - /usr/local/sbin/vmmc create $_vm $_create_args + /usr/local/sbin/vmmc_local create $_vm $_create_args done } @@ -54,15 +54,16 @@ albatross_x_stop () { case $1 in ALL) for _vm in $albatross_x_vms - do /usr/local/sbin/vmmc destroy $_vm; done + do /usr/local/sbin/vmmc_local destroy $_vm; done return esac for _vm in $@ - do /usr/local/sbin/vmmc destroy $_vm; done + do /usr/local/sbin/vmmc_local destroy $_vm; done } albatross_x_status () { - /usr/local/sbin/vmmc info + for _vm in $@ + do /usr/local/sbin/vmmc_local info $_vm; done } case $# in