Merge pull request #5959 from Vincent-lau/private/shul2/sr-scan2

CP-51042: Introduce new SR.scan2 for SMAPI{v1,v2,v3}

Author: Vincent-lau

ocaml/xapi-idl/storage/dune

@@ -28,7 +28,7 @@
    xapi-log
  )
  (wrapped false)
- (preprocess (pps ppx_sexp_conv ppx_deriving_rpc)))
+ (preprocess (pps ppx_sexp_conv ppx_deriving_rpc ppx_deriving.show)))
 
 (library
  (name xcp_storage)

ocaml/xapi-idl/storage/storage_interface.ml

@@ -233,7 +233,7 @@ let default_vdi_info =
       failwith (Printf.sprintf "Error creating default_vdi_info: %s" m)
 
 type sr_health = Healthy | Recovering | Unreachable | Unavailable
-[@@deriving rpcty]
+[@@deriving rpcty, show {with_path= false}]
 
 type sr_info = {
     sr_uuid: string option
@@ -354,6 +354,7 @@ module Errors = struct
     | Cancelled of string
     | Redirect of string option
     | Sr_attached of string
+    | Sr_unhealthy of sr_health
     | Unimplemented of string
     | Activated_on_another_host of uuid
     | Duplicated_key of string
@@ -617,12 +618,24 @@ module StorageAPI (R : RPC) = struct
     let destroy =
       declare "SR.destroy" [] (dbg_p @-> sr_p @-> returning unit_p err)
 
-    (** [scan task sr] returns a list of VDIs contained within an attached SR *)
+    (** [scan task sr] returns a list of VDIs contained within an attached SR.
+    @deprecated This function is deprecated, and is only here to keep backward 
+    compatibility with old xapis that call Remote.SR.scan during SXM. 
+    Use the scan2 function instead. 
+    *)
     let scan =
       let open TypeCombinators in
       let result = Param.mk ~name:"result" (list vdi_info) in
       declare "SR.scan" [] (dbg_p @-> sr_p @-> returning result err)
 
+    (** [scan2 task sr] returns a list of VDIs contained within an attached SR,
+    as well as the sr_info of the scanned [sr]. This operation is implemented as
+    a combination of scan and stats. *)
+    let scan2 =
+      let open TypeCombinators in
+      let result = Param.mk ~name:"result" (pair (list vdi_info, sr_info)) in
+      declare "SR.scan2" [] (dbg_p @-> sr_p @-> returning result err)
+
     (** [update_snapshot_info_src sr vdi url dest dest_vdi snapshot_pairs] *
         updates the fields is_a_snapshot, snapshot_time and snapshot_of for a *
         list of snapshots on a remote SR. *)
@@ -1160,6 +1173,8 @@ module type Server_impl = sig
 
     val scan : context -> dbg:debug_info -> sr:sr -> vdi_info list
 
+    val scan2 : context -> dbg:debug_info -> sr:sr -> vdi_info list * sr_info
+
     val update_snapshot_info_src :
          context
       -> dbg:debug_info
@@ -1449,6 +1464,7 @@ module Server (Impl : Server_impl) () = struct
     S.SR.reset (fun dbg sr -> Impl.SR.reset () ~dbg ~sr) ;
     S.SR.destroy (fun dbg sr -> Impl.SR.destroy () ~dbg ~sr) ;
     S.SR.scan (fun dbg sr -> Impl.SR.scan () ~dbg ~sr) ;
+    S.SR.scan2 (fun dbg sr -> Impl.SR.scan2 () ~dbg ~sr) ;
     S.SR.update_snapshot_info_src
       (fun dbg sr vdi url dest dest_vdi snapshot_pairs verify_dest ->
         Impl.SR.update_snapshot_info_src () ~dbg ~sr ~vdi ~url ~dest ~dest_vdi

ocaml/xapi-idl/storage/storage_skeleton.ml

@@ -68,6 +68,8 @@ module SR = struct
 
   let scan ctx ~dbg ~sr = u "SR.scan"
 
+  let scan2 ctx ~dbg ~sr = u "SR.scan2"
+
   let update_snapshot_info_src ctx ~dbg ~sr ~vdi ~url ~dest ~dest_vdi
       ~snapshot_pairs =
     u "SR.update_snapshot_info_src"

ocaml/xapi-storage-script/dune

@@ -13,6 +13,7 @@
 
     message-switch-async
     message-switch-unix
+    ppx_deriving.runtime
     result
     rpclib.core
     rpclib.json

ocaml/xapi-storage-script/main.ml

@@ -1207,6 +1207,74 @@ let bind ~volume_script_dir =
     |> wrap
   in
   S.SR.scan sr_scan_impl ;
+  let sr_scan2_impl dbg sr =
+    Attached_SRs.find sr
+    >>>= (fun sr ->
+           return_volume_rpc (fun () -> Sr_client.stat (volume_rpc ~dbg) dbg sr)
+           >>>= fun response ->
+           Deferred.Result.return
+             {
+               Storage_interface.sr_uuid= response.Xapi_storage.Control.uuid
+             ; name_label= response.Xapi_storage.Control.name
+             ; name_description= response.Xapi_storage.Control.description
+             ; total_space= response.Xapi_storage.Control.total_space
+             ; free_space= response.Xapi_storage.Control.free_space
+             ; clustered= response.Xapi_storage.Control.clustered
+             ; health=
+                 ( match response.Xapi_storage.Control.health with
+                 | Xapi_storage.Control.Healthy _ ->
+                     Healthy
+                 | Xapi_storage.Control.Recovering _ ->
+                     Recovering
+                 | Xapi_storage.Control.Unreachable _ ->
+                     Unreachable
+                 | Xapi_storage.Control.Unavailable _ ->
+                     Unavailable
+                 )
+             }
+           >>>= fun sr_info ->
+           match sr_info.health with
+           | Healthy ->
+               return_volume_rpc (fun () ->
+                   Sr_client.ls
+                     (volume_rpc ~dbg ~compat_out:Compat.compat_out_volumes)
+                     dbg sr
+               )
+               >>>= fun response ->
+               let response = Array.to_list response in
+               (* Filter out volumes which are clone-on-boot transients *)
+               let transients =
+                 List.fold
+                   ~f:(fun set x ->
+                     match
+                       List.Assoc.find x.Xapi_storage.Control.keys
+                         _clone_on_boot_key ~equal:String.equal
+                     with
+                     | None ->
+                         set
+                     | Some transient ->
+                         Set.add set transient
+                   )
+                   ~init:Core.String.Set.empty response
+               in
+               let response =
+                 List.filter
+                   ~f:(fun x ->
+                     not (Set.mem transients x.Xapi_storage.Control.key)
+                   )
+                   response
+               in
+               Deferred.Result.return
+                 (List.map ~f:vdi_of_volume response, sr_info)
+           | health ->
+               debug "%s: sr unhealthy %s" __FUNCTION__
+                 (Storage_interface.show_sr_health health) ;
+               Deferred.Result.fail
+                 Storage_interface.(Errors.Sr_unhealthy health)
+         )
+    |> wrap
+  in
+  S.SR.scan2 sr_scan2_impl ;
   let vdi_create_impl dbg sr (vdi_info : Storage_interface.vdi_info) =
     Attached_SRs.find sr
     >>>= (fun sr ->

ocaml/xapi/storage_mux.ml

@@ -348,6 +348,14 @@ module Mux = struct
       end)) in
       C.SR.stat (Debug_info.to_string di) sr
 
+    let scan2 () ~dbg ~sr =
+      with_dbg ~name:"SR.scan2" ~dbg @@ fun di ->
+      info "SR.scan2 dbg:%s sr:%s" dbg (s_of_sr sr) ;
+      let module C = StorageAPI (Idl.Exn.GenClient (struct
+        let rpc = of_sr sr
+      end)) in
+      C.SR.scan2 (Debug_info.to_string di) sr
+
     let scan () ~dbg ~sr =
       with_dbg ~name:"SR.scan" ~dbg @@ fun di ->
       info "SR.scan dbg:%s sr:%s" dbg (s_of_sr sr) ;

ocaml/xapi/storage_smapiv1_wrapper.ml

@@ -1210,6 +1210,20 @@ functor
                 Impl.SR.scan context ~dbg ~sr
         )
 
+      let scan2 context ~dbg ~sr =
+        with_dbg ~name:"SR.scan2" ~dbg @@ fun di ->
+        info "SR.scan2 dbg:%s sr:%s" di.log (s_of_sr sr) ;
+        let dbg = Debug_info.to_string di in
+        with_sr sr (fun () ->
+            match Host.find sr !Host.host with
+            | None ->
+                raise (Storage_error (Sr_not_attached (s_of_sr sr)))
+            | Some _ ->
+                let vs = Impl.SR.scan context ~dbg ~sr in
+                let sr_info = Impl.SR.stat context ~dbg ~sr in
+                (vs, sr_info)
+        )
+
       let create context ~dbg ~sr ~name_label ~name_description ~device_config
           ~physical_size =
         with_dbg ~name:"SR.create" ~dbg @@ fun di ->

ocaml/xapi/xapi_sr.ml

@@ -787,19 +787,15 @@ let scan ~__context ~sr =
   SRScanThrottle.execute (fun () ->
       transform_storage_exn (fun () ->
           let sr_uuid = Db.SR.get_uuid ~__context ~self:sr in
-          let vs =
-            C.SR.scan (Ref.string_of task)
+          let vs, sr_info =
+            C.SR.scan2 (Ref.string_of task)
               (Storage_interface.Sr.of_string sr_uuid)
           in
           let db_vdis =
             Db.VDI.get_records_where ~__context
               ~expr:(Eq (Field "SR", Literal sr'))
           in
           update_vdis ~__context ~sr db_vdis vs ;
-          let sr_info =
-            C.SR.stat (Ref.string_of task)
-              (Storage_interface.Sr.of_string sr_uuid)
-          in
           let virtual_allocation =
             List.fold_left Int64.add 0L
               (List.map (fun v -> v.Storage_interface.virtual_size) vs)