diff --git a/app/vmm_console.ml b/app/vmm_console.ml index 1fb787d..7bb03ba 100644 --- a/app/vmm_console.ml +++ b/app/vmm_console.ml @@ -80,7 +80,7 @@ let add_fifo id = | None -> Error (`Msg "opening") -let subscribe s id = +let subscribe s id since = let name = Vmm_core.string_of_id id in Logs.debug (fun m -> m "attempting to attach %a" Vmm_core.pp_id id) ; match String.Map.find name !t with @@ -88,7 +88,11 @@ let subscribe s id = active := String.Map.add name s !active ; Lwt.return (Ok "waiing for VM") | Some r -> - let entries = Vmm_ring.read r in + let entries = + match since with + | None -> Vmm_ring.read r + | Some ts -> Vmm_ring.read_history r ts + in Logs.debug (fun m -> m "found %d history" (List.length entries)) ; Lwt_list.iter_s (fun (i, v) -> let header = Vmm_commands.{ version = my_version ; sequence = 0L ; id } in @@ -114,7 +118,8 @@ let handle s addr () = else match cmd with | `Console_add -> add_fifo header.Vmm_commands.id - | `Console_subscribe -> subscribe s header.Vmm_commands.id) >>= (function + | `Console_subscribe ts -> subscribe s header.Vmm_commands.id ts) + >>= (function | Ok msg -> Vmm_lwt.write_wire s (header, `Success (`String msg)) | Error (`Msg msg) -> Logs.err (fun m -> m "error while processing command: %s" msg) ; diff --git a/app/vmm_log.ml b/app/vmm_log.ml index bc6bc73..5578e2e 100644 --- a/app/vmm_log.ml +++ b/app/vmm_log.ml @@ -55,8 +55,12 @@ let write_to_file file = let tree = ref Vmm_trie.empty -let send_history s ring id = - let elements = Vmm_ring.read ring in +let send_history s ring id ts = + let elements = + match ts with + | None -> Vmm_ring.read ring + | Some since -> Vmm_ring.read_history ring since + in let res = List.fold_left (fun acc (_, x) -> let cs = Cstruct.of_string x in @@ -112,7 +116,7 @@ let handle mvar ring s addr () = Lwt.return_unit end else begin match lc with - | `Log_subscribe -> + | `Log_subscribe ts -> let tree', ret = Vmm_trie.insert hdr.Vmm_commands.id s !tree in tree := tree' ; (match ret with @@ -124,7 +128,7 @@ let handle mvar ring s addr () = Logs.err (fun m -> m "error while sending reply for subscribe") ; Lwt.return_unit | Ok () -> - send_history s ring hdr.Vmm_commands.id >>= function + send_history s ring hdr.Vmm_commands.id ts >>= function | Error _ -> Logs.err (fun m -> m "error while sending history") ; Lwt.return_unit diff --git a/app/vmmc.ml b/app/vmmc.ml index 5904d32..d0d2889 100644 --- a/app/vmmc.ml +++ b/app/vmmc.ml @@ -103,11 +103,14 @@ let create _ opt_socket force name image cpuid requested_memory boot_params bloc in jump opt_socket name (`Vm_cmd cmd) -let console _ opt_socket name = jump opt_socket name (`Console_cmd `Console_subscribe) +let console _ opt_socket name since = + jump opt_socket name (`Console_cmd (`Console_subscribe since)) -let stats _ opt_socket name = jump opt_socket name (`Stats_cmd `Stats_subscribe) +let stats _ opt_socket name = + jump opt_socket name (`Stats_cmd `Stats_subscribe) -let event_log _ opt_socket name = jump opt_socket name (`Log_cmd `Log_subscribe) +let event_log _ opt_socket name since = + jump opt_socket name (`Log_cmd (`Log_subscribe since)) let help _ _ man_format cmds = function | None -> `Help (`Pager, None) @@ -265,13 +268,24 @@ let create_cmd = Term.(ret (const create $ setup_log $ socket $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), Term.info "create" ~doc ~man +let timestamp_c = + let parse s = match Ptime.of_rfc3339 s with + | Ok (t, _, _) -> `Ok t + | Error _ -> `Error "couldn't parse timestamp" + in + (parse, Ptime.pp_rfc3339 ()) + +let since = + let doc = "Since" in + Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc) + let console_cmd = let doc = "console of a VM" in let man = [`S "DESCRIPTION"; `P "Shows console output of a VM."] in - Term.(ret (const console $ setup_log $ socket $ vm_name)), + Term.(ret (const console $ setup_log $ socket $ vm_name $ since)), Term.info "console" ~doc ~man let stats_cmd = @@ -289,7 +303,7 @@ let log_cmd = [`S "DESCRIPTION"; `P "Shows event log of VM."] in - Term.(ret (const event_log $ setup_log $ socket $ opt_vmname)), + Term.(ret (const event_log $ setup_log $ socket $ opt_vmname $ since)), Term.info "log" ~doc ~man let help_cmd = diff --git a/src/vmm_asn.ml b/src/vmm_asn.ml index 6c67020..c1f6ec2 100644 --- a/src/vmm_asn.ml +++ b/src/vmm_asn.ml @@ -90,15 +90,15 @@ let image = let console_cmd = let f = function | `C1 () -> `Console_add - | `C2 () -> `Console_subscribe + | `C2 ts -> `Console_subscribe ts and g = function | `Console_add -> `C1 () - | `Console_subscribe -> `C2 () + | `Console_subscribe ts -> `C2 ts in Asn.S.map f g @@ Asn.S.(choice2 (explicit 0 null) - (explicit 1 null)) + (explicit 1 (sequence (single (optional ~label:"since" utc_time))))) (* TODO is this good? *) let int64 = @@ -246,12 +246,12 @@ let log_event = let log_cmd = let f = function - | () -> `Log_subscribe + | ts -> `Log_subscribe ts and g = function - | `Log_subscribe -> () + | `Log_subscribe ts -> ts in Asn.S.map f g @@ - Asn.S.null + Asn.S.(sequence (single (optional ~label:"since" utc_time))) let vm_config = let f (cpuid, requested_memory, block_device, network, vmimage, argv) = @@ -426,7 +426,7 @@ let wire = (explicit 2 utf8_string) (explicit 3 data)))) -let wire_of_cstruct, (wire_to_cstruct : Vmm_commands.wire -> Cstruct.t) = projections_of wire +let wire_of_cstruct, wire_to_cstruct = projections_of wire let log_entry = Asn.S.(sequence2 diff --git a/src/vmm_commands.ml b/src/vmm_commands.ml index 03b486f..533c607 100644 --- a/src/vmm_commands.ml +++ b/src/vmm_commands.ml @@ -21,12 +21,14 @@ let version_eq a b = type console_cmd = [ | `Console_add - | `Console_subscribe + | `Console_subscribe of Ptime.t option ] let pp_console_cmd ppf = function | `Console_add -> Fmt.string ppf "console add" - | `Console_subscribe -> Fmt.string ppf "console subscribe" + | `Console_subscribe ts -> + Fmt.pf ppf "console subscribe since %a" + Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts type stats_cmd = [ | `Stats_add of int * string list @@ -40,11 +42,13 @@ let pp_stats_cmd ppf = function | `Stats_subscribe -> Fmt.string ppf "stat subscribe" type log_cmd = [ - | `Log_subscribe + | `Log_subscribe of Ptime.t option ] let pp_log_cmd ppf = function - | `Log_subscribe -> Fmt.string ppf "log subscribe" + | `Log_subscribe ts -> + Fmt.pf ppf "log subscribe since %a" + Fmt.(option ~none:(unit "epoch") (Ptime.pp_rfc3339 ())) ts type vm_cmd = [ | `Vm_info diff --git a/src/vmm_commands.mli b/src/vmm_commands.mli index 9d6af05..175e8d0 100644 --- a/src/vmm_commands.mli +++ b/src/vmm_commands.mli @@ -13,7 +13,7 @@ val pp_version : version Fmt.t type console_cmd = [ | `Console_add - | `Console_subscribe + | `Console_subscribe of Ptime.t option ] type stats_cmd = [ @@ -23,7 +23,7 @@ type stats_cmd = [ ] type log_cmd = [ - | `Log_subscribe + | `Log_subscribe of Ptime.t option ] type vm_cmd = [ diff --git a/src/vmm_core.ml b/src/vmm_core.ml index c43a348..f04437f 100644 --- a/src/vmm_core.ml +++ b/src/vmm_core.ml @@ -214,7 +214,7 @@ module Stats = struct type vmm = (string * int64) list let pp_vmm ppf vmm = - Fmt.(list ~sep:(unit "@,") (pair ~sep:(unit ": ") string int64)) ppf vmm + Fmt.(list ~sep:(unit "@.") (pair ~sep:(unit ": ") string int64)) ppf vmm type ifdata = { name : string ;