session_check: add action name in the error returned

Makes it easier to spot which call failed this check when triaging
related issues

Signed-off-by: Pau Ruiz Safont <[email protected]>

ocaml/idl/ocaml_backend/gen_server.ml

@@ -300,8 +300,9 @@ let operation (obj : obj) (x : message) =
   let session_check_exp =
     if x.msg_session then
       [
-        Printf.sprintf "Session_check.check ~intra_pool_only:%b ~session_id;"
-          x.msg_pool_internal
+        Printf.sprintf
+          {|Session_check.check ~intra_pool_only:%b ~session_id ~action:"%s";|}
+          x.msg_pool_internal wire_name
       ]
     else
       []
@@ -528,19 +529,19 @@ let gen_module api : O.Module.t =
                    ^ debug "This is not a built-in rpc \"%s\"" ["__call"]
                  ; "    begin match __params with"
                  ; "    | session_id_rpc :: _->"
+                 ; "      (* based on the Host.call_extension call *)"
+                 ; "      let action = \"Host.call_extension\" in"
                  ; "      let session_id = ref_session_of_rpc session_id_rpc in"
                  ; "      Session_check.check ~intra_pool_only:false \
-                    ~session_id;"
-                 ; "      (* based on the Host.call_extension call *)"
+                    ~session_id ~action;"
                  ; "      let call_rpc = Rpc.String __call in "
                  ; "      let arg_names_values ="
                  ; "        [(\"session_id\", session_id_rpc); (__call, \
                     call_rpc)]"
                  ; "      in"
                  ; "      let key_names = [] in"
-                 ; "      let rbac __context fn = Rbac.check session_id \
-                    \"Host.call_extension\" ~args:arg_names_values \
-                    ~keys:key_names ~__context ~fn in"
+                 ; "      let rbac __context fn = Rbac.check session_id action \
+                    ~args:arg_names_values ~keys:key_names ~__context ~fn in"
                  ; "      Server_helpers.forward_extension ~__context rbac { \
                     call with Rpc.name = __call }"
                  ; "    | _ ->"

ocaml/xapi/session_check.ml

@@ -28,7 +28,7 @@ let is_local_session __context session_id =
     !check_local_session_hook
 
 (* intra_pool_only is true iff the call that's invoking this check can only be called from host<->host intra-pool communication *)
-let check ~intra_pool_only ~session_id =
+let check ~intra_pool_only ~session_id ~action =
   Server_helpers.exec_with_new_task ~quiet:true "session_check"
     (fun __context ->
       (* First see if this is a "local" session *)
@@ -40,17 +40,16 @@ let check ~intra_pool_only ~session_id =
             Db_actions.DB_Action.Session.get_pool ~__context ~self:session_id
           in
           (* If the session is not a pool login, but this call is only supported for pool logins then fail *)
-          if (not pool) && intra_pool_only then
-            raise
-              (Api_errors.Server_error
-                 ( Api_errors.internal_error
-                 , [
-                     "Internal API call attempted with non-pool (external) \
-                      session"
-                   ]
-                 )
-              ) ;
-          (* If the session isn't a pool login, and we're a slave, fail *)
+          ( if (not pool) && intra_pool_only then
+              let msg =
+                Printf.sprintf
+                  {|Internal API "%s" call attempted with non-pool (external) session|}
+                  action
+              in
+              raise Api_errors.(Server_error (internal_error, [msg]))
+          ) ;
+
+          (* If the session isn't a pool login, and we're a supporter, fail *)
           if (not pool) && not (Pool_role.is_master ()) then
             raise Non_master_login_on_slave ;
           if Pool_role.is_master () then

ocaml/xapi/session_check.mli

@@ -0,0 +1,9 @@
+exception Non_master_login_on_slave
+
+val check_local_session_hook :
+  (__context:Context.t -> session_id:[`session] Ref.t -> bool) option ref
+
+val is_local_session : Context.t -> [`session] Ref.t -> bool
+
+val check :
+  intra_pool_only:bool -> session_id:[`session] Ref.t -> action:string -> unit

quality-gate.sh

@@ -25,7 +25,7 @@ verify-cert () {
 }
 
 mli-files () {
-  N=511
+  N=510
   # do not count ml files from the tests in ocaml/{tests/perftest/quicktest}
   MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)
   MLS=$(git  ls-files -- '**/*.ml'  | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;)