Merge pull request #5855 from psafont/rrd-unpack

ocaml/libs/http-lib/http.ml

@@ -94,6 +94,13 @@ let http_501_method_not_implemented ?(version = "1.0") () =
   ; "Cache-Control: no-cache, no-store"
   ]
 
+let http_503_service_unavailable ?(version = "1.0") () =
+  [
+    Printf.sprintf "HTTP/%s 503 Service Unavailable" version
+  ; "Connection: close"
+  ; "Cache-Control: no-cache, no-store"
+  ]
+
 module Hdr = struct
   let task_id = "task-id"
 

ocaml/libs/http-lib/http.mli

@@ -189,6 +189,8 @@ val http_500_internal_server_error : ?version:string -> unit -> string list
 
 val http_501_method_not_implemented : ?version:string -> unit -> string list
 
+val http_503_service_unavailable : ?version:string -> unit -> string list
+
 module Hdr : sig
   val task_id : string
   (** Header used for task id *)

ocaml/libs/http-lib/http_svr.ml

@@ -41,6 +41,8 @@ open D
 
 module E = Debug.Make (struct let name = "http_internal_errors" end)
 
+let ( let* ) = Option.bind
+
 type uri_path = string
 
 module Stats = struct
@@ -296,22 +298,17 @@ module Server = struct
 
   let add_handler x ty uri handler =
     let existing =
-      if MethodMap.mem ty x.handlers then
-        MethodMap.find ty x.handlers
-      else
-        Radix_tree.empty
+      Option.value (MethodMap.find_opt ty x.handlers) ~default:Radix_tree.empty
     in
     x.handlers <-
       MethodMap.add ty
         (Radix_tree.insert uri {(TE.empty ()) with TE.handler} existing)
         x.handlers
 
   let find_stats x m uri =
-    if not (MethodMap.mem m x.handlers) then
-      None
-    else
-      let rt = MethodMap.find m x.handlers in
-      Option.map (fun te -> te.TE.stats) (Radix_tree.longest_prefix uri rt)
+    let* rt = MethodMap.find_opt m x.handlers in
+    let* te = Radix_tree.longest_prefix uri rt in
+    Some te.TE.stats
 
   let all_stats x =
     let open Radix_tree in

ocaml/xapi/rrdd_proxy.ml

@@ -51,61 +51,72 @@ let get_vm_rrd_forwarder (req : Http.Request.t) (s : Unix.file_descr) _ =
   debug "put_rrd_forwarder: start" ;
   let query = req.Http.Request.query in
   req.Http.Request.close <- true ;
-  let vm_uuid = List.assoc "uuid" query in
-  if (not (List.mem_assoc "ref" query)) && not (List.mem_assoc "uuid" query)
-  then
-    fail_req_with s "get_vm_rrd: missing the 'uuid' parameter"
-      Http.http_400_badrequest
-  else if Rrdd.has_vm_rrd vm_uuid then
-    ignore
-      (Xapi_services.hand_over_connection req s !Rrd_interface.forwarded_path)
-  else
-    Xapi_http.with_context ~dummy:true "Get VM RRD." req s (fun __context ->
-        let open Http.Request in
-        (* List of possible actions. *)
-        let read_at_owner owner =
-          let address = Db.Host.get_address ~__context ~self:owner in
-          let url = make_url ~address ~req in
-          Http_svr.headers s (Http.http_302_redirect url)
-        in
-        let unarchive_at_master () =
-          let address = Pool_role.get_master_address () in
-          let query = (Constants.rrd_unarchive, "") :: query in
-          let url = make_url_from_query ~address ~uri:req.uri ~query in
-          Http_svr.headers s (Http.http_302_redirect url)
-        in
-        let unarchive () =
-          let req = {req with uri= Constants.rrd_unarchive_uri} in
-          ignore
-            (Xapi_services.hand_over_connection req s
-               !Rrd_interface.forwarded_path
-            )
-        in
-        (* List of conditions involved. *)
-        let is_unarchive_request =
-          List.mem_assoc Constants.rrd_unarchive query
+  match List.assoc_opt "uuid" query with
+  | None ->
+      fail_req_with s "get_vm_rrd: missing the 'uuid' parameter"
+        Http.http_400_badrequest
+  | Some vm_uuid when Rrdd.has_vm_rrd vm_uuid ->
+      ignore
+        (Xapi_services.hand_over_connection req s !Rrd_interface.forwarded_path)
+  | Some vm_uuid -> (
+      Xapi_http.with_context ~dummy:true "Get VM RRD." req s @@ fun __context ->
+      (* List of possible actions. *)
+      let read_at address =
+        let url = make_url ~address ~req in
+        Http_svr.headers s (Http.http_302_redirect url)
+      in
+      let unarchive_at address =
+        let query = (Constants.rrd_unarchive, "") :: query in
+        let url = make_url_from_query ~address ~uri:req.uri ~query in
+        Http_svr.headers s (Http.http_302_redirect url)
+      in
+      let unarchive () =
+        let req = {req with m= Post; uri= Constants.rrd_unarchive_uri} in
+        ignore
+          (Xapi_services.hand_over_connection req s
+             !Rrd_interface.forwarded_path
+          )
+      in
+      let unavailable () =
+        Http_svr.headers s (Http.http_503_service_unavailable ())
+      in
+      (* List of conditions involved. *)
+      let is_unarchive_request = List.mem_assoc Constants.rrd_unarchive query in
+      let metrics_at () =
+        let ( let* ) = Option.bind in
+        let owner_of vm =
+          let owner = Db.VM.get_resident_on ~__context ~self:vm in
+          let is_xapi_initialising = List.mem_assoc "dbsync" query in
+          let is_available = not is_xapi_initialising in
+          if Db.is_valid_ref __context owner && is_available then
+            Some owner
+          else
+            None
         in
-        let is_master = Pool_role.is_master () in
-        let is_owner_online owner = Db.is_valid_ref __context owner in
-        let is_xapi_initialising = List.mem_assoc "dbsync" query in
-        (* The logic. *)
-        if is_unarchive_request then
-          unarchive ()
+        let* owner = owner_of (Db.VM.get_by_uuid ~__context ~uuid:vm_uuid) in
+        let owner_uuid = Db.Host.get_uuid ~__context ~self:owner in
+        if owner_uuid = Helpers.get_localhost_uuid () then
+          (* VM is local but metrics aren't available *)
+          None
         else
-          let localhost_uuid = Helpers.get_localhost_uuid () in
-          let vm_ref = Db.VM.get_by_uuid ~__context ~uuid:vm_uuid in
-          let owner = Db.VM.get_resident_on ~__context ~self:vm_ref in
-          let owner_uuid = Db.Host.get_uuid ~__context ~self:owner in
-          let is_owner_localhost = owner_uuid = localhost_uuid in
-          if is_owner_localhost then
-            if is_master then
-              unarchive ()
-            else
-              unarchive_at_master ()
-          else if is_owner_online owner && not is_xapi_initialising then
-            read_at_owner owner
-          else
-            unarchive_at_master ()
+          let address = Db.Host.get_address ~__context ~self:owner in
+          Some address
+      in
+      (* The logic. *)
+      if is_unarchive_request then
+        unarchive ()
+      else
+        match (Pool_role.get_role (), metrics_at ()) with
+        | (Master | Slave _), Some owner ->
+            read_at owner
+        | Master, None ->
+            unarchive ()
+        | Slave coordinator, None ->
+            unarchive_at coordinator
+        | Broken, _ ->
+            info "%s: host is broken, VM's metrics are not available"
+              __FUNCTION__ ;
+            unavailable ()
     )
 
 (* Forward the request for host RRD data to the RRDD HTTP handler. If the host