From af0473957526109a44b0b18b15419d7a2c3b76e1 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sun, 10 Nov 2019 23:23:42 +0100 Subject: [PATCH 1/5] albatross_ca: default to 1 day for leaf certificates, 1 year for intermediate policy_add certificates --- provision/albatross_provision_ca.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/provision/albatross_provision_ca.ml b/provision/albatross_provision_ca.ml index 51bc536..fa28da5 100644 --- a/provision/albatross_provision_ca.ml +++ b/provision/albatross_provision_ca.ml @@ -45,10 +45,11 @@ let sign_csr dbname cacert key csr days = Ok () else Error (`Msg "unknown version in request")) >>= fun () -> - let exts = match cmd with - | `Policy_cmd (`Policy_add _) -> d_exts () - | _ -> l_exts + let exts, default_days = match cmd with + | `Policy_cmd (`Policy_add _) -> d_exts (), 365 + | _ -> l_exts, 1 in + let days = match days with None -> default_days | Some x -> x in Logs.app (fun m -> m "signing %a" Vmm_commands.pp cmd); (* the "false" is here since X509 validation bails on exts marked as critical (as required), but has no way to supply which extensions @@ -121,7 +122,7 @@ let generate_cmd = let days = let doc = "Number of days" in - Arg.(value & opt int 1 & info [ "days" ] ~doc) + Arg.(value & opt (some int) None & info [ "days" ] ~doc) let cacert = let doc = "cacert" in From 365a569b25aa8417432c2710c1b2895f06adc3b0 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 11 Nov 2019 19:18:48 +0100 Subject: [PATCH 2/5] albatross_ca: compare request vs my version, write mine, bump to AV4 --- provision/albatross_provision.ml | 2 +- provision/albatross_provision_ca.ml | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/provision/albatross_provision.ml b/provision/albatross_provision.ml index 4cd9b43..98ac091 100644 --- a/provision/albatross_provision.ml +++ b/provision/albatross_provision.ml @@ -1,6 +1,6 @@ (* (c) 2017 Hannes Mehnert, all rights reserved *) -let asn_version = `AV2 +let asn_version = `AV4 let timestamps validity = let now = Ptime_clock.now () in diff --git a/provision/albatross_provision_ca.ml b/provision/albatross_provision_ca.ml index fa28da5..ce35fd7 100644 --- a/provision/albatross_provision_ca.ml +++ b/provision/albatross_provision_ca.ml @@ -41,10 +41,9 @@ let sign_csr dbname cacert key csr days = match albatross_extension csr with | Ok v -> Vmm_asn.cert_extension_of_cstruct v >>= fun (version, cmd) -> - (if Vmm_commands.version_eq version version then - Ok () - else - Error (`Msg "unknown version in request")) >>= fun () -> + if not (Vmm_commands.version_eq asn_version 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); let exts, default_days = match cmd with | `Policy_cmd (`Policy_add _) -> d_exts (), 365 | _ -> l_exts, 1 @@ -54,7 +53,8 @@ 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 extensions = Extension.(add (Unsupported Vmm_asn.oid) (false, v) exts) in + let v' = Vmm_asn.cert_extension_to_cstruct (asn_version, 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 From 784429744c2752c228d58a3f908f138a58a43a67 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 11 Nov 2019 21:49:51 +0100 Subject: [PATCH 3/5] 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) From ff067255b028f0c3ba80b7100fba13863e94ed40 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 11 Nov 2019 22:11:22 +0100 Subject: [PATCH 4/5] albatrossd: acquire lock for restore --- daemon/albatrossd.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/daemon/albatrossd.ml b/daemon/albatrossd.ml index 2c0c376..4398471 100644 --- a/daemon/albatrossd.ml +++ b/daemon/albatrossd.ml @@ -177,7 +177,8 @@ let jump _ influx = in Lwt_list.iter_s (fun (name, config) -> - create stat_out log_out cons_out stub_data_out name config) + Lwt_mutex.with_lock create_lock (fun () -> + create stat_out log_out cons_out stub_data_out name config)) (Vmm_trie.all old_unikernels) >>= fun () -> Lwt.catch (fun () -> From 13e731b78e8d00468f21c9b0d0d88ecb3aaba665 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 11 Nov 2019 22:30:53 +0100 Subject: [PATCH 5/5] albatross tls: re-allow root in leaf certificate (i.e. root) to fix log and info commands via tls this is an interaction of 057dbbf14700699f4fd6a193c35084835918c5eb (allow multiple labels in leaf certificates) and a579a8e1434150915eb65acf3f73ae10a525e54f (print root as "." instead of "") --- client/albatross_client_bistro.ml | 2 +- tls/vmm_tls.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/client/albatross_client_bistro.ml b/client/albatross_client_bistro.ml index b8ba4b6..691c295 100644 --- a/client/albatross_client_bistro.ml +++ b/client/albatross_client_bistro.ml @@ -9,7 +9,7 @@ let read fd = let rec loop () = Vmm_tls_lwt.read_tls fd >>= function | Error `Eof -> - Logs.warn (fun m -> m "eof from server"); + Logs.debug (fun m -> m "eof from server"); Lwt.return (Ok ()) | Error _ -> Lwt.return (Error (`Msg ("read failure"))) | Ok wire -> diff --git a/tls/vmm_tls.ml b/tls/vmm_tls.ml index 09ab5ef..f065927 100644 --- a/tls/vmm_tls.ml +++ b/tls/vmm_tls.ml @@ -80,7 +80,7 @@ let handle chain = name rest >>= fun name' -> (* and subject common name of leaf certificate -- allowing dots in CN -- as postfix *) (cert_name leaf >>= function - | None -> Ok name' + | None | Some "." -> Ok name' | Some x -> Vmm_core.Name.of_string x >>| fun post -> Vmm_core.Name.concat name' post) >>= fun name ->