Skip to content
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
30 changes: 28 additions & 2 deletions ocaml/xapi/xapi_event.ml
Original file line number Diff line number Diff line change
Expand Up @@ -519,6 +519,26 @@ let rec next ~__context =
else
rpc_of_events relevant

let omitted = Rpc.Null

let[@tail_mod_cons] rec maybe_map_fields = function
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why not filter_map?

| [] ->
[]
| (key, _) :: tl when Xapi_globs.StringSet.mem key !Xapi_globs.event_filter ->
(key, omitted) :: (maybe_map_fields [@tailcall]) tl
| hd :: tl ->
hd :: (maybe_map_fields [@tailcall]) tl

let apply_event_filter = function
| Rpc.Dict lst as orig ->
let lst' = maybe_map_fields lst in
if lst' == lst then
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Should add a comment that == is indeed what we want.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is this check worth doing? It seems to me that the only time this condition will be true is when both lists are empty.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

this needs quality_gate.sh to change in order to pass CI. So all usages of == are actually quite purposeful

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

lst and lst' can also match when the filter wasn't applicable to the current dictionary (e.g. this is another object, one that doesn't have any filters).

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

There are discussions upstream about adding a separate phys_equal to the stdlib to mark purposeful usages, meanwhile I'll update the quality gate and comment.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

lst and lst' can also match when the filter wasn't applicable to the current dictionary

I don't see how this could possibly be true.

let[@tail_mod_cons] rec maybe_map_fields = function
  | [] ->
      []
  | (key, _) :: tl when Xapi_globs.StringSet.mem key !Xapi_globs.event_filter ->
      (key, omitted) :: (maybe_map_fields [@tailcall]) tl
  | hd :: tl ->
      hd :: (maybe_map_fields [@tailcall]) tl

(* ... *)

  | Rpc.Dict lst as orig ->
      let lst' = maybe_map_fields lst in
      if lst' == lst then

The function maybe_map_fields is constructing a new list every time, comparison with == will yield false (unless the input is []). This is copying the list, it can't be physically equal afterwards.

Please correct me if there's something I'm missing.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Indeed, the physeuqal optimization is missing from maybe_map_fields, and without it this one is pointless.

orig
else
Rpc.Dict lst'
| rpc ->
rpc

let from_inner __context session subs from from_t timer batching =
let open Xapi_database in
let open From in
Expand Down Expand Up @@ -658,7 +678,10 @@ let from_inner __context session subs from from_t timer batching =
(fun acc (table, objref, mtime) ->
let serialiser = Eventgen.find_get_record table in
try
let xml = serialiser ~__context ~self:objref () in
let xml =
serialiser ~__context ~self:objref ()
|> Option.map apply_event_filter
in
let ev = event_of `_mod ?snapshot:xml (table, objref, mtime) in
if Subscription.event_matches subs ev then ev :: acc else acc
with _ -> acc
Expand All @@ -670,7 +693,10 @@ let from_inner __context session subs from from_t timer batching =
(fun acc (table, objref, ctime) ->
let serialiser = Eventgen.find_get_record table in
try
let xml = serialiser ~__context ~self:objref () in
let xml =
serialiser ~__context ~self:objref ()
|> Option.map apply_event_filter
in
let ev = event_of `add ?snapshot:xml (table, objref, ctime) in
if Subscription.event_matches subs ev then ev :: acc else acc
with _ -> acc
Expand Down
11 changes: 11 additions & 0 deletions ocaml/xapi/xapi_globs.ml
Original file line number Diff line number Diff line change
Expand Up @@ -1068,6 +1068,8 @@ let tgroups_enabled = ref false
let xapi_requests_cgroup =
"/sys/fs/cgroup/cpu/control.slice/xapi.service/request"

let event_filter = ref (StringSet.of_list [])

(* Event.{from,next} batching delays *)
let make_batching name ~delay_before ~delay_between =
let name = Printf.sprintf "%s_delay" name in
Expand Down Expand Up @@ -1451,6 +1453,15 @@ let other_options =
, (fun () -> string_of_bool !Db_globs.idempotent_map)
, "True if the add_to_<map> API calls should be idempotent"
)
; ( "event-field-filter"
, Arg.String
(fun s ->
event_filter := String.split_on_char ',' s |> StringSet.of_list
)
, (fun () -> !event_filter |> StringSet.elements |> String.concat ",")
, "Filter out events on these fields. THIS CAN BREAK API CLIENTS IF USED \
INCORRECTLY."
)
; ( "use-event-next"
, Arg.Set Constants.use_event_next
, (fun () -> string_of_bool !Constants.use_event_next)
Expand Down
Loading