Merge master into feature/config-ntp-timezone-maxcstate (#6764)

Author: changlei-li

doc/content/xapi/internals/certificates.md

@@ -53,7 +53,7 @@ pool or host to be used as an API.
   certificate.
 * See below for xapi-stunnel-ca-bundle for additional certificates that
   can be added to a pool in support of a user-supplied host certificate.
-* `xe reset-server-certificate` creates a new self-signed certificate.
+* `xe host-reset-server-certificate` creates a new self-signed certificate.
 
 
 ### `xapi-pool-tls.pem`

ocaml/database/database_test.ml

@@ -463,6 +463,7 @@ functor
       (* reference which we create *)
       let valid_ref = "ref1" in
       let valid_uuid = "uuid1" in
+      let new_uuid = "uuid2" in
       let invalid_ref = "foo" in
       let invalid_uuid = "bar" in
       let t =
@@ -626,6 +627,32 @@ functor
           "read_field_where <valid table> <valid return> <valid field> <valid \
            value>" ;
       test_invalid_where_record "read_field_where" (Client.read_field_where t) ;
+
+      (* before changing the UUID, the new UUID should be missing *)
+      expect_missing_uuid "VM" new_uuid (fun () ->
+          let (_ : string) = Client.db_get_by_uuid t "VM" new_uuid in
+          ()
+      ) ;
+      (* change UUID, can happen during VM import *)
+      Client.write_field t "VM" valid_ref Db_names.uuid new_uuid ;
+      let old_uuid = valid_uuid in
+      (* new UUID should be found *)
+      let r = Client.db_get_by_uuid t "VM" new_uuid in
+      if r <> valid_ref then
+        failwith_fmt "db_get_by_uuid <new uuid>: got %s; expected %s" r
+          valid_ref ;
+      let r = Client.db_get_by_uuid_opt t "VM" new_uuid in
+      ( if r <> Some valid_ref then
+          let rs = Option.value ~default:"None" r in
+          failwith_fmt "db_get_by_uuid_opt <new uuid>: got %s; expected %s" rs
+            valid_ref
+      ) ;
+      (* old UUID should not be found anymore *)
+      expect_missing_uuid "VM" old_uuid (fun () ->
+          let (_ : string) = Client.db_get_by_uuid t "VM" old_uuid in
+          ()
+      ) ;
+
       Printf.printf "write_field <invalid table>\n" ;
       expect_missing_tbl "Vm" (fun () ->
           let (_ : unit) = Client.write_field t "Vm" "" "" "" in
@@ -842,5 +869,23 @@ functor
           )
         in
         Printf.printf "bad sequence: %.2f calls/sec\n%!" malign_time
-      )
+      ) ;
+      Client.delete_row t "VM" valid_ref ;
+      (* after deleting the row, both old and new uuid must be missing *)
+      expect_missing_uuid "VM" new_uuid (fun () ->
+          let (_ : string) = Client.db_get_by_uuid t "VM" new_uuid in
+          ()
+      ) ;
+      expect_missing_uuid "VM" old_uuid (fun () ->
+          let (_ : string) = Client.db_get_by_uuid t "VM" old_uuid in
+          ()
+      ) ;
+      let r = Client.db_get_by_uuid_opt t "VM" old_uuid in
+      if not (Option.is_none r) then
+        failwith_fmt "db_get_by_uuid_opt <old uuid>: got %s; expected None"
+          valid_ref ;
+      let r = Client.db_get_by_uuid_opt t "VM" new_uuid in
+      if not (Option.is_none r) then
+        failwith_fmt "db_get_by_uuid_opt <old uuid>: got %s; expected None"
+          valid_ref
   end

ocaml/database/db_cache_impl.ml

@@ -277,21 +277,13 @@ let read_field_where' conv t rcd =
 let read_field_where t rcd = read_field_where' Fun.id t rcd
 
 let db_get_by_uuid t tbl uuid_val =
-  match
-    read_field_where' Schema.CachedValue.string_of t
-      {
-        table= tbl
-      ; return= Db_names.ref
-      ; where_field= Db_names.uuid
-      ; where_value= uuid_val
-      }
-  with
-  | [] ->
-      raise (Read_missing_uuid (tbl, "", uuid_val))
-  | [r] ->
+  let db = get_database t in
+  match Database.lookup_uuid uuid_val db with
+  | Some (tbl', r) when String.equal tbl tbl' ->
       r
   | _ ->
-      raise (Too_many_values (tbl, "", uuid_val))
+      (* we didn't find the UUID, or it belonged to another table *)
+      raise (Read_missing_uuid (tbl, "", uuid_val))
 
 let db_get_by_uuid_opt t tbl uuid_val =
   match

ocaml/database/db_cache_types.ml

@@ -508,6 +508,8 @@ module Database = struct
 
   let lookup_key key db = KeyMap.find_opt (Ref key) db.keymap
 
+  let lookup_uuid key db = KeyMap.find_opt (Uuid key) db.keymap
+
   let make schema =
     {
       tables= TableSet.empty
@@ -615,6 +617,33 @@ let update_many_to_many g tblname objref f db =
       db
       (Schema.many_to_many tblname (Database.schema db))
 
+let uuid_of ~tblname ~objref db =
+  try
+    Some
+      (Schema.Value.Unsafe_cast.string
+         (Row.find Db_names.uuid
+            (Table.find objref (TableSet.find tblname (Database.tableset db)))
+         )
+      )
+  with _ -> None
+
+let maybe_update_uuid_keymap ~tblname ~objref ~fldname ~newval db =
+  if fldname = Db_names.uuid then
+    db
+    |> Database.update_keymap @@ fun keymap ->
+       let keymap =
+         match uuid_of ~tblname ~objref db with
+         | None ->
+             keymap
+         | Some uuid ->
+             KeyMap.remove (Uuid uuid) keymap
+       in
+       KeyMap.add_unique tblname Db_names.uuid
+         (Uuid (Schema.Value.Unsafe_cast.string newval))
+         (tblname, objref) keymap
+  else
+    db
+
 let set_field tblname objref fldname newval db =
   if fldname = Db_names.ref then
     failwith (Printf.sprintf "Cannot safely update field: %s" fldname) ;
@@ -632,6 +661,7 @@ let set_field tblname objref fldname newval db =
   if need_other_table_update then
     let g = Manifest.generation (Database.manifest db) in
     db
+    |> maybe_update_uuid_keymap ~tblname ~objref ~fldname ~newval
     |> update_many_to_many g tblname objref remove_from_set
     |> update_one_to_many g tblname objref remove_from_set
     |> Database.update
@@ -646,6 +676,7 @@ let set_field tblname objref fldname newval db =
   else
     let g = Manifest.generation (Database.manifest db) in
     db
+    |> maybe_update_uuid_keymap ~tblname ~objref ~fldname ~newval
     |> ((fun _ -> newval)
        |> Row.update g fldname empty
        |> Table.update g objref Row.empty
@@ -696,16 +727,7 @@ let add_row tblname objref newval db =
   |> Database.increment
 
 let remove_row tblname objref db =
-  let uuid =
-    try
-      Some
-        (Schema.Value.Unsafe_cast.string
-           (Row.find Db_names.uuid
-              (Table.find objref (TableSet.find tblname (Database.tableset db)))
-           )
-        )
-    with _ -> None
-  in
+  let uuid = uuid_of ~tblname ~objref db in
   let g = db.Database.manifest.Manifest.generation_count in
   db
   |> Database.update_keymap (fun m ->

ocaml/database/db_cache_types.mli

@@ -195,6 +195,8 @@ module Database : sig
 
   val lookup_key : string -> t -> (string * string) option
 
+  val lookup_uuid : string -> t -> (string * string) option
+
   val reindex : t -> t
 
   val register_callback : string -> (update -> t -> unit) -> t -> t

ocaml/idl/datamodel.ml

@@ -11005,6 +11005,16 @@ let http_actions =
       , []
       )
     )
+    (* For XC < 8460 compatibility, remove when out of support *)
+  ; ( "get_vm_rrds"
+    , ( Get
+      , "/vm_rrds"
+      , true
+      , [String_query_arg "uuid"; Bool_query_arg "json"]
+      , _R_READ_ONLY
+      , []
+      )
+    )
   ; ( Constants.get_host_rrd
     , ( Get
       , Constants.get_host_rrd_uri
@@ -11014,6 +11024,10 @@ let http_actions =
       , []
       )
     )
+    (* For XC < 8460 compatibility, remove when out of support *)
+  ; ( "get_host_rrds"
+    , (Get, "/host_rrds", true, [Bool_query_arg "json"], _R_READ_ONLY, [])
+    )
   ; ( Constants.get_sr_rrd
     , ( Get
       , Constants.get_sr_rrd_uri
@@ -11081,6 +11095,7 @@ let http_actions =
     )
   ; (* XMLRPC callback *)
     ("post_root", (Post, "/", false, [], _R_READ_ONLY, []))
+  ; ("post_RPC2", (Post, "/RPC2", false, [], _R_READ_ONLY, []))
   ; (* JSON callback *)
     ("post_json", (Post, Constants.json_uri, false, [], _R_READ_ONLY, []))
   ; ("post_root_options", (Options, "/", false, [], _R_READ_ONLY, []))
@@ -11133,6 +11148,7 @@ let http_actions =
 let public_http_actions_with_no_rbac_check =
   [
     "post_root"
+  ; "post_RPC2"
   ; (* XMLRPC (API) calls -> checks RBAC internally *)
     "post_cli"
   ; (* CLI commands -> calls XMLRPC *)

ocaml/idl/datamodel_pool.ml

@@ -5,8 +5,7 @@ open Datamodel_types
 let operations =
   Enum
     ( "pool_allowed_operations"
-    , (* FIXME: This should really be called `pool_operations`, to avoid confusion with the Pool.allowed_operations field *)
-      [
+    , [
         ("ha_enable", "Indicates this pool is in the process of enabling HA")
       ; ("ha_disable", "Indicates this pool is in the process of disabling HA")
       ; ( "cluster_create"

ocaml/idl/datamodel_vm.ml

@@ -1742,7 +1742,7 @@ let assert_can_migrate =
       ; {
           param_type= Map (String, String)
         ; param_name= "dest"
-        ; param_doc= "The result of a VM.migrate_receive call."
+        ; param_doc= "The result of a Host.migrate_receive call."
         ; param_release= tampa_release
         ; param_default= None
         }
@@ -1797,7 +1797,7 @@ let assert_can_migrate_sender =
         (Ref _vm, "vm", "The VM")
       ; ( Map (String, String)
         , "dest"
-        , "The result of a VM.migrate_receive call."
+        , "The result of a Host.migrate_receive call."
         )
       ; (Bool, "live", "Live migration")
       ; ( Map (Ref _vdi, Ref _sr)

ocaml/libs/http-lib/http.ml

@@ -505,7 +505,7 @@ end
 module Request = struct
   type t = {
       m: method_t
-    ; uri: string
+    ; path: string
     ; query: (string * string) list
     ; version: string
     ; frame: bool
@@ -528,7 +528,7 @@ module Request = struct
   let empty =
     {
       m= Unknown ""
-    ; uri= ""
+    ; path= ""
     ; query= []
     ; version= ""
     ; frame= false
@@ -563,7 +563,7 @@ module Request = struct
     ; host
     ; user_agent= Some user_agent
     ; m= meth
-    ; uri= path
+    ; path
     ; additional_headers= headers
     ; body
     ; accept
@@ -577,10 +577,10 @@ module Request = struct
       String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) x)
     in
     Printf.sprintf
-      "{ frame = %b; method = %s; uri = %s; query = [ %s ]; content_length = [ \
-       %s ]; transfer encoding = %s; version = %s; cookie = [ %s ]; task = %s; \
-       subtask_of = %s; content-type = %s; host = %s; user_agent = %s; }"
-      x.frame (string_of_method_t x.m) x.uri (kvpairs x.query)
+      "{ frame = %b; method = %s; path = %s; query = [ %s ]; content_length = \
+       [ %s ]; transfer encoding = %s; version = %s; cookie = [ %s ]; task = \
+       %s; subtask_of = %s; content-type = %s; host = %s; user_agent = %s; }"
+      x.frame (string_of_method_t x.m) x.path (kvpairs x.query)
       (Option.fold ~none:"" ~some:Int64.to_string x.content_length)
       (Option.value ~default:"" x.transfer_encoding)
       x.version "(value filtered)" (* cookies *)
@@ -642,7 +642,7 @@ module Request = struct
       [(Hdr.connection ^ ": " ^ if x.close then "close" else "keep-alive")]
     in
     [
-      Printf.sprintf "%s %s%s HTTP/%s" (string_of_method_t x.m) x.uri query
+      Printf.sprintf "%s %s%s HTTP/%s" (string_of_method_t x.m) x.path query
         x.version
     ]
     @ cookie
@@ -809,17 +809,17 @@ module Url = struct
 
   type scheme = Http of http | File of file
 
-  type data = {uri: string; query_params: (string * string) list}
+  type data = {path: string; query_params: (string * string) list}
 
   type t = scheme * data
 
-  let file_equal a b = String.equal a.path b.path
+  let file_equal (a : file) (b : file) = String.equal a.path b.path
 
   let query_params_equal (ak, av) (bk, bv) =
     String.equal ak bk && String.equal av bv
 
   let data_equal a b =
-    String.equal a.uri b.uri
+    String.equal a.path b.path
     && List.equal query_params_equal a.query_params b.query_params
 
   let http_equal a b =
@@ -858,7 +858,7 @@ module Url = struct
       in
       let data =
         {
-          uri= (match Uri.path_unencoded uri with "" -> "/" | path -> path)
+          path= (match Uri.path_unencoded uri with "" -> "/" | path -> path)
         ; query_params= Uri.query uri |> List.map query
         }
       in
@@ -872,19 +872,19 @@ module Url = struct
           (scheme ~ssl:true, data)
       | Some "file" ->
           let scheme = File {path= Uri.path_unencoded uri} in
-          (scheme, {data with uri= "/"})
+          (scheme, {data with path= "/"})
       | _ ->
           failwith "unsupported URI scheme"
     with e ->
       fail "%s: can't parse '%s': %s" __FUNCTION__ url (Printexc.to_string e)
 
-  let data_to_string {uri; query_params= params} =
+  let data_to_string {path; query_params= params} =
     let kvpairs x =
       String.concat "&"
         (List.map (fun (k, v) -> urlencode k ^ "=" ^ urlencode v) x)
     in
     let params = if params = [] then "" else "?" ^ kvpairs params in
-    uri ^ params
+    path ^ params
 
   let to_string scheme =
     let query (k, v) = (k, [v]) in
@@ -893,7 +893,7 @@ module Url = struct
       | File {path}, {query_params= params; _} ->
           Uri.make ~scheme:"file" ~path ~query:(List.map query params) ()
           |> Uri.to_string
-      | Http h, {uri; query_params= params} ->
+      | Http h, {path; query_params= params} ->
           let auth =
             match h.auth with
             | Some (Basic (username, password)) ->
@@ -905,16 +905,16 @@ module Url = struct
           in
           Uri.make
             ~scheme:(if h.ssl then "https" else "http")
-            ~host:h.host ?port:h.port ?userinfo:auth ~path:uri
+            ~host:h.host ?port:h.port ?userinfo:auth ~path
             ~query:(List.map query params) ()
           |> Uri.to_string
     in
     debug "%s: %s" __FUNCTION__ str ;
     str
 
-  let get_uri (_scheme, data) = data.uri
+  let get_path (_scheme, data) = data.path
 
-  let set_uri (scheme, data) u = (scheme, {data with uri= u})
+  let set_path (scheme, data) u = (scheme, {data with path= u})
 
   let get_query_params (_scheme, data) = data.query_params