since argument for log_subscribe and console_subscribe

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) ;

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

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 =

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

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

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 = [

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 ;