Ring feature cleanup, advertise WATCHDEPTH feature bit

gnt/gnttab_stubs.c

@@ -32,6 +32,8 @@
 #include <caml/callback.h>
 #include <caml/bigarray.h>
 
+#include <xen/io/xs_wire.h>
+
 #include "xengnttab.h"
 #include "mmap_stubs.h"
 
@@ -57,14 +59,25 @@ stub_gnttab_interface_open (void)
         CAMLreturn (result);
 }
 
-/* Only called in tests, returns a unit that poses as any particular type on
- * OCaml side - kind of like an unsafe cast from nullptr */
+/* Only called in tests, returns a mmap_interface allocated without xen */
 CAMLprim value
 unsafe_stub (value unit)
 {
+#define Intf_val(a) ((struct mmap_interface *)Data_abstract_val(a))
+#define Wsize_bsize_round(n) (Wsize_bsize( (n) + sizeof(value) - 1 ))
+
         CAMLparam1 (unit);
+        CAMLlocal1 (result);
+
         assert (geteuid () != 0);
-        CAMLreturn (Val_unit);
+
+        struct xenstore_domain_interface *addr = calloc (1, 4096);
+
+        result = caml_alloc (Wsize_bsize_round
+                             (sizeof (struct mmap_interface)), Abstract_tag);
+        Intf_val (result)->addr = addr;
+
+        CAMLreturn (result);
 }
 
 CAMLprim value

oxenstored/connection.ml

@@ -326,7 +326,7 @@ let get_fd con = Xenbus.Xb.get_fd con.xb
 
 let close con =
   Logging.end_connection ~tid:Transaction.none ~con:(get_domstr con) ;
-  Xenbus.Xb.close ~under_testing:Testing_status.under_testing con.xb
+  Xenbus.Xb.close ~under_testing:!Testing_status.under_testing con.xb
 
 let get_perm con = con.perm
 

oxenstored/connections.ml

@@ -62,8 +62,8 @@ let add_anonymous cons fd =
 let add_domain cons dom =
   let capacity = get_capacity () in
   let xbcon =
-    Xenbus.Xb.open_mmap ~under_testing:Testing_status.under_testing ~capacity
-      (Domain.get_interface dom) (fun () -> Domain.notify dom
+    Xenbus.Xb.open_mmap ~under_testing:!Testing_status.under_testing
+      ~capacity (Domain.get_interface dom) (fun () -> Domain.notify dom
     )
   in
   let con = Connection.create xbcon (Some dom) in

oxenstored/domains.ml

@@ -38,7 +38,7 @@ let load_plug fname =
 
 let () =
   (* Do not link with the plugin when being tested *)
-  if not Testing_status.under_testing then (
+  if not !Testing_status.under_testing then (
     let plugins_dir =
       Filename.concat Paths.libexec "ocaml/xsd_glue/xenctrl_plugin"
     in

oxenstored/logging.ml

@@ -323,6 +323,10 @@ let string_of_access_type = function
         "error    "
     | Xenbus.Xb.Op.Watchevent ->
         "w event  "
+    | Xenbus.Xb.Op.Get_feature ->
+        "get_feature "
+    | Xenbus.Xb.Op.Set_feature ->
+        "set_feature "
     | Xenbus.Xb.Op.Invalid ->
         "invalid  "
   )

oxenstored/poll.ml

@@ -56,5 +56,5 @@ let poll_select fdarr timeout =
       fdarr r
 
 let () =
-  if not Testing_status.under_testing then
+  if not !Testing_status.under_testing then
     set_fd_limit (get_sys_fs_nr_open ())

oxenstored/process.ml

@@ -886,6 +886,8 @@ let retain_op_in_history ty =
   | Xenbus.Xb.Op.Rm
   | Xenbus.Xb.Op.Setperms ->
       true
+  | Xenbus.Xb.Op.Get_feature
+  | Xenbus.Xb.Op.Set_feature
   | Xenbus.Xb.Op.Debug
   | Xenbus.Xb.Op.Directory
   | Xenbus.Xb.Op.Directory_part

oxenstored/testing_status/testing_status.ml

@@ -1 +1 @@
-let under_testing = false
+let under_testing = ref false

oxenstored/xenstored.ml

@@ -439,7 +439,7 @@ let main () =
         (Unix.handle_unix_error Utils.create_unix_socket Define.xs_daemon_socket)
   in
 
-  if (not Testing_status.under_testing) && cf.daemonize && not cf.live_reload
+  if (not !Testing_status.under_testing) && cf.daemonize && not cf.live_reload
   then
     Unixext.daemonize ()
   else
@@ -719,7 +719,7 @@ let main () =
 
     if cfds <> [] || wset <> [] then
       process_connection_fds store cons domains cfds wset spec_fds ;
-    if not Testing_status.under_testing then (
+    if not !Testing_status.under_testing then (
       ( if timeout <> 0. then
           let now = Unix.gettimeofday () in
           if now > !period_start +. period_ops_interval then (
@@ -732,7 +732,7 @@ let main () =
     )
   in
 
-  if not Testing_status.under_testing then (
+  if not !Testing_status.under_testing then (
     Systemd.sd_notify_ready () ;
     let live_update = ref false in
     while not (!quit && Connections.prevents_quit cons = []) do

tests/testing_status.ml

@@ -1 +1 @@
-let under_testing = true
+let under_testing = ref true

tests/unit_tests.ml

@@ -916,8 +916,49 @@ let test_quota_maxent () =
     ; (dom1, none, (Write, ["b"; "hello"]), (Error, ["EQUOTA"]))
     ]
 
+let feature_testable =
+  Alcotest.testable
+    (Fmt.of_to_string Xenbus.Xs_ring.Server_feature.to_string)
+    Stdlib.( = )
+
+let check_features (con : Connection.t) expected =
+  let open Xenbus.Xs_ring in
+  let d = Option.get (Connection.get_domain con) in
+  let x = get_server_features (Xenmmap.to_interface (Domain.get_interface d)) in
+  Alcotest.(check' (seq @@ feature_testable))
+    ~msg:"Verify advertised features on xenstore ring"
+    ~actual:(Server_features.to_seq x) ~expected:(List.to_seq expected)
+
+let test_feature_advertisement () =
+  let _store, doms, cons = initialize () in
+  (* Turn off under_testing flag here to trigger the setting of feature bitmap *)
+  Testing_status.under_testing := false ;
+
+  let dom0 = create_dom0_conn cons doms in
+  let dom1 = create_domU_conn cons doms 1 in
+  check_features dom0 Xenbus.Xs_ring.Server_feature.[Reconnection; Watch_depth] ;
+  check_features dom1 Xenbus.Xs_ring.Server_feature.[Reconnection; Watch_depth] ;
+  Testing_status.under_testing := true
+
+let test_get_feature () =
+  let store, doms, cons = initialize () in
+  (* Turn off under_testing flag here to trigger the setting of feature bitmap *)
+  Testing_status.under_testing := false ;
+
+  let dom0 = create_dom0_conn cons doms in
+  let dom1 = create_domU_conn cons doms 1 in
+  run store cons doms
+    [
+      (dom0, none, (Get_feature, ["0"]), (Error, ["ENOSYS"]))
+    ; (dom1, none, (Get_feature, ["1"]), (Error, ["ENOSYS"]))
+    ; (dom1, none, (Set_feature, ["0"; "1"]), (Error, ["ENOSYS"]))
+    ] ;
+  check_features dom0 Xenbus.Xs_ring.Server_feature.[Reconnection; Watch_depth] ;
+  check_features dom1 Xenbus.Xs_ring.Server_feature.[Reconnection; Watch_depth] ;
+  Testing_status.under_testing := true
+
 let () =
-  Alcotest.run "Test RRD library"
+  Alcotest.run "Test oxenstored"
     [
       ( "Basic tests"
       , [
@@ -972,4 +1013,10 @@ let () =
         ; ("test_quota_maxent", `Quick, test_quota_maxent)
         ]
       )
+    ; ( "Features tests"
+      , [
+          ("test_feature_advertisement", `Quick, test_feature_advertisement)
+        ; ("test_get_feature", `Quick, test_get_feature)
+        ]
+      )
     ]

xenbus/op.ml

@@ -37,6 +37,8 @@ type operation =
   | Set_target
   | Reset_watches
   | Directory_part
+  | Get_feature
+  | Set_feature
   | Invalid
 
 (* See xs_wire.h for the required order *)
@@ -65,6 +67,8 @@ let operation_c_mapping =
    ; Invalid
    ; Reset_watches
    ; Directory_part
+   ; Get_feature
+   ; Set_feature
   |]
 
 let size = Array.length operation_c_mapping
@@ -131,5 +135,9 @@ let to_string ty =
       "RESET_WATCHES"
   | Directory_part ->
       "DIRECTORY_PART"
+  | Get_feature ->
+      "GET_FEATURE"
+  | Set_feature ->
+      "SET_FEATURE"
   | Invalid ->
       "INVALID"

xenbus/op.mli

@@ -21,6 +21,8 @@ type operation =
   | Set_target
   | Reset_watches
   | Directory_part
+  | Get_feature
+  | Set_feature
   | Invalid
 
 val operation_c_mapping : operation array

xenbus/xb.ml

@@ -352,11 +352,19 @@ let newcon ~capacity backend =
 let open_fd fd = newcon (Fd {fd})
 
 let open_mmap mmap notifyfct ~under_testing =
-  (* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *)
-  if not under_testing then
-    Xs_ring.set_server_features
-      (Xenmmap.to_interface mmap)
-      (Xs_ring.Server_features.singleton Xs_ring.Server_feature.Reconnection) ;
+  (* Advertise
+     XENSTORE_SERVER_FEATURE_RECONNECTION |
+     XENSTORE_SERVER_FEATURE_WATCHDEPTH
+     *)
+  ( if not under_testing then
+      Xs_ring.(
+        set_server_features
+          (Xenmmap.to_interface mmap)
+          (Server_features.of_list
+             [Server_feature.Reconnection; Server_feature.Watch_depth]
+          )
+      )
+  ) ;
   newcon (Xenmmap {mmap; eventchn_notify= notifyfct; work_again= false})
 
 let close con ~under_testing =

xenbus/xb.mli

@@ -22,6 +22,8 @@ module Op : sig
     | Set_target
     | Reset_watches
     | Directory_part
+    | Get_feature
+    | Set_feature
     | Invalid
 
   val operation_c_mapping : operation array

xenbus/xs_ring.ml

@@ -14,14 +14,57 @@
  * GNU Lesser General Public License for more details.
  *)
 
-module Server_feature = struct type t = Reconnection end
+module Server_feature = struct
+  type t = Reconnection | Error_indicator | Watch_depth
+
+  (* See xenstore-ring.txt for the required order *)
+  let bit_mapping = [|Reconnection; Error_indicator; Watch_depth|]
+
+  let bitmap_size = Array.length bit_mapping
+
+  (* See xenstore-ring.txt for bit numbers *)
+  let feature_to_bit = function
+    | Reconnection ->
+        0
+    | Error_indicator ->
+        1
+    | Watch_depth ->
+        2
+
+  let to_string = function
+    | Reconnection ->
+        "Reconnection"
+    | Error_indicator ->
+        "Error_indicator"
+    | Watch_depth ->
+        "Watch_depth"
+end
 
 module Server_features = Set.Make (struct
   type t = Server_feature.t
 
   let compare = compare
 end)
 
+(* Set of features from bitmask *)
+let of_cval n =
+  let features = ref Server_features.empty in
+  for i = 0 to Server_feature.bitmap_size - 1 do
+    if (n lsr i) land 1 = 1 then
+      let feature = Server_feature.bit_mapping.(i) in
+      features := Server_features.add feature !features
+  done ;
+  !features
+
+(* Bitmask from set of features *)
+let to_cval features =
+  Server_features.fold
+    (fun feature bitmap ->
+      let i = Server_feature.feature_to_bit feature in
+      bitmap lor (1 lsl i)
+    )
+    features 0
+
 external read : Xenmmap.mmap_interface -> bytes -> int -> int
   = "ml_interface_read"
 
@@ -37,16 +80,11 @@ external _internal_get_server_features : Xenmmap.mmap_interface -> int
 [@@noalloc]
 
 let get_server_features mmap =
-  (* NB only one feature currently defined above *)
   let x = _internal_get_server_features mmap in
-  if x = 0 then
-    Server_features.empty
-  else
-    Server_features.singleton Server_feature.Reconnection
+  of_cval x
 
 let set_server_features mmap set =
-  (* NB only one feature currently defined above *)
-  let x = if set = Server_features.empty then 0 else 1 in
+  let x = to_cval set in
   _internal_set_server_features mmap x
 
 external close : Xenmmap.mmap_interface -> unit = "ml_interface_close"

xenbus/xs_ring.mli

@@ -0,0 +1,20 @@
+module Server_feature : sig
+  type t = Reconnection | Error_indicator | Watch_depth
+
+  val to_string : t -> string
+end
+
+module Server_features : module type of Set.Make (struct
+  type t = Server_feature.t
+
+  let compare = compare end)
+
+val read : Xenmmap.mmap_interface -> bytes -> int -> int
+
+val write_substring : Xenmmap.mmap_interface -> string -> int -> int
+
+val get_server_features : Xenmmap.mmap_interface -> Server_features.t
+
+val set_server_features : Xenmmap.mmap_interface -> Server_features.t -> unit
+
+val close : Xenmmap.mmap_interface -> unit