Merge pull request #55 from last-genius/directory_part

psafont · web-flow · commit ba66bbbf7807 · 2024-12-03T13:49:14.000Z
diff --git a/client_lwt/xs_client_lwt.ml b/client_lwt/xs_client_lwt.ml
@@ -54,7 +54,6 @@ module type S = sig
   val mkdir : handle -> string -> unit Lwt.t
   val setperms : handle -> string -> Xs_protocol.ACL.t -> unit Lwt.t
   val debug : handle -> string list -> string list Lwt.t
-  val restrict : handle -> int -> unit Lwt.t
   val getdomainpath : handle -> int -> string Lwt.t
   val watch : handle -> string -> Xs_protocol.Token.t -> unit Lwt.t
   val unwatch : handle -> string -> Xs_protocol.Token.t -> unit Lwt.t
@@ -342,9 +341,6 @@ functor
 
     let debug h cmd_args = rpc "debug" h (Request.Debug cmd_args) Unmarshal.list
 
-    let restrict h domid =
-      rpc "restrict" h (Request.Restrict domid) Unmarshal.ok
-
     let getdomainpath h domid =
       rpc "getdomainpath" h (Request.Getdomainpath domid) Unmarshal.string
 
diff --git a/client_lwt/xs_client_lwt.mli b/client_lwt/xs_client_lwt.mli
@@ -89,10 +89,6 @@ module type S = sig
   val debug : handle -> string list -> string list Lwt.t
   (** [debug cmd_args] invokes a debug command. *)
 
-  val restrict : handle -> int -> unit Lwt.t
-  (** [restrict h domid] restricts the current connection to have only
-	    the priviledges associated with domain [domid]. *)
-
   val getdomainpath : handle -> int -> string Lwt.t
   (** [getdomainpath domid] returns the local directory of domain
       [domid]. *)
diff --git a/client_unix/xs_client_unix.ml b/client_unix/xs_client_unix.ml
@@ -301,11 +301,40 @@ functor
         with_mutex c.m (fun () -> Hashtbl.remove c.rid_to_wakeup rid);
         response hint request res unmarshal)
 
+    let directory_part h path offset =
+      rpc "directory_part" h
+        Request.(PathOp (path, Directory_part offset))
+        Unmarshal.raw
+
+    let rpc_dir hint h path =
+      try rpc hint h Request.(PathOp (path, Directory)) Unmarshal.list
+      with Error "E2BIG" ->
+        let data = Buffer.create 16 in
+        let rec read_part generation =
+          let offset = Buffer.length data in
+          let out = directory_part h path offset in
+          let i = String.index out '\000' in
+          let new_generation = String.sub out 0 i in
+
+          (* Node's children changed, restart *)
+          if offset <> 0 && new_generation <> generation then (
+            Buffer.clear data;
+            read_part "")
+          else Buffer.add_substring data out (i + 1) (String.length out - i - 1);
+
+          let l = Buffer.length data in
+
+          if l < 2 then Buffer.clear data
+          else if String.ends_with ~suffix:"\000\000" (Buffer.contents data)
+          then (* last packet *)
+            Buffer.truncate data (l - 2)
+          else read_part new_generation
+        in
+        read_part "";
+        String.split_on_char '\000' (Buffer.contents data)
+
     let directory h path =
-      rpc "directory"
-        (Xs_handle.accessed_path h path)
-        Request.(PathOp (path, Directory))
-        Unmarshal.list
+      rpc_dir "directory" (Xs_handle.accessed_path h path) path
 
     let read h path =
       rpc "read"
@@ -339,9 +368,6 @@ functor
 
     let debug h cmd_args = rpc "debug" h (Request.Debug cmd_args) Unmarshal.list
 
-    let restrict h domid =
-      rpc "restrict" h (Request.Restrict domid) Unmarshal.ok
-
     let getdomainpath h domid =
       rpc "getdomainpath" h (Request.Getdomainpath domid) Unmarshal.string
 
diff --git a/client_unix/xs_client_unix.mli b/client_unix/xs_client_unix.mli
@@ -110,10 +110,6 @@ module Client : functor (IO : IO) -> sig
   val debug : handle -> string list -> string list IO.t
   (** [debug cmd_args] invokes a debug command. *)
 
-  val restrict : handle -> int -> unit IO.t
-  (** [restrict h domid] restricts the current connection to have only
-	  the priviledges associated with domain [domid]. *)
-
   val getdomainpath : handle -> int -> string IO.t
   (** [getdomainpath domid] returns the local directory of domain
       [domid]. *)
diff --git a/core/xs_protocol.ml b/core/xs_protocol.ml
@@ -37,7 +37,9 @@ module Op = struct
     | Isintroduced
     | Resume
     | Set_target
-    | Restrict
+    | Invalid
+    | Reset_watches
+    | Directory_part
 
   (* The index of the value in the array is the integer representation used
      by the wire protocol. Every element of t exists exactly once in the array. *)
@@ -63,7 +65,9 @@ module Op = struct
      ; Isintroduced
      ; Resume
      ; Set_target
-     ; Restrict
+     ; Invalid
+     ; Reset_watches
+     ; Directory_part
     |]
 
   let of_int32 i =
@@ -104,7 +108,9 @@ module Op = struct
     | Isintroduced -> "isintroduced"
     | Resume -> "resume"
     | Set_target -> "set_target"
-    | Restrict -> "restrict"
+    | Invalid -> "invalid"
+    | Reset_watches -> "reset_watches"
+    | Directory_part -> "directory_part"
 end
 
 let split_string ~limit c s =
@@ -212,6 +218,7 @@ let get_data pkt =
     Buffer.sub pkt.data 0 (pkt.len - 1)
   else Buffer.contents pkt.data
 
+let get_raw_data pkt = Buffer.contents pkt.data
 let get_rid pkt = pkt.rid
 
 module Parser = struct
@@ -372,10 +379,12 @@ module Response = struct
     | Resume
     | Release
     | Set_target
-    | Restrict
     | Isintroduced of bool
     | Error of string
     | Watchevent of string * string
+    | Directory_part of int64 * string
+  (* Not a string list like Directory because we need to add another null
+     character at the end of the last packet *)
 
   let prettyprint_payload =
     let open Printf in
@@ -397,10 +406,10 @@ module Response = struct
     | Resume -> "Resume"
     | Release -> "Release"
     | Set_target -> "Set_target"
-    | Restrict -> "Restrict"
     | Isintroduced x -> sprintf "Isintroduced %b" x
     | Error x -> sprintf "Error %s" x
     | Watchevent (x, y) -> sprintf "Watchevent %s %s" x y
+    | Directory_part (gen, ls) -> sprintf "Directory_part %Ld %s" gen ls
 
   let ty_of_payload = function
     | Read _ -> Op.Read
@@ -423,7 +432,7 @@ module Response = struct
     | Resume -> Op.Resume
     | Release -> Op.Release
     | Set_target -> Op.Set_target
-    | Restrict -> Op.Restrict
+    | Directory_part _ -> Op.Directory_part
 
   let ok = "OK\000"
 
@@ -437,6 +446,9 @@ module Response = struct
     | Isintroduced b -> data_concat [ (if b then "T" else "F") ]
     | Watchevent (path, token) -> data_concat [ path; token ]
     | Error x -> data_concat [ x ]
+    | Directory_part (gen, ls) ->
+        let gen = Int64.to_string gen in
+        gen ^ "\000" ^ ls
     | _ -> ok
 
   let print x tid rid = create tid rid (ty_of_payload x) (data_of_payload x)
@@ -446,6 +458,7 @@ module Request = struct
   type path_op =
     | Read
     | Directory
+    | Directory_part of int (* offset *)
     | Getperms
     | Write of string
     | Mkdir
@@ -464,7 +477,6 @@ module Request = struct
     | Resume of int
     | Release of int
     | Set_target of int * int
-    | Restrict of int
     | Isintroduced of int
     | Error of string
     | Watchevent of string
@@ -474,6 +486,8 @@ module Request = struct
   let prettyprint_pathop x = function
     | Read -> sprintf "Read %s" x
     | Directory -> sprintf "Directory %s" x
+    | Directory_part offset ->
+        sprintf "Directory_part %s %s" x (string_of_int offset)
     | Getperms -> sprintf "Getperms %s" x
     | Write v -> sprintf "Write %s %s" x v
     | Mkdir -> sprintf "Mkdir %s" x
@@ -492,12 +506,13 @@ module Request = struct
     | Resume x -> sprintf "Resume %d" x
     | Release x -> sprintf "Release %d" x
     | Set_target (x, y) -> sprintf "Set_target %d %d" x y
-    | Restrict x -> sprintf "Restrict %d" x
     | Isintroduced x -> sprintf "Isintroduced %d" x
     | Error x -> sprintf "Error %s" x
     | Watchevent x -> sprintf "Watchevent %s" x
 
   exception Parse_failure
+  exception Deprecated
+  exception Unimplemented
 
   let strings data = String.split_on_char '\000' data
 
@@ -515,9 +530,10 @@ module Request = struct
   let acl x =
     match ACL.of_string x with Some x -> x | None -> raise Parse_failure
 
+  let is_digit c = c >= '0' && c <= '9'
+
   let domid s =
     let v = ref 0 in
-    let is_digit c = c >= '0' && c <= '9' in
     let len = String.length s in
     let i = ref 0 in
     while !i < len && not (is_digit s.[!i]) do
@@ -537,6 +553,11 @@ module Request = struct
     match get_ty request with
     | Op.Read -> PathOp (data |> one_string, Read)
     | Op.Directory -> PathOp (data |> one_string, Directory)
+    | Op.Directory_part ->
+        let path, off = two_strings data in
+        let off = int_of_string off in
+        PathOp (path, Directory_part off)
+    | Op.Reset_watches -> raise Unimplemented
     | Op.Getperms -> PathOp (data |> one_string, Getperms)
     | Op.Getdomainpath -> Getdomainpath (data |> one_string |> domid)
     | Op.Transaction_start -> Transaction_start
@@ -571,10 +592,10 @@ module Request = struct
         let mine, yours = two_strings data in
         let mine = domid mine and yours = domid yours in
         Set_target (mine, yours)
-    | Op.Restrict -> Restrict (data |> one_string |> domid)
     | Op.Isintroduced -> Isintroduced (data |> one_string |> domid)
     | Op.Error -> Error (data |> one_string)
     | Op.Watchevent -> Watchevent (data |> one_string)
+    | Op.Invalid -> raise Deprecated
 
   let parse request = try Some (parse_exn request) with _ -> None
 
@@ -587,6 +608,7 @@ module Request = struct
 
   let ty_of_payload = function
     | PathOp (_, Directory) -> Op.Directory
+    | PathOp (_, Directory_part _) -> Op.Directory_part
     | PathOp (_, Read) -> Op.Read
     | PathOp (_, Getperms) -> Op.Getperms
     | Debug _ -> Op.Debug
@@ -603,7 +625,6 @@ module Request = struct
     | PathOp (_, Rm) -> Op.Rm
     | PathOp (_, Setperms _) -> Op.Setperms
     | Set_target (_, _) -> Op.Set_target
-    | Restrict _ -> Op.Restrict
     | Isintroduced _ -> Op.Isintroduced
     | Error _ -> Op.Error
     | Watchevent _ -> Op.Watchevent
@@ -616,6 +637,8 @@ module Request = struct
     | PathOp (path, Write value) ->
         path ^ "\000" ^ value (* no NUL at the end *)
     | PathOp (path, Setperms perms) -> data_concat [ path; ACL.to_string perms ]
+    | PathOp (path, Directory_part value) ->
+        data_concat [ path; string_of_int value ]
     | PathOp (path, _) -> data_concat [ path ]
     | Debug commands -> data_concat commands
     | Watch (path, token) | Unwatch (path, token) -> data_concat [ path; token ]
@@ -628,11 +651,7 @@ module Request = struct
           ; Printf.sprintf "%nu" mfn
           ; string_of_int port
           ]
-    | Release domid
-    | Resume domid
-    | Getdomainpath domid
-    | Restrict domid
-    | Isintroduced domid ->
+    | Release domid | Resume domid | Getdomainpath domid | Isintroduced domid ->
         data_concat [ Printf.sprintf "%u" domid ]
     | Set_target (mine, yours) ->
         data_concat [ Printf.sprintf "%u" mine; Printf.sprintf "%u" yours ]
@@ -658,6 +677,7 @@ module Unmarshal = struct
   let int32 = int32_of_string_opt ++ get_data
   let unit = unit_of_string_opt ++ get_data
   let ok = ok ++ get_data
+  let raw = some ++ get_raw_data (* with trailing NUL *)
 end
 
 exception Enoent of string
diff --git a/core/xs_protocol.mli b/core/xs_protocol.mli
@@ -39,7 +39,9 @@ module Op : sig
     | Isintroduced
     | Resume
     | Set_target
-    | Restrict  (** The type of xenstore operation. *)
+    | Invalid
+    | Reset_watches
+    | Directory_part  (** The type of xenstore operation. *)
 
   val to_string : t -> string
   val of_int32 : int32 -> t option
@@ -159,10 +161,10 @@ module Response : sig
     | Resume
     | Release
     | Set_target
-    | Restrict
     | Isintroduced of bool
     | Error of string
     | Watchevent of string * string
+    | Directory_part of int64 * string
 
   val ty_of_payload : payload -> Op.t
   val prettyprint_payload : payload -> string
@@ -173,6 +175,7 @@ module Request : sig
   type path_op =
     | Read
     | Directory
+    | Directory_part of int
     | Getperms
     | Write of string
     | Mkdir
@@ -191,7 +194,6 @@ module Request : sig
     | Resume of int
     | Release of int
     | Set_target of int * int
-    | Restrict of int
     | Isintroduced of int
     | Error of string
     | Watchevent of string
@@ -211,6 +213,7 @@ module Unmarshal : sig
   val int32 : t -> int32 option
   val unit : t -> unit option
   val ok : t -> unit option
+  val raw : t -> string option
 end
 
 exception Enoent of string (* Raised when a named key does not exist. *)
diff --git a/server/call.ml b/server/call.ml
@@ -52,7 +52,7 @@ let op_exn _store c t (payload : Request.payload) : Response.payload =
   | Introduce (_, _, _)
   | Resume _ | Release _
   | Set_target (_, _)
-  | Restrict _ | Isintroduced _ | Error _ | Watchevent _ ->
+  | Isintroduced _ | Error _ | Watchevent _ ->
       assert false
   | Getdomainpath domid ->
       let v = Store.Path.getdomainpath domid |> Store.Path.to_string in
@@ -80,6 +80,7 @@ let op_exn _store c t (payload : Request.payload) : Response.payload =
       | Directory ->
           let entries = Impl.list t c.Connection.perm path in
           Response.Directory entries
+      | Directory_part _ -> raise Parse_failure
       | Getperms ->
           let v = Impl.getperms t c.Connection.perm path in
           Response.Getperms v
@@ -203,10 +204,6 @@ let reply_exn store c (request : t) : Response.payload =
               c.Connection.perm <- Perms.set_target c.Connection.perm yours)
           Connection.by_address;
         Response.Set_target
-    | Request.Restrict domid ->
-        Perms.has c.Connection.perm Perms.RESTRICT;
-        c.Connection.perm <- Perms.restrict c.Connection.perm domid;
-        Response.Restrict
     | Request.Isintroduced _ ->
         Perms.has c.Connection.perm Perms.ISINTRODUCED;
         Response.Isintroduced false
diff --git a/server/store.ml b/server/store.ml
@@ -85,10 +85,7 @@ let char_is_valid c =
   || (c >= '0' && c <= '9')
   || c = '_' || c = '-' || c = '@'
 
-let name_is_valid name =
-  name <> ""
-  && String.fold_left (fun accu c -> accu && char_is_valid c) true name
-
+let name_is_valid name = name <> "" && String.for_all char_is_valid name
 let is_valid = List.for_all name_is_valid
 
 type path = string list
diff --git a/server_test/server_test.ml b/server_test/server_test.ml
