Merge pull request #5773 from psafont/getallwhere

Author: psafont

ocaml/idl/datamodel_types.ml

@@ -586,6 +586,7 @@ and obj_op =
   | GetByLabel
   | GetRecord
   | GetAll
+  | GetAllWhere
   | GetAllRecordsWhere
   | GetAllRecords
   | Private of private_op

ocaml/idl/datamodel_types.mli

@@ -210,6 +210,7 @@ and obj_op =
   | GetByLabel
   | GetRecord
   | GetAll
+  | GetAllWhere
   | GetAllRecordsWhere
   | GetAllRecords
   | Private of private_op

ocaml/idl/datamodel_utils.ml

@@ -683,6 +683,36 @@ let messages_of_obj (x : obj) document_order : message list =
     }
   in
 
+  let get_all_where =
+    {
+      get_all_public with
+      msg_name= "get_all_where"
+    ; msg_tag= FromObject GetAllWhere
+    ; msg_params=
+        [
+          {
+            param_type= String
+          ; param_name= "expr"
+          ; param_doc= "expression matching records"
+          ; param_release= x.obj_release
+          ; param_default= None
+          }
+        ]
+    ; msg_result= Some (Set (Ref x.name), "references to all matching objects")
+    ; msg_release=
+        {
+          opensource= []
+        ; internal=
+            x.obj_release.internal
+            (* This should be the release of getallwhere, or the class'
+                introduction, whichever is last. *)
+        ; internal_deprecated_since= None
+        }
+    ; msg_allowed_roles= x.obj_implicit_msg_allowed_roles
+    ; msg_hide_from_docs= true
+    }
+  in
+
   (* And the 'get_all_records_where' semi-public function *)
   let get_all_records_where =
     {
@@ -738,7 +768,7 @@ let messages_of_obj (x : obj) document_order : message list =
   in
   let get_all_public =
     if List.mem x.name expose_get_all_messages_for then
-      [get_all_public; get_all_records_where; get_all_records]
+      [get_all_public; get_all_where; get_all_records_where; get_all_records]
     else
       []
   in

ocaml/idl/ocaml_backend/gen_db_actions.ml

@@ -536,6 +536,12 @@ let db_action api : O.Module.t =
               "let expr' = Xapi_database.Db_filter.expr_of_string expr in"
             ; "get_records_where ~" ^ Gen_common.context ^ " ~expr:expr'"
             ]
+      | FromObject GetAllWhere ->
+          String.concat "\n"
+            [
+              "let expr' = Xapi_database.Db_filter.expr_of_string expr in"
+            ; "get_refs_where ~" ^ Gen_common.context ^ " ~expr:expr'"
+            ]
       | _ ->
           assert false
     in

ocaml/idl/ocaml_backend/gen_empty_custom.ml

@@ -62,20 +62,21 @@ let operation_requires_side_effect ({msg_tag= tag; _} as msg) =
   match tag with
   | FromField (Setter, fld) ->
       fld.DT.field_has_effect
+  | FromField ((Getter | Add | Remove), _) ->
+      false
   | FromObject
       ( GetRecord
       | GetByUuid
       | GetByLabel
       | GetAll
+      | GetAllWhere
       | GetAllRecordsWhere
       | GetAllRecords ) ->
       false
-  | FromObject _ ->
+  | FromObject (Make | Delete | Private _) ->
       true
   | Custom ->
       msg.DT.msg_has_effect && msg.DT.msg_forward_to = None
-  | _ ->
-      false
 
 let make_custom_api api =
   Dm_api.filter

ocaml/xapi-cli-server/cli_operations.ml

@@ -4580,68 +4580,58 @@ let vm_migrate printer rpc session_id params =
       Client.Session.login_with_password ~rpc:remote_rpc ~uname ~pwd
         ~version:"1.3" ~originator:Constants.xapi_user_agent
     in
+    let remote f = f ~rpc:remote_rpc ~session_id:remote_session in
     finally
       (fun () ->
-        let host, host_record =
-          let all =
-            Client.Host.get_all_records ~rpc:remote_rpc
-              ~session_id:remote_session
+        let host =
+          let expr_match x =
+            Printf.sprintf
+              {|(field "hostname"="%s") or (field "name__label"="%s") or (field "uuid"="%s")|}
+              x x x
           in
-          if List.mem_assoc "host" params then
-            let x = List.assoc "host" params in
-            try
-              List.find
-                (fun (_, h) ->
-                  h.API.host_hostname = x
-                  || h.API.host_name_label = x
-                  || h.API.host_uuid = x
-                )
-                all
-            with Not_found ->
-              failwith (Printf.sprintf "Failed to find host: %s" x)
-          else
-            List.hd all
+          let expr, fail_msg =
+            match List.assoc_opt "host" params with
+            | Some x ->
+                (expr_match x, Printf.sprintf "Failed to find host: %s" x)
+            | None ->
+                ("true", Printf.sprintf "Failed to find a suitable host")
+          in
+          match remote Client.Host.get_all_where ~expr with
+          | host :: _ ->
+              host
+          | [] ->
+              failwith fail_msg
         in
-        let network, network_record =
-          let all =
-            Client.Network.get_all_records ~rpc:remote_rpc
-              ~session_id:remote_session
+        let network =
+          let expr x =
+            Printf.sprintf
+              {|(field "bridge"="%s") or (field "name__label"="%s") or (field "uuid"="%s")|}
+              x x x
           in
-          if List.mem_assoc "remote-network" params then
-            let x = List.assoc "remote-network" params in
-            try
-              List.find
-                (fun (_, net) ->
-                  net.API.network_bridge = x
-                  || net.API.network_name_label = x
-                  || net.API.network_uuid = x
-                )
-                all
-            with Not_found ->
-              failwith (Printf.sprintf "Failed to find network: %s" x)
-          else
-            let pifs = host_record.API.host_PIFs in
-            let management_pifs =
-              List.filter
-                (fun self ->
-                  Client.PIF.get_management ~rpc:remote_rpc
-                    ~session_id:remote_session ~self
-                )
-                pifs
-            in
-            if management_pifs = [] then
-              failwith
-                (Printf.sprintf "Could not find management PIF on host %s"
-                   host_record.API.host_uuid
-                ) ;
-            let pif = List.hd management_pifs in
-            let net =
-              Client.PIF.get_network ~rpc:remote_rpc ~session_id:remote_session
-                ~self:pif
-            in
-            ( net
-            , Client.Network.get_record ~rpc:remote_rpc
-                ~session_id:remote_session ~self:net
+          match List.assoc_opt "remote-network" params with
+          | Some x -> (
+            match remote Client.Network.get_all_where ~expr:(expr x) with
+            | network :: _ ->
+                network
+            | [] ->
+                failwith (Printf.sprintf "Failed to find network: %s" x)
+          )
+          | None -> (
+              let expr =
+                Printf.sprintf
+                  {|(field "host"="%s") and (field "management"="true")|}
+                  Ref.(string_of host)
+              in
+              let management_pifs = remote Client.PIF.get_all_where ~expr in
+              match management_pifs with
+              | [] ->
+                  let host_uuid = remote Client.Host.get_uuid ~self:host in
+                  failwith
+                    (Printf.sprintf "Could not find management PIF on host %s"
+                       host_uuid
+                    )
+              | pif :: _ ->
+                  remote Client.PIF.get_network ~self:pif
             )
         in
         let vif_map =
@@ -4650,10 +4640,7 @@ let vm_migrate printer rpc session_id params =
               let vif =
                 Client.VIF.get_by_uuid ~rpc ~session_id ~uuid:vif_uuid
               in
-              let net =
-                Client.Network.get_by_uuid ~rpc:remote_rpc
-                  ~session_id:remote_session ~uuid:net_uuid
-              in
+              let net = remote Client.Network.get_by_uuid ~uuid:net_uuid in
               (vif, net)
             )
             (read_map_params "vif" params)
@@ -4664,10 +4651,7 @@ let vm_migrate printer rpc session_id params =
               let vdi =
                 Client.VDI.get_by_uuid ~rpc ~session_id ~uuid:vdi_uuid
               in
-              let sr =
-                Client.SR.get_by_uuid ~rpc:remote_rpc ~session_id:remote_session
-                  ~uuid:sr_uuid
-              in
+              let sr = remote Client.SR.get_by_uuid ~uuid:sr_uuid in
               (vdi, sr)
             )
             (read_map_params "vdi" params)
@@ -4679,8 +4663,7 @@ let vm_migrate printer rpc session_id params =
                 Client.VGPU.get_by_uuid ~rpc ~session_id ~uuid:vgpu_uuid
               in
               let gpu_group =
-                Client.GPU_group.get_by_uuid ~rpc:remote_rpc
-                  ~session_id:remote_session ~uuid:gpu_group_uuid
+                remote Client.GPU_group.get_by_uuid ~uuid:gpu_group_uuid
               in
               (vgpu, gpu_group)
             )
@@ -4696,19 +4679,12 @@ let vm_migrate printer rpc session_id params =
                 {|(field "host"="%s") and (field "currently_attached"="true")|}
                 (Ref.string_of host)
             in
-            let host_pbds =
-              Client.PBD.get_all_records_where ~rpc:remote_rpc
-                ~session_id:remote_session ~expr
-            in
             let srs =
-              List.map
-                (fun (_, pbd_rec) ->
-                  ( pbd_rec.API.pBD_SR
-                  , Client.SR.get_record ~rpc:remote_rpc
-                      ~session_id:remote_session ~self:pbd_rec.API.pBD_SR
-                  )
-                )
-                host_pbds
+              remote Client.PBD.get_all_where ~expr
+              |> List.map (fun pbd ->
+                     let sr = remote Client.PBD.get_SR ~self:pbd in
+                     (sr, remote Client.SR.get_record ~self:sr)
+                 )
             in
             (* In the following loop, the current SR:sr' will be compared with previous checked ones,
                first if it is an ISO type, then pass this one for selection, then the only shared one from this and
@@ -4807,13 +4783,20 @@ let vm_migrate printer rpc session_id params =
             )
             params
         in
+        let host_name_label =
+          Client.Host.get_name_label ~rpc:remote_rpc ~session_id:remote_session
+            ~self:host
+        in
+        let network_name_label =
+          Client.Network.get_name_label ~rpc:remote_rpc
+            ~session_id:remote_session ~self:network
+        in
         printer
           (Cli_printer.PMsg
              (Printf.sprintf
                 "Will migrate to remote host: %s, using remote network: %s. \
                  Here is the VDI mapping:"
-                host_record.API.host_name_label
-                network_record.API.network_name_label
+                host_name_label network_name_label
              )
           ) ;
         List.iter
@@ -4822,16 +4805,13 @@ let vm_migrate printer rpc session_id params =
               (Cli_printer.PMsg
                  (Printf.sprintf "VDI %s -> SR %s"
                     (Client.VDI.get_uuid ~rpc ~session_id ~self:vdi)
-                    (Client.SR.get_uuid ~rpc:remote_rpc
-                       ~session_id:remote_session ~self:sr
-                    )
+                    (remote Client.SR.get_uuid ~self:sr)
                  )
               )
           )
           vdi_map ;
         let token =
-          Client.Host.migrate_receive ~rpc:remote_rpc ~session_id:remote_session
-            ~host ~network ~options
+          remote Client.Host.migrate_receive ~host ~network ~options
         in
         let new_vm =
           do_vm_op ~include_control_vms:false ~include_template_vms:true printer
@@ -4847,13 +4827,7 @@ let vm_migrate printer rpc session_id params =
           |> List.hd
         in
         if get_bool_param params "copy" then
-          printer
-            (Cli_printer.PList
-               [
-                 Client.VM.get_uuid ~rpc:remote_rpc ~session_id:remote_session
-                   ~self:new_vm
-               ]
-            )
+          printer (Cli_printer.PList [remote Client.VM.get_uuid ~self:new_vm])
       )
       (fun () ->
         Client.Session.logout ~rpc:remote_rpc ~session_id:remote_session

ocaml/xapi/xapi_role.ml

@@ -92,25 +92,26 @@ let get_record ~__context ~self =
     ~static_fn:(fun static_record -> get_api_record ~static_record)
     ~db_fn:(fun ~__context ~self -> Db.Role.get_record ~__context ~self)
 
-(*    val get_all_records_where : __context:Context.t -> expr:string -> ref_role_to_role_t_map*)
 let expr_no_permissions = "subroles<>[]"
 
 let expr_only_permissions = "subroles=[]"
 
-let get_all_records_where ~__context ~expr =
+let get_common_where ~__context ~expr ~f =
   if expr = expr_no_permissions then (* composite role, ie. not a permission *)
-    List.map
-      (fun r -> (ref_of_role ~role:r, get_api_record ~static_record:r))
-      Rbac_static.all_static_roles
+    List.map f Rbac_static.all_static_roles
   else if expr = expr_only_permissions then
     (* composite role, ie. a permission *)
-    List.map
-      (fun r -> (ref_of_role ~role:r, get_api_record ~static_record:r))
-      Rbac_static.all_static_permissions
+    List.map f Rbac_static.all_static_permissions
   else (* anything in this table, ie. roles+permissions *)
-    List.map
-      (fun r -> (ref_of_role ~role:r, get_api_record ~static_record:r))
-      get_all_static_roles
+    List.map f get_all_static_roles
+
+let get_all_where ~__context ~expr =
+  let f r = ref_of_role ~role:r in
+  get_common_where ~__context ~expr ~f
+
+let get_all_records_where ~__context ~expr =
+  let f r = (ref_of_role ~role:r, get_api_record ~static_record:r) in
+  get_common_where ~__context ~expr ~f
 
 (*@ (* concatenate with Db table *)
   			(* TODO: this line is crashing for some unknown reason, but not needed in RBAC 1 *)