From 784429744c2752c228d58a3f908f138a58a43a67 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 11 Nov 2019 21:49:51 +0100 Subject: [PATCH] versioning: revise it all, use a 'current' in Vmm_commands, all daemons reply with the received version on that particular stream --- client/albatross_client_bistro.ml | 12 +- client/albatross_client_local.ml | 8 +- client/albatross_client_remote_tls.ml | 6 +- command-line/albatross_cli.ml | 18 +-- daemon/albatross_console.ml | 41 +++---- daemon/albatross_influx.ml | 56 ++++----- daemon/albatross_log.ml | 63 +++++----- daemon/albatrossd.ml | 64 +++++----- provision/albatross_provision.ml | 2 - provision/albatross_provision_ca.ml | 10 +- provision/albatross_provision_request.ml | 6 +- src/vmm_asn.ml | 12 +- src/vmm_asn.mli | 9 +- src/vmm_commands.ml | 25 ++-- src/vmm_commands.mli | 23 ++-- src/vmm_lwt.ml | 7 +- src/vmm_vmmd.ml | 63 +++++----- src/vmm_vmmd.mli | 22 ++-- stats/albatross_stat_client.ml | 2 +- stats/albatross_stats.ml | 4 +- stats/albatross_stats_pure.ml | 52 ++++----- tls/albatross_tls_common.ml | 143 +++++++++++------------ tls/albatross_tls_endpoint.ml | 6 +- tls/albatross_tls_inetd.ml | 6 +- tls/vmm_tls.ml | 45 +++---- tls/vmm_tls.mli | 9 +- tls/vmm_tls_lwt.ml | 7 +- 27 files changed, 337 insertions(+), 384 deletions(-) diff --git a/client/albatross_client_bistro.ml b/client/albatross_client_bistro.ml index 0b606a4..b8ba4b6 100644 --- a/client/albatross_client_bistro.ml +++ b/client/albatross_client_bistro.ml @@ -3,8 +3,6 @@ open Lwt.Infix open X509 -let version = `AV4 - let read fd = (* now we busy read and process output *) Logs.debug (fun m -> m "reading tls stream") ; @@ -15,7 +13,7 @@ let read fd = Lwt.return (Ok ()) | Error _ -> Lwt.return (Error (`Msg ("read failure"))) | Ok wire -> - Albatross_cli.print_result version wire ; + Albatross_cli.print_result wire ; loop () in loop () @@ -37,6 +35,10 @@ let timestamps validity = | Some now, Some exp -> (now, exp) let handle (host, port) cert key ca id (cmd : Vmm_commands.t) = + 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) ; Vmm_lwt.read_from_file cert >>= fun cert_cs -> Vmm_lwt.read_from_file key >>= fun key_cs -> match Certificate.decode_pem cert_cs, Private_key.decode_pem key_cs with @@ -48,7 +50,7 @@ let handle (host, port) cert key ca id (cmd : Vmm_commands.t) = let tmpkey = Nocrypto.Rsa.generate 4096 in let name = Vmm_core.Name.to_string id in let extensions = - let v = Vmm_asn.cert_extension_to_cstruct (version, cmd) in + let v = Vmm_asn.to_cert_extension cmd in Extension.(add Key_usage (true, [ `Digital_signature ; `Key_encipherment ]) (add Basic_constraints (true, (false, None)) (add Ext_key_usage (true, [ `Client_auth ]) @@ -285,7 +287,7 @@ let default_cmd = `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 "albatross_client_bistro" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "albatross_client_bistro" ~version ~doc ~man let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; diff --git a/client/albatross_client_local.ml b/client/albatross_client_local.ml index 3691804..be87066 100644 --- a/client/albatross_client_local.ml +++ b/client/albatross_client_local.ml @@ -2,8 +2,6 @@ open Lwt.Infix -let version = `AV4 - let socket t = function | Some x -> x | None -> Vmm_core.socket_path t @@ -11,7 +9,7 @@ let socket t = function let process fd = Vmm_lwt.read_wire fd >|= function | Error _ -> Error () - | Ok wire -> Ok (Albatross_cli.print_result version wire) + | Ok wire -> Ok (Albatross_cli.print_result wire) let read fd = (* now we busy read and process output *) @@ -32,7 +30,7 @@ let handle opt_socket name (cmd : Vmm_commands.t) = in Lwt.return err | Some fd -> - let header = Vmm_commands.{ version ; sequence = 0L ; name } in + let header = Vmm_commands.header name in Vmm_lwt.write_wire fd (header, `Command cmd) >>= function | Error `Exception -> Lwt.return (Error (`Msg "exception")) | Ok () -> @@ -248,7 +246,7 @@ let default_cmd = `P "$(tname) connects to albatrossd via a local socket" ] in Term.(ret (const help $ setup_log $ socket $ Term.man_format $ Term.choice_names $ Term.pure None)), - Term.info "albatross_client_local" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "albatross_client_local" ~version ~doc ~man let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; diff --git a/client/albatross_client_remote_tls.ml b/client/albatross_client_remote_tls.ml index 0ba2c3c..481029b 100644 --- a/client/albatross_client_remote_tls.ml +++ b/client/albatross_client_remote_tls.ml @@ -2,8 +2,6 @@ open Lwt.Infix -let version = `AV4 - let rec read_tls_write_cons t = Vmm_tls_lwt.read_tls t >>= function | Error `Eof -> @@ -12,7 +10,7 @@ let rec read_tls_write_cons t = | Error _ -> Lwt.return (Error (`Msg ("read failure"))) | Ok wire -> - Albatross_cli.print_result version wire ; + Albatross_cli.print_result wire ; read_tls_write_cons t let client cas host port cert priv_key = @@ -82,7 +80,7 @@ let cmd = `P "$(tname) connects to an Albatross server and initiates a TLS handshake" ] in Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination), - Term.info "albatross_client_remote_tls" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "albatross_client_remote_tls" ~version ~doc ~man let () = match Term.eval cmd diff --git a/command-line/albatross_cli.ml b/command-line/albatross_cli.ml index d001aaa..45becfe 100644 --- a/command-line/albatross_cli.ml +++ b/command-line/albatross_cli.ml @@ -48,14 +48,12 @@ let init_influx name data = in Lwt.async report -let print_result version (header, reply) = - if not (Vmm_commands.version_eq header.Vmm_commands.version version) then - Logs.err (fun m -> m "version not equal") - else match reply with - | `Success _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) - | `Data _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) - | `Failure _ -> Logs.warn (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) - | `Command _ -> Logs.err (fun m -> m "unexpected command %a" Vmm_commands.pp_wire (header, reply)) +let print_result ((_, reply) as wire) = + match reply with + | `Success _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire) + | `Data _ -> Logs.app (fun m -> m "%a" Vmm_commands.pp_wire wire) + | `Failure _ -> Logs.warn (fun m -> m "%a" Vmm_commands.pp_wire wire) + | `Command _ -> Logs.err (fun m -> m "unexpected command %a" Vmm_commands.pp_wire wire) let setup_log style_renderer level = Fmt_tty.setup_std_outputs ?style_renderer (); @@ -252,3 +250,7 @@ let count = let since_count since count = match since with | None -> `Count count | Some since -> `Since since + +let version = + Fmt.strf "version %%VERSION%% protocol version %a" + Vmm_commands.pp_version Vmm_commands.current diff --git a/daemon/albatross_console.ml b/daemon/albatross_console.ml index 1ff3653..17bf8f2 100644 --- a/daemon/albatross_console.ml +++ b/daemon/albatross_console.ml @@ -14,8 +14,6 @@ open Lwt.Infix open Astring -let my_version = `AV4 - let pp_unix_error ppf e = Fmt.string ppf (Unix.error_message e) let active = ref String.Map.empty @@ -31,8 +29,8 @@ let read_console id name ring fd = Vmm_ring.write ring (t, line) ; (match String.Map.find name !active with | None -> Lwt.return_unit - | Some fd -> - let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = id } in + | Some (version, fd) -> + let header = Vmm_commands.header ~version id in Vmm_lwt.write_wire fd (header, `Data (`Console_data (t, line))) >>= function | Error _ -> Vmm_lwt.safe_close fd >|= fun () -> @@ -87,21 +85,21 @@ let add_fifo id = Lwt.async (fun () -> read_console id name ring f >|= fun () -> fifos `Close) ; Ok () -let subscribe s id = +let subscribe s version id = let name = Vmm_core.Name.to_string id in Logs.debug (fun m -> m "attempting to subscribe %a" Vmm_core.Name.pp id) ; match String.Map.find name !t with | None -> - active := String.Map.add name s !active ; + active := String.Map.add name (version, s) !active ; Lwt.return (None, "waiting for VM") | Some r -> (match String.Map.find name !active with | None -> Lwt.return_unit - | Some s -> Vmm_lwt.safe_close s) >|= fun () -> - active := String.Map.add name s !active ; + | Some (_, s) -> Vmm_lwt.safe_close s) >|= fun () -> + active := String.Map.add name (version, s) !active ; (Some r, "subscribed") -let send_history s r id since = +let send_history s version r id since = let entries = match since with | `Count n -> Vmm_ring.read_last r n @@ -109,7 +107,7 @@ let send_history s r id since = in Logs.debug (fun m -> m "%a found %d history" Vmm_core.Name.pp id (List.length entries)) ; Lwt_list.iter_s (fun (i, v) -> - let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = id } in + let header = Vmm_commands.header ~version id in Vmm_lwt.write_wire s (header, `Data (`Console_data (i, v))) >>= function | Ok () -> Lwt.return_unit | Error _ -> Vmm_lwt.safe_close s) @@ -123,10 +121,7 @@ let handle s addr = Logs.err (fun m -> m "exception while reading") ; Lwt.return_unit | Ok (header, `Command (`Console_cmd cmd)) -> - if not (Vmm_commands.version_eq header.Vmm_commands.version my_version) then begin - Logs.err (fun m -> m "ignoring data with bad version") ; - Lwt.return_unit - end else begin + begin let name = header.Vmm_commands.name in match cmd with | `Console_add -> @@ -135,21 +130,21 @@ let handle s addr = 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 + 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) -> + subscribe s header.Vmm_commands.version 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 () -> + | Some r -> send_history s header.Vmm_commands.version r name ts) >>= fun () -> (* now we wait for the next read and terminate*) Vmm_lwt.read_wire s >|= fun _ -> () end @@ -182,6 +177,6 @@ open Albatross_cli let cmd = Term.(term_result (const jump $ setup_log $ influx)), - Term.info "albatross_console" ~version:"%%VERSION_NUM%%" + Term.info "albatross_console" ~version let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/daemon/albatross_influx.ml b/daemon/albatross_influx.ml index 85e5f04..6052890 100644 --- a/daemon/albatross_influx.ml +++ b/daemon/albatross_influx.ml @@ -156,8 +156,6 @@ module P = struct vm ifd.bridge (String.concat ~sep:"," fields) end -let my_version = `AV4 - let command = ref 1L let str_of_e = function @@ -199,36 +197,30 @@ let rec read_sock_write_tcp drop c ?fd addr = safe_close c >|= fun () -> true | Ok (hdr, `Data (`Stats_data (ru, mem, vmm, ifs))) -> + let name = + let orig = hdr.Vmm_commands.name + and f = if drop then Name.drop_front else (fun a -> a) + in + let n = f orig in + let safe = if Name.is_root n then orig else n in + Name.to_string safe + in + let ru = P.encode_ru name ru in + let mem = match mem with None -> [] | Some m -> [ P.encode_kinfo_mem name m ] in + let vmm = match vmm with None -> [] | Some vmm -> [ P.encode_vmm name vmm ] in + let taps = List.map (P.encode_if name) ifs in + let out = (String.concat ~sep:"\n" (ru :: mem @ vmm @ taps)) ^ "\n" in + Logs.debug (fun m -> m "writing %d via tcp" (String.length out)) ; 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 () -> + Vmm_lwt.write_raw fd (Bytes.unsafe_of_string out) >>= function + | Ok () -> + Logs.debug (fun m -> m "wrote successfully") ; + read_sock_write_tcp drop c ~fd addr + | 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 else - let name = - let orig = hdr.Vmm_commands.name - and f = if drop then Name.drop_front else (fun a -> a) - in - let n = f orig in - let safe = if Name.is_root n then orig else n in - Name.to_string safe - in - let ru = P.encode_ru name ru in - let mem = match mem with None -> [] | Some m -> [ P.encode_kinfo_mem name m ] in - let vmm = match vmm with None -> [] | Some vmm -> [ P.encode_vmm name vmm ] in - let taps = List.map (P.encode_if name) ifs in - let out = (String.concat ~sep:"\n" (ru :: mem @ 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 drop c ~fd addr - | Error e -> - Logs.err (fun m -> m "error %s while writing to tcp (%s)" - (str_of_e e) name) ; - safe_close fd >|= fun () -> - false end | Ok wire -> Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ; @@ -236,7 +228,7 @@ let rec read_sock_write_tcp drop c ?fd addr = read_sock_write_tcp drop c ?fd addr let query_sock vm c = - let header = Vmm_commands.{ version = my_version ; sequence = !command ; name = vm } in + let header = Vmm_commands.header ~sequence:!command vm in command := Int64.succ !command ; Logs.debug (fun m -> m "%Lu requesting %a via socket" !command Name.pp vm) ; Vmm_lwt.write_wire c (header, `Command (`Stats_cmd `Stats_subscribe)) @@ -306,7 +298,7 @@ let cmd = `P "$(tname) connects to a albatross stats socket, pulls statistics and pushes them via TCP to influxdb" ] in Term.(term_result (const run_client $ setup_log $ influx $ opt_vm_name $ drop_label)), - Term.info "albatross_influx" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "albatross_influx" ~version ~doc ~man let () = match Term.eval cmd diff --git a/daemon/albatross_log.ml b/daemon/albatross_log.ml index dd9107f..96b03bd 100644 --- a/daemon/albatross_log.ml +++ b/daemon/albatross_log.ml @@ -10,11 +10,10 @@ open Lwt.Infix -let my_version = `AV4 - let broadcast prefix wire t = - Lwt_list.fold_left_s (fun t (id, s) -> - Vmm_lwt.write_wire s wire >|= function + Lwt_list.fold_left_s (fun t (id, (version, s)) -> + let hdr = Vmm_commands.header ~version prefix in + Vmm_lwt.write_wire s (hdr, wire) >|= function | Ok () -> t | Error `Exception -> Vmm_trie.remove id t) t (Vmm_trie.collect prefix t) @@ -47,7 +46,7 @@ let write_to_file mvar file = get_fd () >>= fun fd -> loop ~log_entry:(Ptime_clock.now (), `Hup) fd | `Entry log_entry -> Lwt.return log_entry) >>= fun log_entry -> - let data = Vmm_asn.log_to_disk my_version log_entry in + let data = Vmm_asn.log_to_disk log_entry in Lwt.catch (fun () -> write_complete fd data >>= fun () -> @@ -67,7 +66,7 @@ let write_to_file mvar file = loop fd >|= fun _ -> () -let send_history s ring id what = +let send_history s version ring id what = let tst event = let sub = Vmm_core.Log.name event in Vmm_core.Name.is_sub ~super:id ~sub @@ -81,7 +80,7 @@ let send_history s ring id what = Lwt_list.fold_left_s (fun r (ts, event) -> match r with | Ok () -> - let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = id } in + let header = Vmm_commands.header ~version id in Vmm_lwt.write_wire s (header, `Data (`Log_data (ts, event))) | Error e -> Lwt.return (Error e)) (Ok ()) elements @@ -89,17 +88,12 @@ let send_history s ring id what = let tree = ref Vmm_trie.empty let handle_data s mvar ring hdr entry = - if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin - Logs.warn (fun m -> m "unsupported version") ; - Lwt.return_unit - end else begin - Vmm_lwt.write_wire s (hdr, `Success `Empty) >>= fun _ -> - Vmm_ring.write ring entry ; - Lwt_mvar.put mvar (`Entry entry) >>= fun () -> - let data' = (hdr, `Data (`Log_data entry)) in - broadcast hdr.Vmm_commands.name data' !tree >|= fun tree' -> - tree := tree' - end + Vmm_lwt.write_wire s (hdr, `Success `Empty) >>= fun _ -> + Vmm_ring.write ring entry ; + Lwt_mvar.put mvar (`Entry entry) >>= fun () -> + let data' = `Data (`Log_data entry) in + broadcast hdr.Vmm_commands.name data' !tree >|= fun tree' -> + tree := tree' let read_data mvar ring s = let rec loop () = @@ -122,27 +116,24 @@ let handle mvar ring s addr = | Error _ -> Logs.err (fun m -> m "error while reading") ; Lwt.return_unit - | Ok (hdr, `Data (`Log_data entry)) -> + | Ok (hdr, `Data `Log_data entry) -> handle_data s mvar ring hdr entry >>= fun () -> read_data mvar ring s - | Ok (hdr, `Command (`Log_cmd lc)) -> - if not (Vmm_commands.version_eq hdr.Vmm_commands.version my_version) then begin - Logs.warn (fun m -> m "unsupported version") ; - Lwt.return_unit - end else begin - match lc with - | `Log_subscribe ts -> - let tree', ret = Vmm_trie.insert hdr.Vmm_commands.name 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 + | Ok (hdr, `Command `Log_cmd `Log_subscribe ts) -> + let tree', ret = + Vmm_trie.insert hdr.Vmm_commands.name (hdr.Vmm_commands.version, 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 + begin + Vmm_lwt.write_wire s (hdr, out) >>= function | Error _ -> Logs.err (fun m -> m "error while sending reply for subscribe") ; Lwt.return_unit | Ok () -> - send_history s ring hdr.Vmm_commands.name ts >>= function + send_history s hdr.Vmm_commands.version ring hdr.Vmm_commands.name ts >>= function | Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit | Ok () -> (* command processing is finished, but we leave the socket open @@ -150,7 +141,7 @@ let handle mvar ring s addr = Vmm_lwt.read_wire s >|= fun _ -> () end | Ok wire -> - Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire) ; + Logs.warn (fun m -> m "ignoring %a" Vmm_commands.pp_wire wire); Lwt.return_unit end >>= fun () -> Vmm_lwt.safe_close s @@ -201,6 +192,6 @@ let read_only = let cmd = Term.(const jump $ setup_log $ file $ read_only $ influx), - Term.info "albatross_log" ~version:"%%VERSION_NUM%%" + Term.info "albatross_log" ~version let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/daemon/albatrossd.ml b/daemon/albatrossd.ml index 260c8a3..2c0c376 100644 --- a/daemon/albatrossd.ml +++ b/daemon/albatrossd.ml @@ -6,11 +6,8 @@ open Vmm_core open Lwt.Infix -let version = `AV4 +let state = ref (Vmm_vmmd.init ()) -let state = ref (Vmm_vmmd.init version) - -let stub_hdr = Vmm_commands.{ version ; sequence = 0L ; name = Name.root } let stub_data_out _ = Lwt.return_unit let create_lock = Lwt_mutex.create () @@ -18,11 +15,11 @@ let create_lock = Lwt_mutex.create () Vmm_vmmd.handle is getting called, and while communicating via log / console / stat socket communication. *) -let rec create stat_out log_out cons_out data_out hdr name config = - (match Vmm_vmmd.handle_create !state hdr name config with +let rec create stat_out log_out cons_out data_out name config = + (match Vmm_vmmd.handle_create !state name config with | Error `Msg msg -> Logs.err (fun m -> m "failed to create %a: %s" Name.pp name msg) ; - Lwt.return (None, (hdr, `Failure msg)) + Lwt.return (None, `Failure msg) | Ok (state', (cons, succ_cont, fail_cont)) -> state := state'; cons_out "create" cons >>= function @@ -43,7 +40,7 @@ let rec create stat_out log_out cons_out data_out hdr name config = if should_restart config name r then Lwt_mutex.with_lock create_lock (fun () -> create stat_out log_out cons_out stub_data_out - stub_hdr name vm.Unikernel.config) + name vm.Unikernel.config) else Lwt.return_unit)); stat_out "setting up stat" stat >>= fun () -> @@ -68,29 +65,28 @@ let rec create stat_out log_out cons_out data_out hdr name config = let handle log_out cons_out stat_out fd addr = Logs.debug (fun m -> m "connection from %a" Vmm_lwt.pp_sockaddr addr) ; - let out wire = - (* TODO should we terminate the connection on write failure? *) - Vmm_lwt.write_wire fd wire >|= fun _ -> () - in - let rec loop () = Logs.debug (fun m -> m "now reading") ; Vmm_lwt.read_wire fd >>= function | Error _ -> Logs.err (fun m -> m "error while reading") ; Lwt.return_unit - | Ok wire -> - Logs.debug (fun m -> m "read %a" Vmm_commands.pp_wire wire) ; + | Ok (hdr, wire) -> + let out wire' = + (* TODO should we terminate the connection on write failure? *) + Vmm_lwt.write_wire fd (hdr, wire') >|= fun _ -> () + in + Logs.debug (fun m -> m "read %a" Vmm_commands.pp_wire (hdr, wire)); Lwt_mutex.lock create_lock >>= fun () -> - match Vmm_vmmd.handle_command !state wire with - | Error wire -> Lwt_mutex.unlock create_lock; out wire + match Vmm_vmmd.handle_command !state (hdr, wire) with + | Error wire' -> Lwt_mutex.unlock create_lock; out wire' | Ok (state', next) -> state := state' ; match next with | `Loop wire -> Lwt_mutex.unlock create_lock; out wire >>= loop | `End wire -> Lwt_mutex.unlock create_lock; out wire - | `Create (hdr, id, vm) -> - create stat_out log_out cons_out out hdr id vm >|= fun () -> + | `Create (id, vm) -> + create stat_out log_out cons_out out id vm >|= fun () -> Lwt_mutex.unlock create_lock | `Wait (who, data) -> let state', task = Vmm_vmmd.register !state who Lwt.task in @@ -98,38 +94,32 @@ let handle log_out cons_out stat_out fd addr = Lwt_mutex.unlock create_lock; task >>= fun r -> out (data r) - | `Wait_and_create (who, (hdr, id, vm)) -> + | `Wait_and_create (who, (id, vm)) -> let state', task = Vmm_vmmd.register !state who Lwt.task in state := state'; Lwt_mutex.unlock create_lock; task >>= fun r -> Logs.info (fun m -> m "wait returned %a" pp_process_exit r); Lwt_mutex.with_lock create_lock (fun () -> - create stat_out log_out cons_out out hdr id vm) + create stat_out log_out cons_out out id vm) in loop () >>= fun () -> Vmm_lwt.safe_close fd -let write_reply name fd txt (header, cmd) = - Vmm_lwt.write_wire fd (header, cmd) >>= function - | Error `Exception -> invalid_arg ("exception during " ^ txt ^ " while writing to " ^ name) +let write_reply name fd txt (hdr, cmd) = + Vmm_lwt.write_wire fd (hdr, cmd) >>= function + | Error `Exception -> + invalid_arg ("exception during " ^ txt ^ " while writing to " ^ name) | Ok () -> Vmm_lwt.read_wire fd >|= function - | Ok (header', reply) -> - if not Vmm_commands.(version_eq header.version header'.version) then begin - Logs.err (fun m -> m "%s: wrong version (got %a, expected %a) in reply from %s" - txt - Vmm_commands.pp_version header'.Vmm_commands.version - Vmm_commands.pp_version header.Vmm_commands.version - name) ; - invalid_arg "bad version received" - end else if not Vmm_commands.(Int64.equal header.sequence header'.sequence) then begin + | Ok (hdr', reply) -> + if not Vmm_commands.(Int64.equal hdr.sequence hdr'.sequence) then begin Logs.err (fun m -> m "%s: wrong id %Lu (expected %Lu) in reply from %s" - txt header'.Vmm_commands.sequence header.Vmm_commands.sequence name) ; + txt hdr'.Vmm_commands.sequence hdr.Vmm_commands.sequence name) ; invalid_arg "wrong sequence number received" end else begin Logs.debug (fun m -> m "%s: received valid reply from %s %a (request %a)" - txt name Vmm_commands.pp_wire (header', reply) Vmm_commands.pp_wire (header,cmd)) ; + txt name Vmm_commands.pp_wire (hdr', reply) Vmm_commands.pp_wire (hdr, cmd)) ; match reply with | `Success _ -> Ok () | `Failure msg -> @@ -187,7 +177,7 @@ let jump _ influx = in Lwt_list.iter_s (fun (name, config) -> - create stat_out log_out cons_out stub_data_out stub_hdr name config) + create stat_out log_out cons_out stub_data_out name config) (Vmm_trie.all old_unikernels) >>= fun () -> Lwt.catch (fun () -> @@ -209,6 +199,6 @@ open Cmdliner let cmd = Term.(const jump $ setup_log $ influx), - Term.info "albatrossd" ~version:"%%VERSION_NUM%%" + Term.info "albatrossd" ~version:Albatross_cli.version let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/provision/albatross_provision.ml b/provision/albatross_provision.ml index 98ac091..9db33c5 100644 --- a/provision/albatross_provision.ml +++ b/provision/albatross_provision.ml @@ -1,7 +1,5 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) -let asn_version = `AV4 - let timestamps validity = let now = Ptime_clock.now () in match Ptime.add_span now (Ptime.Span.of_int_s (Duration.to_sec validity)) with diff --git a/provision/albatross_provision_ca.ml b/provision/albatross_provision_ca.ml index ce35fd7..0d867ef 100644 --- a/provision/albatross_provision_ca.ml +++ b/provision/albatross_provision_ca.ml @@ -40,10 +40,10 @@ let sign_csr dbname cacert key csr days = (* TODO: check delegation! verify whitelisted commands!? *) match albatross_extension csr with | Ok v -> - Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) -> - if not (Vmm_commands.version_eq asn_version version) then + Vmm_asn.of_cert_extension v >>= fun (version, cmd) -> + if not Vmm_commands.(is_current version) then Logs.warn (fun m -> m "version in request (%a) different from our version %a, using ours" - Vmm_commands.pp_version version Vmm_commands.pp_version asn_version); + Vmm_commands.pp_version version Vmm_commands.pp_version Vmm_commands.current); let exts, default_days = match cmd with | `Policy_cmd (`Policy_add _) -> d_exts (), 365 | _ -> l_exts, 1 @@ -53,7 +53,7 @@ let sign_csr dbname cacert key csr days = (* the "false" is here since X509 validation bails on exts marked as critical (as required), but has no way to supply which extensions are actually handled by the application / caller *) - let v' = Vmm_asn.cert_extension_to_cstruct (asn_version, cmd) in + let v' = Vmm_asn.to_cert_extension cmd in let extensions = Extension.(add (Unsupported Vmm_asn.oid) (false, v') exts) in sign ~dbname extensions issuer key csr (Duration.of_day days) | Error e -> Error e @@ -157,7 +157,7 @@ let default_cmd = `P "$(tname) does CA operations (creation, sign, etc.)" ] in Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)), - Term.info "albatross_provision_ca" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "albatross_provision_ca" ~version ~doc ~man let cmds = [ help_cmd ; sign_cmd ; generate_cmd ; (* TODO revoke_cmd *)] diff --git a/provision/albatross_provision_request.ml b/provision/albatross_provision_request.ml index d4c2d32..e3bafa0 100644 --- a/provision/albatross_provision_request.ml +++ b/provision/albatross_provision_request.ml @@ -5,11 +5,9 @@ open Vmm_asn open Rresult.R.Infix -let version = `AV4 - let csr priv name cmd = let ext = - let v = cert_extension_to_cstruct (version, cmd) in + let v = to_cert_extension cmd in X509.Extension.(singleton (Unsupported oid) (false, v)) and name = [ X509.Distinguished_name.(Relative_distinguished_name.singleton (CN name)) ] @@ -199,7 +197,7 @@ let default_cmd = `P "$(tname) creates a certificate signing request for Albatross" ] in Term.(ret (const help $ setup_log $ Term.man_format $ Term.choice_names $ Term.pure None)), - Term.info "albatross_provision_request" ~version:"%%VERSION_NUM%%" ~doc ~man + Term.info "albatross_provision_request" ~version ~doc ~man let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 8809fb0..3982628 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -455,12 +455,10 @@ let version = let f data = match data with | 4 -> `AV4 | 3 -> `AV3 - | 2 -> `AV2 | x -> Asn.S.error (`Parse (Printf.sprintf "unknown version number 0x%X" x)) and g = function | `AV4 -> 4 | `AV3 -> 3 - | `AV2 -> 2 in Asn.S.map f g Asn.S.int @@ -602,8 +600,7 @@ 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 log_to_disk entry = log_disk_to_cstruct (current, entry) let logs_of_disk buf = let rec next acc buf = @@ -655,12 +652,11 @@ let unikernels = let unikernels_of_cstruct, unikernels_to_cstruct = projections_of unikernels -type cert_extension = version * t - let cert_extension = Asn.S.(sequence2 (required ~label:"version" version) (required ~label:"command" wire_command)) -let cert_extension_of_cstruct, cert_extension_to_cstruct = - projections_of cert_extension +let of_cert_extension, to_cert_extension = + let a, b = projections_of cert_extension in + a, (fun d -> b (current, d)) diff --git a/src/vmm_asn.mli b/src/vmm_asn.mli index 6bab81f..c0d34a4 100644 --- a/src/vmm_asn.mli +++ b/src/vmm_asn.mli @@ -17,14 +17,13 @@ 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 log_to_disk : Log.t -> Cstruct.t val logs_of_disk : 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 -val cert_extension_to_cstruct : cert_extension -> Cstruct.t +val of_cert_extension : + Cstruct.t -> (Vmm_commands.version * Vmm_commands.t, [> `Msg of string ]) result +val to_cert_extension : Vmm_commands.t -> Cstruct.t val unikernels_to_cstruct : Unikernel.config Vmm_trie.t -> Cstruct.t val unikernels_of_cstruct : Cstruct.t -> (Unikernel.config Vmm_trie.t, [> `Msg of string ]) result diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index 4fd49f5..35665ea 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -3,22 +3,24 @@ (* the wire protocol *) open Vmm_core -type version = [ `AV2 | `AV3 | `AV4 ] +type version = [ `AV3 | `AV4 ] + +let current = `AV4 let pp_version ppf v = Fmt.int ppf (match v with | `AV4 -> 4 - | `AV3 -> 3 - | `AV2 -> 2) + | `AV3 -> 3) let version_eq a b = match a, b with | `AV4, `AV4 -> true | `AV3, `AV3 -> true - | `AV2, `AV2 -> true | _ -> false +let is_current = version_eq current + type since_count = [ `Since of Ptime.t | `Count of int ] let pp_since_count ppf = function @@ -124,6 +126,8 @@ type header = { name : Name.t ; } +let header ?(version = current) ?(sequence = 0L) name = { version ; sequence ; name } + type success = [ | `Empty | `String of string @@ -142,11 +146,14 @@ let pp_success ppf = function | `Unikernels vms -> Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") Name.pp Unikernel.pp_config)) ppf vms | `Block_devices blocks -> Fmt.(list ~sep:(unit "@.") pp_block) ppf blocks -type wire = header * [ - | `Command of t - | `Success of success - | `Failure of string - | `Data of data ] +type res = [ + | `Command of t + | `Success of success + | `Failure of string + | `Data of data +] + +type wire = header * res let pp_wire ppf (header, data) = let name = header.name in diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index e2abf9c..1c39ac5 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -3,10 +3,12 @@ open Vmm_core (** The type of versions of the grammar defined below. *) -type version = [ `AV2 | `AV3 | `AV4 ] +type version = [ `AV3 | `AV4 ] -(** [version_eq a b] is true if [a] and [b] are equal. *) -val version_eq : version -> version -> bool +(** [current] is the current version. *) +val current : version + +val is_current : version -> bool (** [pp_version ppf version] pretty prints [version] onto [ppf]. *) val pp_version : version Fmt.t @@ -72,6 +74,8 @@ type header = { name : Name.t ; } +val header : ?version:version -> ?sequence:int64 -> Name.t -> header + type success = [ | `Empty | `String of string @@ -80,11 +84,14 @@ type success = [ | `Block_devices of (Name.t * int * bool) list ] -type wire = header * [ - | `Command of t - | `Success of success - | `Failure of string - | `Data of data ] +type res = [ + | `Command of t + | `Success of success + | `Failure of string + | `Data of data +] + +type wire = header * res val pp_wire : wire Fmt.t diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml index a091dd1..fd87cea 100644 --- a/src/vmm_lwt.ml +++ b/src/vmm_lwt.ml @@ -104,10 +104,15 @@ let read_wire s = Cstruct.hexdump_pp (Cstruct.of_bytes buf) Cstruct.hexdump_pp (Cstruct.of_bytes b)) ; *) 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 + | (Ok (hdr, _)) as w -> + if not Vmm_commands.(is_current hdr.version) then + Logs.warn (fun m -> m "version mismatch, received %a current %a" + Vmm_commands.pp_version hdr.Vmm_commands.version + Vmm_commands.pp_version Vmm_commands.current); + w end else begin Lwt.return (Error `Eof) end diff --git a/src/vmm_vmmd.ml b/src/vmm_vmmd.ml index eae669f..ffcb030 100644 --- a/src/vmm_vmmd.ml +++ b/src/vmm_vmmd.ml @@ -8,7 +8,6 @@ open Rresult open R.Infix type 'a t = { - wire_version : Vmm_commands.version ; console_counter : int64 ; stats_counter : int64 ; log_counter : int64 ; @@ -64,9 +63,8 @@ let register_restart t id create = | Some _ -> Logs.err (fun m -> m "restart attempted to overwrite waiter"); None | _ -> Some (register t id create) -let init wire_version = +let init () = let t = { - wire_version ; console_counter = 1L ; stats_counter = 1L ; log_counter = 1L ; @@ -91,12 +89,12 @@ let init wire_version = type 'a create = Vmm_commands.wire * - ('a t -> ('a t * Vmm_commands.wire * Vmm_commands.wire * Vmm_commands.wire * Name.t * Unikernel.t, [ `Msg of string ]) result) * - (unit -> Vmm_commands.wire) + ('a t -> ('a t * Vmm_commands.wire * Vmm_commands.wire * Vmm_commands.res * Name.t * Unikernel.t, [ `Msg of string ]) result) * + (unit -> Vmm_commands.res) let log t name event = let data = (Ptime_clock.now (), event) in - let header = Vmm_commands.{ version = t.wire_version ; sequence = t.log_counter ; name } in + let header = Vmm_commands.header ~sequence:t.log_counter name in let log_counter = Int64.succ t.log_counter in Logs.debug (fun m -> m "log %a" Log.pp data) ; ({ t with log_counter }, (header, `Data (`Log_data data))) @@ -123,16 +121,16 @@ let setup_stats t name vm = in `Stats_add (name, vm.Unikernel.pid, ifs) in - let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in + let header = Vmm_commands.header ~sequence:t.stats_counter name in let t = { t with stats_counter = Int64.succ t.stats_counter } in t, (header, `Command (`Stats_cmd stat_out)) let remove_stats t name = - let header = Vmm_commands.{ version = t.wire_version ; sequence = t.stats_counter ; name } in + let header = Vmm_commands.header ~sequence:t.stats_counter name in let t = { t with stats_counter = Int64.succ t.stats_counter } in (t, (header, `Command (`Stats_cmd `Stats_remove))) -let handle_create t hdr name vm_config = +let handle_create t name vm_config = (match Vmm_resources.find_vm t.resources name with | Some _ -> Error (`Msg "VM with same name is already running") | None -> Ok ()) >>= fun () -> @@ -142,7 +140,7 @@ let handle_create t hdr name 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_commands.{ version = t.wire_version ; sequence = t.console_counter ; name } in + let header = Vmm_commands.header ~sequence:t.console_counter name in (header, `Command (`Console_cmd `Console_add)) in let success t = @@ -170,13 +168,13 @@ let handle_create t hdr name vm_config = log t name start in let t, stat_out = setup_stats t name vm in - (t, stat_out, log_out, (hdr, `Success (`String "created VM")), name, vm) + (t, stat_out, log_out, `Success (`String "created VM"), name, vm) and fail () = match Vmm_unix.free_system_resources name taps with - | Ok () -> (hdr, `Failure "could not create VM: console failed") + | Ok () -> `Failure "could not create VM: console failed" | Error (`Msg msg) -> let m = "could not create VM: console failed, and also " ^ msg ^ " while cleaning resources" in - (hdr, `Failure m) + `Failure m in Ok ({ t with console_counter = Int64.succ t.console_counter }, (cons_out, success, fail)) @@ -190,11 +188,11 @@ let handle_shutdown t name vm r = let t, stat_out = remove_stats t name in (t, stat_out, log_out) -let handle_policy_cmd t reply id = function +let handle_policy_cmd t id = function | `Policy_remove -> Logs.debug (fun m -> m "remove policy %a" Name.pp id) ; Vmm_resources.remove_policy t.resources id >>= fun resources -> - Ok ({ t with resources }, `End (reply (`String "removed policy"))) + Ok ({ t with resources }, `End (`Success (`String "removed policy"))) | `Policy_add policy -> Logs.debug (fun m -> m "insert policy %a" Name.pp id) ; let same_policy = match Vmm_resources.find_policy t.resources id with @@ -202,10 +200,10 @@ let handle_policy_cmd t reply id = function | Some p' -> Policy.equal policy p' in if same_policy then - Ok (t, `Loop (reply (`String "no modification of policy"))) + Ok (t, `Loop (`Success (`String "no modification of policy"))) else Vmm_resources.insert_policy t.resources id policy >>= fun resources -> - Ok ({ t with resources }, `Loop (reply (`String "added policy"))) + Ok ({ t with resources }, `Loop (`Success (`String "added policy"))) | `Policy_info -> Logs.debug (fun m -> m "policy %a" Name.pp id) ; let policies = @@ -218,9 +216,9 @@ let handle_policy_cmd t reply id = function Logs.debug (fun m -> m "policies: couldn't find %a" Name.pp id) ; Error (`Msg "policy: not found") | _ -> - Ok (t, `End (reply (`Policies policies))) + Ok (t, `End (`Success (`Policies policies))) -let handle_unikernel_cmd t reply header id = function +let handle_unikernel_cmd t id = function | `Unikernel_info -> Logs.debug (fun m -> m "info %a" Name.pp id) ; let vms = @@ -233,9 +231,9 @@ let handle_unikernel_cmd t reply header id = function Logs.debug (fun m -> m "info: couldn't find %a" Name.pp id) ; Error (`Msg "info: no unikernel found") | _ -> - Ok (t, `End (reply (`Unikernels vms))) + Ok (t, `End (`Success (`Unikernels vms))) end - | `Unikernel_create vm_config -> Ok (t, `Create (header, id, vm_config)) + | `Unikernel_create vm_config -> Ok (t, `Create (id, vm_config)) | `Unikernel_force_create vm_config -> begin let resources = @@ -244,12 +242,12 @@ let handle_unikernel_cmd t reply header id = function in Vmm_resources.check_vm resources id vm_config >>= fun () -> match Vmm_resources.find_vm t.resources id with - | None -> Ok (t, `Create (header, id, vm_config)) + | None -> Ok (t, `Create (id, vm_config)) | Some vm -> (match Vmm_unix.destroy vm with | exception Unix.Unix_error _ -> () | () -> ()); - Ok (t, `Wait_and_create (id, (header, id, vm_config))) + Ok (t, `Wait_and_create (id, (id, vm_config))) end | `Unikernel_destroy -> match Vmm_resources.find_vm t.resources id with @@ -263,11 +261,11 @@ let handle_unikernel_cmd t reply header id = function in let s ex = let data = Fmt.strf "%a %s %a" Name.pp id answer pp_process_exit ex in - reply (`String data) + `Success (`String data) in Ok (t, `Wait (id, s)) -let handle_block_cmd t reply id = function +let handle_block_cmd t id = function | `Block_remove -> Logs.debug (fun m -> m "removing block %a" Name.pp id) ; begin match Vmm_resources.find_block t.resources id with @@ -276,7 +274,7 @@ let handle_block_cmd t reply id = function | Some (_, false) -> Vmm_unix.destroy_block id >>= fun () -> Vmm_resources.remove_block t.resources id >>= fun resources -> - Ok ({ t with resources }, `End (reply (`String "removed block"))) + Ok ({ t with resources }, `End (`Success (`String "removed block"))) end | `Block_add size -> begin @@ -287,7 +285,7 @@ let handle_block_cmd t reply id = function Vmm_resources.check_block t.resources id size >>= fun () -> Vmm_unix.create_block id size >>= fun () -> Vmm_resources.insert_block t.resources id size >>= fun resources -> - Ok ({ t with resources }, `Loop (reply (`String "added block device"))) + Ok ({ t with resources }, `Loop (`Success (`String "added block device"))) end | `Block_info -> Logs.debug (fun m -> m "block %a" Name.pp id) ; @@ -301,22 +299,21 @@ let handle_block_cmd t reply id = function Logs.debug (fun m -> m "block: couldn't find %a" Name.pp id) ; Error (`Msg "block: not found") | _ -> - Ok (t, `End (reply (`Block_devices blocks))) + Ok (t, `End (`Success (`Block_devices blocks))) let handle_command t (header, payload) = let msg_to_err = function | Ok x -> Ok x | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; - Error (header, `Failure msg) - and reply x = (header, `Success x) + Error (`Failure msg) and id = header.Vmm_commands.name in msg_to_err ( match payload with - | `Command (`Policy_cmd pc) -> handle_policy_cmd t reply id pc - | `Command (`Unikernel_cmd vc) -> handle_unikernel_cmd t reply header id vc - | `Command (`Block_cmd bc) -> handle_block_cmd t reply id bc + | `Command (`Policy_cmd pc) -> handle_policy_cmd t id pc + | `Command (`Unikernel_cmd vc) -> handle_unikernel_cmd t id vc + | `Command (`Block_cmd bc) -> handle_block_cmd t id bc | _ -> Logs.err (fun m -> m "ignoring %a" Vmm_commands.pp_wire (header, payload)) ; Error (`Msg "unknown command")) diff --git a/src/vmm_vmmd.mli b/src/vmm_vmmd.mli index 64f21fc..787a8b1 100644 --- a/src/vmm_vmmd.mli +++ b/src/vmm_vmmd.mli @@ -4,7 +4,7 @@ open Vmm_core type 'a t -val init : Vmm_commands.version -> 'a t +val init : unit -> 'a t val waiter : 'a t -> Name.t -> 'a t * 'a option @@ -14,25 +14,23 @@ val register_restart : 'a t -> Name.t -> (unit -> 'b * 'a) -> ('a t * 'b) option type 'a create = Vmm_commands.wire * - ('a t -> ('a t * Vmm_commands.wire * Vmm_commands.wire * Vmm_commands.wire * - Name.t * Unikernel.t, [ `Msg of string ]) result) * - (unit -> Vmm_commands.wire) + ('a t -> ('a t * Vmm_commands.wire * Vmm_commands.wire * Vmm_commands.res * Name.t * Unikernel.t, [ `Msg of string ]) result) * + (unit -> Vmm_commands.res) val handle_shutdown : 'a t -> Name.t -> Unikernel.t -> [ `Exit of int | `Signal of int | `Stop of int ] -> 'a t * Vmm_commands.wire * Vmm_commands.wire -val handle_create : 'a t -> Vmm_commands.header -> - Name.t -> Unikernel.config -> +val handle_create : 'a t -> Name.t -> Unikernel.config -> ('a t * 'a create, [> `Msg of string ]) result val handle_command : 'a t -> Vmm_commands.wire -> ('a t * - [ `Create of Vmm_commands.header * Name.t * Unikernel.config - | `Loop of Vmm_commands.wire - | `End of Vmm_commands.wire - | `Wait of Name.t * (process_exit -> Vmm_commands.wire) - | `Wait_and_create of Name.t * (Vmm_commands.header * Name.t * Unikernel.config) ], - Vmm_commands.wire) result + [ `Create of Name.t * Unikernel.config + | `Loop of Vmm_commands.res + | `End of Vmm_commands.res + | `Wait of Name.t * (process_exit -> Vmm_commands.res) + | `Wait_and_create of Name.t * (Name.t * Unikernel.config) ], + Vmm_commands.res) result val killall : 'a t -> bool diff --git a/stats/albatross_stat_client.ml b/stats/albatross_stat_client.ml index ca491d6..97f0b72 100644 --- a/stats/albatross_stat_client.ml +++ b/stats/albatross_stat_client.ml @@ -69,6 +69,6 @@ let vmname = let cmd = Term.(term_result (const jump $ setup_log $ pid $ vmname $ interval)), - Term.info "albatross_stat_client" ~version:"%%VERSION_NUM%%" + Term.info "albatross_stat_client" ~version let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/stats/albatross_stats.ml b/stats/albatross_stats.ml index 3f228ad..eca2242 100644 --- a/stats/albatross_stats.ml +++ b/stats/albatross_stats.ml @@ -40,7 +40,7 @@ let handle s addr = Vmm_lwt.write_wire s (fst wire, `Success (`String out)) >>= function | Ok () -> (match close with - | Some s' -> + | Some (_, s') -> Vmm_lwt.safe_close s' >>= fun () -> (* read the next *) loop () @@ -90,6 +90,6 @@ let interval = let cmd = Term.(term_result (const jump $ setup_log $ interval $ influx)), - Term.info "albatross_stats" ~version:"%%VERSION_NUM%%" + Term.info "albatross_stats" ~version let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/stats/albatross_stats_pure.ml b/stats/albatross_stats_pure.ml index 46002d8..e702ba8 100644 --- a/stats/albatross_stats_pure.ml +++ b/stats/albatross_stats_pure.ml @@ -17,8 +17,6 @@ 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 = `AV4 - let descr = ref [] type 'a t = { @@ -139,11 +137,11 @@ let tick t = ru', mem, vmm', ifd in let outs = - List.fold_left (fun out (id, socket) -> + List.fold_left (fun out (id, (version, socket)) -> match Vmm_core.Name.drop_super ~super:id ~sub:vmid with | None -> Logs.err (fun m -> m "couldn't drop super %a from sub %a" Vmm_core.Name.pp id Vmm_core.Name.pp vmid) ; out | Some real_id -> - let header = Vmm_commands.{ version = my_version ; sequence = 0L ; name = real_id } in + let header = Vmm_commands.header ~version real_id in ((socket, id, (header, `Data (`Stats_data stats))) :: out)) out xs in @@ -178,28 +176,24 @@ let add_pid t vmid vmmdev pid nics = assert (ret = None) ; Ok { t with pid_nic ; vmid_pid } -let handle t socket (header, wire) = - if not (Vmm_commands.version_eq my_version header.Vmm_commands.version) then begin - Logs.err (fun m -> m "invalid version %a (mine is %a)" - Vmm_commands.pp_version header.Vmm_commands.version - Vmm_commands.pp_version my_version) ; - Error (`Msg "cannot handle version") - end else - match wire with - | `Command (`Stats_cmd cmd) -> - begin - let id = header.Vmm_commands.name in - match cmd with - | `Stats_add (vmmdev, pid, taps) -> - add_pid t id vmmdev pid taps >>= fun t -> - Ok (t, None, "added") - | `Stats_remove -> - let t = remove_vmid t id in - Ok (t, None, "removed") - | `Stats_subscribe -> - let name_sockets, close = Vmm_trie.insert id socket t.name_sockets in - Ok ({ t with name_sockets }, close, "subscribed") - end - | _ -> - Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire (header, wire)) ; - Error (`Msg "unexpected command") +let handle t socket (hdr, wire) = + match wire with + | `Command (`Stats_cmd cmd) -> + begin + let id = hdr.Vmm_commands.name in + match cmd with + | `Stats_add (vmmdev, pid, taps) -> + add_pid t id vmmdev pid taps >>= fun t -> + Ok (t, None, "added") + | `Stats_remove -> + let t = remove_vmid t id in + Ok (t, None, "removed") + | `Stats_subscribe -> + let name_sockets, close = + Vmm_trie.insert id (hdr.Vmm_commands.version, socket) t.name_sockets + in + Ok ({ t with name_sockets }, close, "subscribed") + end + | _ -> + Logs.err (fun m -> m "unexpected wire %a" Vmm_commands.pp_wire (hdr, wire)) ; + Error (`Msg "unexpected command") diff --git a/tls/albatross_tls_common.ml b/tls/albatross_tls_common.ml index 9f35500..eada76b 100644 --- a/tls/albatross_tls_common.ml +++ b/tls/albatross_tls_common.ml @@ -2,8 +2,6 @@ open Lwt.Infix -let my_version = `AV4 - let command = ref 0L let tls_config cacert cert priv_key = @@ -32,92 +30,87 @@ let client_auth ca tls = | `Ok epoch -> Lwt.return epoch.Tls.Core.peer_certificate_chain | `Error -> Lwt.fail_with "error while getting epoch") -let read fd tls = +let read version fd tls = (* now we busy read and process output *) let rec loop () = Vmm_lwt.read_wire fd >>= function - | Error _ -> Lwt.return (Error (`Msg "exception while reading")) - | Ok wire -> - Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire wire) ; + | Error _ -> Lwt.return (`Failure "exception while reading from fd") + | Ok (hdr, pay) -> + Logs.debug (fun m -> m "read proxying %a" Vmm_commands.pp_wire (hdr, pay)) ; + let wire = { hdr with version }, pay in Vmm_tls_lwt.write_tls tls wire >>= function | Ok () -> loop () - | Error `Exception -> Lwt.return (Error (`Msg "exception")) + | Error `Exception -> Lwt.return (`Failure "exception") in loop () -let process fd tls = - Vmm_lwt.read_wire fd >>= function - | Error _ -> Lwt.return (Error (`Msg "read error")) - | Ok wire -> - (* TODO check version *) - Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire wire) ; - Vmm_tls_lwt.write_tls tls wire >|= function - | Ok () -> Ok () - | Error `Exception -> Error (`Msg "exception on write") +let process fd = + Vmm_lwt.read_wire fd >|= function + | Error _ -> `Failure "error reading from fd" + | Ok (hdr, pay) -> + Logs.debug (fun m -> m "proxying %a" Vmm_commands.pp_wire (hdr, pay)); + pay let handle ca tls = client_auth ca tls >>= fun chain -> - match Vmm_tls.handle my_version chain with - | Error (`Msg m) -> Lwt.fail_with m - | Ok (name, policies, cmd) -> - let sock, next = Vmm_commands.endpoint cmd in - let sockaddr = Lwt_unix.ADDR_UNIX (Vmm_core.socket_path sock) in - Vmm_lwt.connect Lwt_unix.PF_UNIX sockaddr >>= function - | None -> - let err = - Rresult.R.error_msgf "failed to connect to %a" Vmm_lwt.pp_sockaddr sockaddr - in - Lwt.return err - | Some fd -> - (match sock with - | `Vmmd -> - Lwt_list.fold_left_s (fun r (id, policy) -> - match r with - | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) - | Ok () -> - Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.Policy.pp policy) ; - let header = Vmm_commands.{version = my_version ; sequence = !command ; name = 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")) + match Vmm_tls.handle chain with + | Error `Msg msg -> + Logs.err (fun m -> m "failed to handle TLS connection %s" msg); + Lwt.return_unit + | Ok (name, policies, version, cmd) -> + begin + let sock, next = Vmm_commands.endpoint cmd in + let sockaddr = Lwt_unix.ADDR_UNIX (Vmm_core.socket_path sock) in + Vmm_lwt.connect Lwt_unix.PF_UNIX sockaddr >>= function + | None -> + Logs.warn (fun m -> m "failed to connect to %a" Vmm_lwt.pp_sockaddr sockaddr); + Lwt.return (`Failure "couldn't reach service") + | Some fd -> + (match sock with + | `Vmmd -> + Lwt_list.fold_left_s (fun r (id, policy) -> + match r with + | Error (`Msg msg) -> Lwt.return (Error (`Msg msg)) | Ok () -> - Vmm_lwt.read_wire fd >|= function - (* TODO check version *) - | Error _ -> Error (`Msg "read error after writing policy") - | Ok (_, `Success _) -> Ok () - | Ok wire -> - Rresult.R.error_msgf - "expected success when adding policy, got: %a" - Vmm_commands.pp_wire wire) - (Ok ()) policies - | _ -> Lwt.return (Ok ())) >>= function - | Error (`Msg msg) -> - begin - Logs.warn (fun m -> m "error while applying policies %s" msg) ; - let wire = - let header = Vmm_commands.{version = my_version ; sequence = 0L ; name } in - header, `Failure msg - in - Vmm_tls_lwt.write_tls tls wire >>= fun _ -> - Vmm_lwt.safe_close fd >>= fun () -> - Lwt.fail_with msg - end - | Ok () -> - let wire = - let header = Vmm_commands.{version = my_version ; sequence = !command ; name } in - command := Int64.succ !command ; - (header, `Command cmd) - in - Vmm_lwt.write_wire fd wire >>= function - | Error `Exception -> - 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 -> + Logs.debug (fun m -> m "adding policy for %a: %a" Vmm_core.Name.pp id Vmm_core.Policy.pp policy) ; + let header = Vmm_commands.header ~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 after writing policy") + | Ok (_, `Success _) -> Ok () + | Ok wire -> + Rresult.R.error_msgf + "expected success when adding policy, got: %a" + Vmm_commands.pp_wire wire) + (Ok ()) policies + | _ -> Lwt.return (Ok ())) >>= function + | Error (`Msg msg) -> Vmm_lwt.safe_close fd >|= fun () -> - res + Logs.warn (fun m -> m "error while applying policies %s" msg) ; + `Failure msg + | Ok () -> + let wire = + let header = Vmm_commands.header ~sequence:!command name in + command := Int64.succ !command ; + (header, `Command cmd) + in + Vmm_lwt.write_wire fd wire >>= function + | Error `Exception -> + Vmm_lwt.safe_close fd >|= fun () -> + `Failure "couldn't write unikernel to VMMD" + | Ok () -> + (match next with + | `Read -> read version fd tls + | `End -> process fd) >>= fun res -> + Vmm_lwt.safe_close fd >|= fun () -> + res + end >>= fun reply -> + Vmm_tls_lwt.write_tls tls + (Vmm_commands.header ~version name, reply) >|= fun _ -> + () open Cmdliner diff --git a/tls/albatross_tls_endpoint.ml b/tls/albatross_tls_endpoint.ml index 74d0367..0861e64 100644 --- a/tls/albatross_tls_endpoint.ml +++ b/tls/albatross_tls_endpoint.ml @@ -30,9 +30,7 @@ let jump _ cacert cert priv_key port = Lwt.async (fun () -> Lwt.catch (fun () -> - (handle ca t >|= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg) - | Ok () -> ()) >>= fun () -> + handle ca t >>= fun () -> Vmm_tls_lwt.close t) (fun e -> Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ; @@ -60,6 +58,6 @@ let port = let cmd = Term.(const jump $ setup_log $ cacert $ cert $ key $ port), - Term.info "albatross_tls_endpoint" ~version:"%%VERSION_NUM%%" + Term.info "albatross_tls_endpoint" ~version let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/tls/albatross_tls_inetd.ml b/tls/albatross_tls_inetd.ml index f5d3880..c749ab5 100644 --- a/tls/albatross_tls_inetd.ml +++ b/tls/albatross_tls_inetd.ml @@ -16,9 +16,7 @@ let jump cacert cert priv_key = Lwt.fail exn) >>= fun t -> Lwt.catch (fun () -> - (handle ca t >|= function - | Error (`Msg msg) -> Logs.err (fun m -> m "error in handle %s" msg) - | Ok () -> ()) >>= fun () -> + handle ca t >>= fun () -> Vmm_tls_lwt.close t) (fun e -> Logs.err (fun m -> m "error while handle() %s" (Printexc.to_string e)) ; @@ -28,6 +26,6 @@ open Cmdliner let cmd = Term.(const jump $ cacert $ cert $ key), - Term.info "albatross_tls_inetd" ~version:"%%VERSION_NUM%%" + Term.info "albatross_tls_inetd" ~version:Albatross_cli.version let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/tls/vmm_tls.ml b/tls/vmm_tls.ml index 6db8fb3..09ab5ef 100644 --- a/tls/vmm_tls.ml +++ b/tls/vmm_tls.ml @@ -11,7 +11,7 @@ let cert_name cert = | Some (_, data) -> match X509.(Distinguished_name.common_name (Certificate.subject cert)) with | Some name -> Ok (Some name) - | None -> match Vmm_asn.cert_extension_of_cstruct data with + | None -> match Vmm_asn.of_cert_extension data with | Error (`Msg _) -> Error (`Msg "couldn't parse albatross extension") | Ok (_, `Policy_cmd pc) -> begin match pc with @@ -44,36 +44,33 @@ let separate_chain = function | [ leaf ] -> Ok (leaf, []) | leaf :: xs -> Ok (leaf, List.rev xs) -let wire_command_of_cert version cert = +let wire_command_of_cert cert = match Extension.(find (Unsupported Vmm_asn.oid) (Certificate.extensions cert)) with | 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 - Error (`Version v) - else - Ok wire + Vmm_asn.of_cert_extension data >>= fun (v, wire) -> + if not Vmm_commands.(is_current v) then + Logs.warn (fun m -> m "version mismatch, received %a current %a" + Vmm_commands.pp_version v + Vmm_commands.pp_version Vmm_commands.current); + Ok (v, wire) -let extract_policies version chain = +let extract_policies chain = List.fold_left (fun acc cert -> - match acc, wire_command_of_cert version cert with + match acc, wire_command_of_cert cert with | Error e, _ -> Error e | Ok acc, Error `Not_present -> Ok acc | Ok _, Error (`Msg 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)) -> + | Ok (prefix, acc), Ok (_, `Policy_cmd `Policy_add p) -> (cert_name cert >>= function | None -> Ok prefix | Some x -> Vmm_core.Name.prepend x prefix) >>| fun name -> (name, (name, p) :: acc) | _, Ok wire -> - R.error_msgf "unexpected wire %a" Vmm_commands.pp wire) + R.error_msgf "unexpected wire %a" Vmm_commands.pp (snd wire)) (Ok (Vmm_core.Name.root, [])) chain -let handle version chain = +let handle chain = (if List.length chain < 10 then Ok () else @@ -90,22 +87,18 @@ let handle version chain = Logs.debug (fun m -> m "name is %a leaf is %a, chain %a" Vmm_core.Name.pp name Certificate.pp leaf Fmt.(list ~sep:(unit " -> ") Certificate.pp) rest); - extract_policies version rest >>= fun (_, policies) -> + extract_policies rest >>= fun (_, policies) -> (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) - match wire_command_of_cert version leaf with - | Error (`Msg p) -> Error (`Msg p) - | Error (`Not_present) -> + match wire_command_of_cert leaf with + | Error `Msg 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 -> + | Ok (v, wire) -> (* we only allow some commands via certificate *) match wire with | `Console_cmd (`Console_subscribe _) | `Stats_cmd `Stats_subscribe | `Log_cmd (`Log_subscribe _) | `Unikernel_cmd _ - | `Policy_cmd `Policy_info -> Ok (name, policies, wire) + | `Policy_cmd `Policy_info -> Ok (name, policies, v, wire) | _ -> Error (`Msg "unexpected command") diff --git a/tls/vmm_tls.mli b/tls/vmm_tls.mli index b534dfe..40420d1 100644 --- a/tls/vmm_tls.mli +++ b/tls/vmm_tls.mli @@ -1,10 +1,9 @@ (* (c) 2018 Hannes Mehnert, all rights reserved *) -val wire_command_of_cert : Vmm_commands.version -> X509.Certificate.t -> - (Vmm_commands.t, [> `Msg of string | `Not_present | `Version of Vmm_commands.version ]) result +val wire_command_of_cert : X509.Certificate.t -> + (Vmm_commands.version * Vmm_commands.t, [> `Msg of string | `Not_present ]) result val handle : - Vmm_commands.version -> X509.Certificate.t list -> - (Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.Policy.t) list * Vmm_commands.t, - [> `Msg of string ]) Result.result + (Vmm_core.Name.t * (Vmm_core.Name.t * Vmm_core.Policy.t) list * Vmm_commands.version * Vmm_commands.t, + [> `Msg of string ]) result diff --git a/tls/vmm_tls_lwt.ml b/tls/vmm_tls_lwt.ml index 99ad308..8955ed0 100644 --- a/tls/vmm_tls_lwt.ml +++ b/tls/vmm_tls_lwt.ml @@ -40,10 +40,15 @@ let read_tls t = 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 + | (Ok (hdr, _)) as w -> + if not Vmm_commands.(is_current hdr.version) then + Logs.warn (fun m -> m "version mismatch, received %a current %a" + Vmm_commands.pp_version hdr.Vmm_commands.version + Vmm_commands.pp_version Vmm_commands.current); + w else Lwt.return (Error `Eof)