From fd0818d0d41e2fb447a0f2c43ba3c32ae33709d0 Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Tue, 25 Jun 2024 16:19:43 +0100 Subject: [PATCH 1/5] context: `complete_tracing` should be called last Use `finally` to execute `complete_tracing` on the context when we are done and not at the beginning. This allows for instrumentation and correct trace display of functions such as `assert_op_valid`. Signed-off-by: Gabriel Buica --- ocaml/xapi/taskHelper.ml | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/ocaml/xapi/taskHelper.ml b/ocaml/xapi/taskHelper.ml index abe7f4b4599..afa9f3f05a0 100644 --- a/ocaml/xapi/taskHelper.ml +++ b/ocaml/xapi/taskHelper.ml @@ -18,6 +18,13 @@ module Date = Xapi_stdext_date.Date let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute +let ( let@ ) f x = f x + +let finally_complete_tracing ?error __context f = + Xapi_stdext_pervasives.Pervasiveext.finally f (fun () -> + Context.complete_tracing ?error __context + ) + type t = API.ref_task (* creates a new task *) @@ -178,7 +185,7 @@ let status_is_completed task_status = task_status = `success || task_status = `failure || task_status = `cancelled let complete ~__context result = - Context.complete_tracing __context ; + let@ () = finally_complete_tracing __context in operate_on_db_task ~__context (fun self -> let status = Db_actions.DB_Action.Task.get_status ~__context ~self in if status = `pending then ( @@ -225,7 +232,7 @@ let exn_if_cancelling ~__context = raise_cancelled ~__context let cancel_this ~__context ~self = - Context.complete_tracing __context ; + let@ () = finally_complete_tracing __context in assert_op_valid ~__context self ; let status = Db_actions.DB_Action.Task.get_status ~__context ~self in if status = `pending then ( @@ -244,7 +251,7 @@ let cancel ~__context = let failed ~__context exn = let backtrace = Printexc.get_backtrace () in - Context.complete_tracing __context ~error:(exn, backtrace) ; + let@ () = finally_complete_tracing ~error:(exn, backtrace) __context in let code, params = ExnHelper.error_of_exn exn in operate_on_db_task ~__context (fun self -> let status = Db_actions.DB_Action.Task.get_status ~__context ~self in @@ -267,7 +274,11 @@ let failed ~__context exn = debug "the status of %s is %s; cannot set it to %s" (Ref.really_pretty_and_small self) (status_to_string status) - (if code = Api_errors.task_cancelled then "`cancelled" else "`failure") + ( if code = Api_errors.task_cancelled then + "`cancelled" + else + "`failure" + ) ) type id = Sm of string | Xenops of string * string From 9ddaf75fc5e40e30e8247014ed1169898e6bd40f Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Wed, 26 Jun 2024 09:08:57 +0100 Subject: [PATCH 2/5] context: catch error inside span Update `with_tracing` to record the error and finish the span if the instrumented function fails. Add `session.track.id` and `task.id` attributes to all spans inside a trace that is following a task. This will result in spans being finished even if the function has raised an exception. Plus, better debuggability in the case that something fails. Signed-off-by: Gabriel Buica --- ocaml/xapi/context.ml | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/context.ml b/ocaml/xapi/context.ml index 92ab9c82130..7027caaec67 100644 --- a/ocaml/xapi/context.ml +++ b/ocaml/xapi/context.ml @@ -503,12 +503,23 @@ let get_user_agent context = let with_tracing ?originator ~__context name f = let open Tracing in let parent = __context.tracing in - let span_attributes = Attributes.attr_of_originator originator in + let span_attributes = + Attributes.attr_of_originator originator + @ make_attributes ~task_id:__context.task_id + ?session_id:__context.session_id () + in match start_tracing_helper ~span_attributes (fun _ -> parent) name with - | Some _ as span -> + | Some _ as span -> ( + try let new_context = {__context with tracing= span} in let result = f new_context in let _ = Tracer.finish span in result + with exn -> + let backtrace = Printexc.get_raw_backtrace () in + let error = (exn, Printexc.raw_backtrace_to_string backtrace) in + ignore @@ Tracer.finish span ~error ; + Printexc.raise_with_backtrace exn backtrace + ) | None -> f __context From 174b59740aed0be72040b0e8a87f93881d0a86bc Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Thu, 20 Jun 2024 09:55:19 +0100 Subject: [PATCH 3/5] tracing: Instrument task related functionality Instruments task relatated functions. This will allow for better debuggablity and understanding of issues related with tasks. Signed-off-by: Gabriel Buica --- ocaml/xapi/helpers.ml | 3 +++ ocaml/xapi/message_forwarding.ml | 2 ++ ocaml/xapi/taskHelper.ml | 19 +++++++++++++++++++ ocaml/xapi/xapi_task.ml | 8 ++++++++ 4 files changed, 32 insertions(+) diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index ba58ddd7b92..87e143dc227 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -546,6 +546,7 @@ let call_api_functions_internal ~__context f = ) let call_api_functions ~__context f = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> match Context.get_test_rpc __context with | Some rpc -> f rpc (Ref.of_string "fake_session") @@ -1733,6 +1734,7 @@ module Task : sig end = struct (* can't place these functions in task helpers due to circular dependencies *) let wait_for_ ~__context ~tasks ~propagate_cancel cb = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> let our_task = Context.get_task_id __context in let classes = List.map @@ -1819,6 +1821,7 @@ end = struct wait_for_ ~__context ~tasks:[t] mirror let to_result ~__context ~of_rpc ~t = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> wait_for_mirror ~__context ~propagate_cancel:true ~t ; let fail msg = raise diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index 6be9f50d4c0..cef4de7a732 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -688,6 +688,7 @@ functor include Local.Task let cancel ~__context ~task = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> TaskHelper.assert_op_valid ~__context task ; let local_fn = cancel ~task in let forwarded_to = Db.Task.get_forwarded_to ~__context ~self:task in @@ -1185,6 +1186,7 @@ functor with _ -> () let cancel ~__context ~vm ~ops = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> let cancelled = List.filter_map (fun (task, op) -> diff --git a/ocaml/xapi/taskHelper.ml b/ocaml/xapi/taskHelper.ml index afa9f3f05a0..334792fd63b 100644 --- a/ocaml/xapi/taskHelper.ml +++ b/ocaml/xapi/taskHelper.ml @@ -30,6 +30,7 @@ type t = API.ref_task (* creates a new task *) let make ~__context ~http_other_config ?(description = "") ?session_id ?subtask_of label : t * t Uuidx.t = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> let uuid = Uuidx.make () in let uuid_str = Uuidx.to_string uuid in let ref = Ref.make () in @@ -61,6 +62,7 @@ let rbac_assert_permission_fn = ref None (* required to break dep-cycle with rbac.ml *) let assert_op_valid ?(ok_if_no_session_in_context = false) ~__context task_id = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> let assert_permission_task_op_any () = match !rbac_assert_permission_fn with | None -> @@ -108,6 +110,7 @@ let assert_op_valid ?(ok_if_no_session_in_context = false) ~__context task_id = assert_permission_task_op_any () let get_name ~__context = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> let task_id = Context.get_task_id __context in if Ref.is_dummy task_id then Ref.name_of_dummy task_id @@ -115,6 +118,7 @@ let get_name ~__context = Db.Task.get_name_label ~__context ~self:task_id let destroy ~__context task_id = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> if not (Ref.is_dummy task_id) then ( assert_op_valid ~ok_if_no_session_in_context:true ~__context task_id ; Db_actions.DB_Action.Task.destroy ~__context ~self:task_id @@ -130,26 +134,31 @@ let init () = Context.__make_task := make let operate_on_db_task ~__context f = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> if Context.task_in_database __context then f (Context.get_task_id __context) let set_description ~__context value = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> operate_on_db_task ~__context (fun self -> Db_actions.DB_Action.Task.set_name_description ~__context ~self ~value ) let add_to_other_config ~__context key value = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> operate_on_db_task ~__context (fun self -> Db_actions.DB_Action.Task.remove_from_other_config ~__context ~self ~key ; Db_actions.DB_Action.Task.add_to_other_config ~__context ~self ~key ~value ) let set_progress ~__context value = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> operate_on_db_task ~__context (fun self -> Db_actions.DB_Action.Task.set_progress ~__context ~self ~value ) let set_external_pid ~__context pid = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> operate_on_db_task ~__context (fun self -> Db_actions.DB_Action.Task.set_externalpid ~__context ~self ~value:(Int64.of_int pid) @@ -158,6 +167,7 @@ let set_external_pid ~__context pid = let clear_external_pid ~__context = set_external_pid ~__context (-1) let set_result_on_task ~__context task_id result = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> match result with | None -> () @@ -167,6 +177,7 @@ let set_result_on_task ~__context task_id result = (** Only set the result without completing the task. Useful for vm import *) let set_result ~__context result = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> operate_on_db_task ~__context (fun t -> set_result_on_task ~__context t result) let status_to_string = function @@ -203,18 +214,21 @@ let complete ~__context result = ) let set_cancellable ~__context = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> operate_on_db_task ~__context (fun self -> Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self ~value:[`cancel] ) let set_not_cancellable ~__context = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> operate_on_db_task ~__context (fun self -> Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self ~value:[] ) let is_cancelling ~__context = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> Context.task_in_database __context && let l = @@ -224,10 +238,12 @@ let is_cancelling ~__context = List.exists (fun (_, x) -> x = `cancel) l let raise_cancelled ~__context = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> let task_id = Context.get_task_id __context in raise Api_errors.(Server_error (task_cancelled, [Ref.string_of task_id])) let exn_if_cancelling ~__context = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> if is_cancelling ~__context then raise_cancelled ~__context @@ -247,6 +263,7 @@ let cancel_this ~__context ~self = (status_to_string status) let cancel ~__context = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> operate_on_db_task ~__context (fun self -> cancel_this ~__context ~self) let failed ~__context exn = @@ -298,6 +315,7 @@ let task_to_id_exn task = with_lock task_tbl_m (fun () -> Hashtbl.find task_to_id_tbl task) let register_task __context ?(cancellable = true) id = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> let task = Context.get_task_id __context in with_lock task_tbl_m (fun () -> Hashtbl.replace id_to_task_tbl id task ; @@ -313,6 +331,7 @@ let register_task __context ?(cancellable = true) id = () let unregister_task __context id = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> (* The rest of the XenAPI Task won't be cancellable *) set_not_cancellable ~__context ; with_lock task_tbl_m (fun () -> diff --git a/ocaml/xapi/xapi_task.ml b/ocaml/xapi/xapi_task.ml index 22016270fbc..aef42c01593 100644 --- a/ocaml/xapi/xapi_task.ml +++ b/ocaml/xapi/xapi_task.ml @@ -20,6 +20,7 @@ module D = Debug.Make (struct let name = "xapi_task" end) open D let create ~__context ~label ~description = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> (* This call will have a dummy task ID already but we need to make a fresh one *) let subtask_of = Context.get_task_id __context in let session_id = @@ -34,6 +35,7 @@ let create ~__context ~label ~description = t let destroy ~__context ~self = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> TaskHelper.assert_op_valid ~__context self ; if TaskHelper.status_is_completed (Db.Task.get_status ~__context ~self) then Db.Task.destroy ~__context ~self @@ -42,6 +44,7 @@ let destroy ~__context ~self = ~value:`destroy let cancel ~__context ~task = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> let localhost = Helpers.get_localhost ~__context in let forwarded_to = Db.Task.get_forwarded_to ~__context ~self:task in if Db.is_valid_ref __context forwarded_to && localhost <> forwarded_to then @@ -62,21 +65,26 @@ let cancel ~__context ~task = info "Task.cancel is falling back to polling" let set_status ~__context ~self ~value = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> TaskHelper.assert_op_valid ~__context self ; Db.Task.set_status ~__context ~self ~value let set_progress ~__context ~self ~value = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> TaskHelper.assert_op_valid ~__context self ; Db.Task.set_progress ~__context ~self ~value let set_result ~__context ~self ~value = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> TaskHelper.assert_op_valid ~__context self ; Db.Task.set_result ~__context ~self ~value let set_error_info ~__context ~self ~value = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> TaskHelper.assert_op_valid ~__context self ; Db.Task.set_error_info ~__context ~self ~value let set_resident_on ~__context ~self ~value = + Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> TaskHelper.assert_op_valid ~__context self ; Db.Task.set_resident_on ~__context ~self ~value From 1e619ab2164f71ccf45f95b7f400a8e85b2a9b9f Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Mon, 1 Jul 2024 10:49:08 +0100 Subject: [PATCH 4/5] time: use `Date.now` over `Unix.time` in `taskHelper.ml` `Date.now` is preffered for synchronisation between host as it uses `ptime`. Signed-off-by: Gabriel Buica --- ocaml/xapi/taskHelper.ml | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/ocaml/xapi/taskHelper.ml b/ocaml/xapi/taskHelper.ml index 334792fd63b..dcd33439d33 100644 --- a/ocaml/xapi/taskHelper.ml +++ b/ocaml/xapi/taskHelper.ml @@ -43,8 +43,7 @@ let make ~__context ~http_other_config ?(description = "") ?session_id Ref.null in let (_ : unit) = - Db_actions.DB_Action.Task.create ~ref ~__context - ~created:(Date.of_float (Unix.time ())) + Db_actions.DB_Action.Task.create ~ref ~__context ~created:(Date.now ()) ~finished:(Date.of_float 0.0) ~current_operations:[] ~_type:"" ~session:(Option.value ~default:Ref.null session_id) ~resident_on:!Xapi_globs.localhost_ref ~status:`pending ~result:"" @@ -203,7 +202,7 @@ let complete ~__context result = Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self ~value:[] ; Db_actions.DB_Action.Task.set_finished ~__context ~self - ~value:(Date.of_float (Unix.time ())) ; + ~value:(Date.now ()) ; Db_actions.DB_Action.Task.set_progress ~__context ~self ~value:1. ; set_result_on_task ~__context self result ; Db_actions.DB_Action.Task.set_status ~__context ~self ~value:`success @@ -253,8 +252,7 @@ let cancel_this ~__context ~self = let status = Db_actions.DB_Action.Task.get_status ~__context ~self in if status = `pending then ( Db_actions.DB_Action.Task.set_progress ~__context ~self ~value:1. ; - Db_actions.DB_Action.Task.set_finished ~__context ~self - ~value:(Date.of_float (Unix.time ())) ; + Db_actions.DB_Action.Task.set_finished ~__context ~self ~value:(Date.now ()) ; Db_actions.DB_Action.Task.set_status ~__context ~self ~value:`cancelled ; Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self ~value:[] ) else @@ -279,7 +277,7 @@ let failed ~__context exn = Db_actions.DB_Action.Task.set_backtrace ~__context ~self ~value:(Sexplib.Sexp.to_string Backtrace.(sexp_of_t (get exn))) ; Db_actions.DB_Action.Task.set_finished ~__context ~self - ~value:(Date.of_float (Unix.time ())) ; + ~value:(Date.now ()) ; Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self ~value:[] ; if code = Api_errors.task_cancelled then From d496db1d2507f82afcf58b0c719b652f251e3453 Mon Sep 17 00:00:00 2001 From: Gabriel Buica Date: Mon, 1 Jul 2024 11:04:10 +0100 Subject: [PATCH 5/5] formatting: Use `let@` and `match` statements. Uses `let@` and `match` statements to avoid nesting. This should increase code readability. Signed-off-by: Gabriel Buica --- ocaml/xapi/taskHelper.ml | 164 +++++++++++++++++++-------------------- 1 file changed, 79 insertions(+), 85 deletions(-) diff --git a/ocaml/xapi/taskHelper.ml b/ocaml/xapi/taskHelper.ml index dcd33439d33..e32c6bf811d 100644 --- a/ocaml/xapi/taskHelper.ml +++ b/ocaml/xapi/taskHelper.ml @@ -30,7 +30,7 @@ type t = API.ref_task (* creates a new task *) let make ~__context ~http_other_config ?(description = "") ?session_id ?subtask_of label : t * t Uuidx.t = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let uuid = Uuidx.make () in let uuid_str = Uuidx.to_string uuid in let ref = Ref.make () in @@ -61,7 +61,7 @@ let rbac_assert_permission_fn = ref None (* required to break dep-cycle with rbac.ml *) let assert_op_valid ?(ok_if_no_session_in_context = false) ~__context task_id = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let assert_permission_task_op_any () = match !rbac_assert_permission_fn with | None -> @@ -109,7 +109,7 @@ let assert_op_valid ?(ok_if_no_session_in_context = false) ~__context task_id = assert_permission_task_op_any () let get_name ~__context = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let task_id = Context.get_task_id __context in if Ref.is_dummy task_id then Ref.name_of_dummy task_id @@ -117,7 +117,7 @@ let get_name ~__context = Db.Task.get_name_label ~__context ~self:task_id let destroy ~__context task_id = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in if not (Ref.is_dummy task_id) then ( assert_op_valid ~ok_if_no_session_in_context:true ~__context task_id ; Db_actions.DB_Action.Task.destroy ~__context ~self:task_id @@ -133,40 +133,36 @@ let init () = Context.__make_task := make let operate_on_db_task ~__context f = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in if Context.task_in_database __context then f (Context.get_task_id __context) let set_description ~__context value = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - operate_on_db_task ~__context (fun self -> - Db_actions.DB_Action.Task.set_name_description ~__context ~self ~value - ) + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let@ self = operate_on_db_task ~__context in + Db_actions.DB_Action.Task.set_name_description ~__context ~self ~value let add_to_other_config ~__context key value = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - operate_on_db_task ~__context (fun self -> - Db_actions.DB_Action.Task.remove_from_other_config ~__context ~self ~key ; - Db_actions.DB_Action.Task.add_to_other_config ~__context ~self ~key ~value - ) + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let@ self = operate_on_db_task ~__context in + Db_actions.DB_Action.Task.remove_from_other_config ~__context ~self ~key ; + Db_actions.DB_Action.Task.add_to_other_config ~__context ~self ~key ~value let set_progress ~__context value = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - operate_on_db_task ~__context (fun self -> - Db_actions.DB_Action.Task.set_progress ~__context ~self ~value - ) + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let@ self = operate_on_db_task ~__context in + Db_actions.DB_Action.Task.set_progress ~__context ~self ~value let set_external_pid ~__context pid = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - operate_on_db_task ~__context (fun self -> - Db_actions.DB_Action.Task.set_externalpid ~__context ~self - ~value:(Int64.of_int pid) - ) + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let@ self = operate_on_db_task ~__context in + Db_actions.DB_Action.Task.set_externalpid ~__context ~self + ~value:(Int64.of_int pid) let clear_external_pid ~__context = set_external_pid ~__context (-1) let set_result_on_task ~__context task_id result = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in match result with | None -> () @@ -176,8 +172,9 @@ let set_result_on_task ~__context task_id result = (** Only set the result without completing the task. Useful for vm import *) let set_result ~__context result = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - operate_on_db_task ~__context (fun t -> set_result_on_task ~__context t result) + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let@ self = operate_on_db_task ~__context in + set_result_on_task ~__context self result let status_to_string = function | `pending -> @@ -196,38 +193,35 @@ let status_is_completed task_status = let complete ~__context result = let@ () = finally_complete_tracing __context in - operate_on_db_task ~__context (fun self -> - let status = Db_actions.DB_Action.Task.get_status ~__context ~self in - if status = `pending then ( - Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self - ~value:[] ; - Db_actions.DB_Action.Task.set_finished ~__context ~self - ~value:(Date.now ()) ; - Db_actions.DB_Action.Task.set_progress ~__context ~self ~value:1. ; - set_result_on_task ~__context self result ; - Db_actions.DB_Action.Task.set_status ~__context ~self ~value:`success - ) else - debug "the status of %s is: %s; cannot set it to `success" - (Ref.really_pretty_and_small self) - (status_to_string status) - ) + let@ self = operate_on_db_task ~__context in + let status = Db_actions.DB_Action.Task.get_status ~__context ~self in + match status with + | `pending -> + Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self + ~value:[] ; + Db_actions.DB_Action.Task.set_finished ~__context ~self + ~value:(Date.now ()) ; + Db_actions.DB_Action.Task.set_progress ~__context ~self ~value:1. ; + set_result_on_task ~__context self result ; + Db_actions.DB_Action.Task.set_status ~__context ~self ~value:`success + | _ -> + debug "the status of %s is: %s; cannot set it to `success" + (Ref.really_pretty_and_small self) + (status_to_string status) let set_cancellable ~__context = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - operate_on_db_task ~__context (fun self -> - Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self - ~value:[`cancel] - ) + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let@ self = operate_on_db_task ~__context in + Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self + ~value:[`cancel] let set_not_cancellable ~__context = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - operate_on_db_task ~__context (fun self -> - Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self - ~value:[] - ) + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let@ self = operate_on_db_task ~__context in + Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self ~value:[] let is_cancelling ~__context = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in Context.task_in_database __context && let l = @@ -237,12 +231,12 @@ let is_cancelling ~__context = List.exists (fun (_, x) -> x = `cancel) l let raise_cancelled ~__context = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let task_id = Context.get_task_id __context in raise Api_errors.(Server_error (task_cancelled, [Ref.string_of task_id])) let exn_if_cancelling ~__context = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in if is_cancelling ~__context then raise_cancelled ~__context @@ -261,40 +255,40 @@ let cancel_this ~__context ~self = (status_to_string status) let cancel ~__context = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> - operate_on_db_task ~__context (fun self -> cancel_this ~__context ~self) + let@ __context = Context.with_tracing ~__context __FUNCTION__ in + let@ self = operate_on_db_task ~__context in + cancel_this ~__context ~self let failed ~__context exn = let backtrace = Printexc.get_backtrace () in let@ () = finally_complete_tracing ~error:(exn, backtrace) __context in let code, params = ExnHelper.error_of_exn exn in - operate_on_db_task ~__context (fun self -> - let status = Db_actions.DB_Action.Task.get_status ~__context ~self in - if status = `pending then ( - Db_actions.DB_Action.Task.set_progress ~__context ~self ~value:1. ; - Db_actions.DB_Action.Task.set_error_info ~__context ~self - ~value:(code :: params) ; - Db_actions.DB_Action.Task.set_backtrace ~__context ~self - ~value:(Sexplib.Sexp.to_string Backtrace.(sexp_of_t (get exn))) ; - Db_actions.DB_Action.Task.set_finished ~__context ~self - ~value:(Date.now ()) ; - Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self - ~value:[] ; - if code = Api_errors.task_cancelled then - Db_actions.DB_Action.Task.set_status ~__context ~self - ~value:`cancelled - else - Db_actions.DB_Action.Task.set_status ~__context ~self ~value:`failure - ) else - debug "the status of %s is %s; cannot set it to %s" - (Ref.really_pretty_and_small self) - (status_to_string status) - ( if code = Api_errors.task_cancelled then - "`cancelled" - else - "`failure" - ) - ) + let@ self = operate_on_db_task ~__context in + let status = Db_actions.DB_Action.Task.get_status ~__context ~self in + match status with + | `pending -> + Db_actions.DB_Action.Task.set_progress ~__context ~self ~value:1. ; + Db_actions.DB_Action.Task.set_error_info ~__context ~self + ~value:(code :: params) ; + Db_actions.DB_Action.Task.set_backtrace ~__context ~self + ~value:(Sexplib.Sexp.to_string Backtrace.(sexp_of_t (get exn))) ; + Db_actions.DB_Action.Task.set_finished ~__context ~self + ~value:(Date.now ()) ; + Db_actions.DB_Action.Task.set_allowed_operations ~__context ~self + ~value:[] ; + if code = Api_errors.task_cancelled then + Db_actions.DB_Action.Task.set_status ~__context ~self ~value:`cancelled + else + Db_actions.DB_Action.Task.set_status ~__context ~self ~value:`failure + | _ -> + debug "the status of %s is %s; cannot set it to %s" + (Ref.really_pretty_and_small self) + (status_to_string status) + ( if code = Api_errors.task_cancelled then + "`cancelled" + else + "`failure" + ) type id = Sm of string | Xenops of string * string @@ -313,7 +307,7 @@ let task_to_id_exn task = with_lock task_tbl_m (fun () -> Hashtbl.find task_to_id_tbl task) let register_task __context ?(cancellable = true) id = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in let task = Context.get_task_id __context in with_lock task_tbl_m (fun () -> Hashtbl.replace id_to_task_tbl id task ; @@ -329,7 +323,7 @@ let register_task __context ?(cancellable = true) id = () let unregister_task __context id = - Context.with_tracing ~__context __FUNCTION__ @@ fun __context -> + let@ __context = Context.with_tracing ~__context __FUNCTION__ in (* The rest of the XenAPI Task won't be cancellable *) set_not_cancellable ~__context ; with_lock task_tbl_m (fun () ->