<commit_before>module D = Debug.Debugger(struct let name = "cli" end)
open D

open Stringext
open Event_types
open Event_helper
open Cli_protocol
open Client
open Pervasiveext

let log_exn_continue msg f x = try f x with e -> debug "Ignoring exception: %s while %s" (Printexc.to_string e) msg

exception Cli_failure of string

(** Use the event system to wait for a specific task to complete (succeed, failed or be cancelled) *)
let wait_for_task_completion rpc session_id task = 
  let classes = [ "task" ] in
  finally 
    (fun () ->
       let finished = ref false in
       while not(!finished) do
	 Client.Event.register ~rpc ~session_id ~classes;
	 try
	   (* Need to check once after registering to avoid a race *)
	   finished := Client.Task.get_status ~rpc ~session_id ~self:task <> `pending;

	   while not(!finished) do
	     let events = Event_types.events_of_xmlrpc (Client.Event.next ~rpc ~session_id) in
	     let events = List.map Event_helper.record_of_event events in
	     let matches = function
	       | Event_helper.Task (t, t_rec) -> t = task && t_rec.API.task_status <> `pending
	       | _ -> false in
	     finished := List.fold_left (||) false (List.map matches events)
	   done
	 with Api_errors.Server_error(code, _) when code = Api_errors.events_lost ->
	   debug "Caught EVENTS_LOST; reregistering";
	   Client.Event.unregister ~rpc ~session_id ~classes
       done)
    (fun () -> Client.Event.unregister ~rpc ~session_id ~classes)

let track_http_operation ?use_existing_task fd rpc session_id (make_command: API.ref_task -> command) label =
  (* Need to associate the operation with a task so we can check for failure *)
  let task_id = match use_existing_task with None -> Client.Task.create rpc session_id label "" | Some t -> t in
  finally
    (fun () ->
       marshal fd (Command (make_command task_id));
       if unmarshal fd = Response OK then begin
	 (* Wait for the task to complete *)
	 debug "Waiting for the task to be completed";
	 wait_for_task_completion rpc session_id task_id;
(*
	 (* Events for tasks have been deleted *)
	 while Client.Task.get_status rpc session_id task_id = `pending do
	   Thread.delay 5.
	 done;
*)
	 if Client.Task.get_status rpc session_id task_id = `success then begin
	   let result = Client.Task.get_result rpc session_id task_id in
	   debug "result was [%s]" result;
	   result
	 end else begin
	   let params = Client.Task.get_error_info rpc session_id task_id in
	   raise (Api_errors.Server_error(List.hd params, List.tl params));
	 end
       end else begin
	 debug "client-side reports failure";
	 (* Debug info might have been written into the task, let's see if there is some *)
	 Thread.delay 1.;
	 (* Bit of a race here - we can't simply wait for the task to be completed since *)
	 (* 'response failed' doesn't indicate whether it managed to talk to the handler *)
	 (* or not, so we don't know if the handler got the task_id to complete. The     *)
	 (* import/export commands get round this by setting a negative progress, and    *)
	 (* using this as an indicator that the handler never got the task. All handlers *)
	 (* would need to use this mechanism if we want to check for it here. For now a  *)
	 (* delay of 1 will do... *)
	     let params = Client.Task.get_error_info rpc session_id task_id in
	     raise (Api_errors.Server_error(List.hd params, List.tl params));
       end)
    (fun () ->
       (* if we created our own task then destroy it again; if the task was supplied to us then don't destroy it --
	  if clients pass a task in on the command-line then they are responsible for destroying *)
       match use_existing_task with
	 None -> log_exn_continue "destroying task" (fun x -> Client.Task.destroy rpc session_id x) task_id
       | Some _ -> ()
    )


(* Rewrite the provisioning XML fragment to create all disks on a new, specified SR *)
let rewrite_provisioning_xml rpc session_id new_vm sr_uuid = 
  let rewrite_xml xml newsrname =
    let rewrite_disk = function
      | Xml.Element("disk",params,[]) ->
	  Xml.Element("disk",List.map (fun (x,y) -> if x<>"sr" then (x,y) else ("sr",newsrname)) params,[])
      | x -> x<commit_msg>CA-26147: improve the error message on the server-side if the client side fails. The error thrown just say that it is the fault of the client, unfortunately it is a bit difficult to be more precise here.<commit_after>module D = Debug.Debugger(struct let name = "cli" end)
open D

open Stringext
open Event_types
open Event_helper
open Cli_protocol
open Client
open Pervasiveext

let log_exn_continue msg f x = try f x with e -> debug "Ignoring exception: %s while %s" (Printexc.to_string e) msg

exception Cli_failure of string

(** Use the event system to wait for a specific task to complete (succeed, failed or be cancelled) *)
let wait_for_task_completion rpc session_id task = 
  let classes = [ "task" ] in
  finally 
    (fun () ->
       let finished = ref false in
       while not(!finished) do
	 Client.Event.register ~rpc ~session_id ~classes;
	 try
	   (* Need to check once after registering to avoid a race *)
	   finished := Client.Task.get_status ~rpc ~session_id ~self:task <> `pending;

	   while not(!finished) do
	     let events = Event_types.events_of_xmlrpc (Client.Event.next ~rpc ~session_id) in
	     let events = List.map Event_helper.record_of_event events in
	     let matches = function
	       | Event_helper.Task (t, t_rec) -> t = task && t_rec.API.task_status <> `pending
	       | _ -> false in
	     finished := List.fold_left (||) false (List.map matches events)
	   done
	 with Api_errors.Server_error(code, _) when code = Api_errors.events_lost ->
	   debug "Caught EVENTS_LOST; reregistering";
	   Client.Event.unregister ~rpc ~session_id ~classes
       done)
    (fun () -> Client.Event.unregister ~rpc ~session_id ~classes)

let track_http_operation ?use_existing_task fd rpc session_id (make_command: API.ref_task -> command) label =
  (* Need to associate the operation with a task so we can check for failure *)
  let task_id = match use_existing_task with None -> Client.Task.create rpc session_id label "" | Some t -> t in
  finally
    (fun () ->
       marshal fd (Command (make_command task_id));
       if unmarshal fd = Response OK then begin
	 (* Wait for the task to complete *)
	 debug "Waiting for the task to be completed";
	 wait_for_task_completion rpc session_id task_id;
(*
	 (* Events for tasks have been deleted *)
	 while Client.Task.get_status rpc session_id task_id = `pending do
	   Thread.delay 5.
	 done;
*)
	 if Client.Task.get_status rpc session_id task_id = `success then begin
	   let result = Client.Task.get_result rpc session_id task_id in
	   debug "result was [%s]" result;
	   result
	 end else begin
	   let params = Client.Task.get_error_info rpc session_id task_id in
	   raise (Api_errors.Server_error(List.hd params, List.tl params));
	 end
       end else begin
	 debug "client-side reports failure";
	 (* Debug info might have been written into the task, let's see if there is some *)
	 Thread.delay 1.;
	 (* Bit of a race here - we can't simply wait for the task to be completed since *)
	 (* 'response failed' doesn't indicate whether it managed to talk to the handler *)
	 (* or not, so we don't know if the handler got the task_id to complete. The     *)
	 (* import/export commands get round this by setting a negative progress, and    *)
	 (* using this as an indicator that the handler never got the task. All handlers *)
	 (* would need to use this mechanism if we want to check for it here. For now a  *)
	 (* delay of 1 will do... *)
	     let params = Client.Task.get_error_info rpc session_id task_id in
		 if params = [] then
			 raise (Api_errors.Server_error(Api_errors.client_error, []))
		 else
			 raise (Api_errors.Server_error(List.hd params, List.tl params));
       end)
    (fun () ->
       (* if we created our own task then destroy it again; if the task was supplied to us then don't destroy it --
	  if clients pass a task in on the command-line then they are responsible for destroying *)
       match use_existing_task with
	 None -> log_exn_continue "destroying task" (fun x -> Client.Task.destroy rpc session_id x) task_id
       | Some _ -> ()
    )


(* Rewrite the provisioning XML fragment to create all disks on a new, specified SR *)
let rewrite_provisioning_xml rpc session_id new_vm sr_uuid = 
  let rewrite_xml xml newsrname =
    let rewrite_disk = function
      | Xml.Element("disk",params,[]) ->
	  Xml.Element("disk",List.map (fun (x,y) -> if x<>"sr" then (x,y) else ("sr",newsrname)) params,[])
      | x -> x
{'fraction_non_alphanumeric': 0.08813953488372094, 'fraction_numerical': 0.0012790697674418604, 'mean_word_length': 3.339556004036327, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 43, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 8}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7449746', 'n_tokens_mistral': 2655, 'n_tokens_neox': 2492, 'n_words': 1035}