<commit_before>(*
 * Copyright (C) 2006 XenSource Inc.
 * Author <NAME> <<EMAIL>>
 *
 * Provide some helpers for XAPI
 *)

open Stringext
open Pervasiveext
open Threadext
open Printf
open Xapi_globs
open Db_filter
open Db_filter_types
open Xmlrpc_sexpr
open Api_errors

include Helper_hostname
include Helper_process

module D=Debug.Debugger(struct let name="helpers" end)
open D

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

let choose_network_name_for_pif device =
  Printf.sprintf "Pool-wide network associated with %s" device

(** Once the server functor has been instantiated, set this reference to the appropriate
    "fake_rpc" (loopback non-HTTP) rpc function. This is used by the CLI, which passes in
    the HTTP request headers it has already received together with its active file descriptor. *)
let rpc_fun : (Http.request -> Unix.file_descr -> Xml.xml -> Xml.xml) option ref = ref None

let get_rpc () =
  match !rpc_fun with 
      None -> failwith "No rpc set!"
    | Some f -> f

(* Given a device-name and a VLAN, figure out what the dom0 device name is that corresponds to this: *)
let get_dom0_network_device_name dev vlan =
  if vlan = -1L then dev else Printf.sprintf "%s.%Ld" dev vlan 

(* !! FIXME - trap proper MISSINGREFERENCE exception when this has been defined *)
(* !! FIXME(2) - this code could be shared with the CLI? *)
let checknull f =
  try f() with
      _ -> "<not in database>"

let get_management_ip_addr () =
  try
    let addrs = Netdev.Addr.get (Xapi_inventory.lookup Xapi_inventory._management_interface) in
    let (addr,netmask) = List.hd addrs in
      Some (Unix.string_of_inet_addr addr)
  with e -> None 

let get_localhost_uuid () =
  Xapi_inventory.lookup Xapi_inventory._installation_uuid

let localhost_ref_m = Mutex.create ()
let localhost_ref = ref Ref.null
  
let get_localhost ~__context : API.ref_host  =
  Mutex.execute localhost_ref_m (fun () -> 
    if !localhost_ref <> Ref.null then
      !localhost_ref
    else
      let me = get_localhost_uuid () in
      let my_ref = Db.Host.get_internal_records_where ~__context ~expr:(Eq (Field "uuid", Literal me)) in
      if List.length my_ref <> 1 then
	failwith (sprintf "Found %d hosts which claim to be localhost" (List.length my_ref));
      let my_ref = fst (List.hd my_ref) in
      localhost_ref := my_ref;
      my_ref)

let make_rpc ~__context xml = 
    let subtask_of = Ref.string_of (Context.get_task_id __context) in
    if Pool_role.is_master () then
      (* Master goes via domain socket *)
      (* !!! FIXME - maybe could make this go direct !!! *)
      Xmlrpcclient.do_xml_rpc_unix ~subtask_of ~version:"1.0" 
	~filename:Xapi_globs.unix_domain_socket ~path:"/" xml
    else
      (* Slave has to go back to master via network *)
      Xmlrpcclient.do_secure_xml_rpc 
	~subtask_of
  ~use_stunnel_cache:true
    ~version:"1.1" ~host:(Pool_role.get_master_address ())
    ~port:!Xapi_globs.https_port ~path:"/" xml 
    (* No auth needed over unix domain socket *)

(** Log into pool master using the client code, call a function
    passing it the rpc function and session id, logout when finished. *)
let call_api_functions ~__context f =
  let rpc = make_rpc ~__context in
  let () = debug "logging into master" in
  (* If we're the master then our existing session may be a client one without 'pool' flag set, so
     we consider making a new one. If we're a slave then our existing session (if we have one) must
     have the 'pool' flag set because it would have been created for us in the message forwarding layer
     in the master, so we just re-use it. [If we haven't got an existing session in our context then
     we always make a new one *)
  let require_explicit_logout = ref false in
  let do_master_login () =
    let session = Client.Client.Session.slave_login rpc (get_localhost ~__context) !Xapi_globs.pool_secret in
      require_explicit_logout := true;
      session 
  in
  let session_id =
      try
        if Pool_role.is_master() then 
      begin
        let session_id = Context.get_session_id __context in
          if Db.Session.get_pool ~__context ~self:session_id 
          then session_id
          else do_master_login ()
      end 
      else Context.get_session_id __context
      with _ -> 
      do_master_login ()
  in
  let () = debug "login done" in
  finally 
    (fun () -> f rpc session_id) 
    (fun () ->
       debug "remote client call finished; logging out";
       if !require_explicit_logout 
      then Client.Client.Session.logout rpc session_id)

let call_emergency_mode_functions hostname f = 
  let rpc xml = Xmlrpcclient.do_secure_xml_rpc ~version:"1.0" ~host:hostname
    ~port:!Xapi_globs.https_port ~path:"/" xml in
  let session_id = Client.Client.Session.slave_local_login rpc !Xapi_globs.pool_secret in
  finally
    (fun () -> f rpc session_id)
    (fun () -> Client.Client.Session.local_logout rpc session_id)

let progress ~__context t =
    for i = 0 to int_of_float (t *. 100.) do
        let v = (float_of_int i /. 100.) /. t in

        TaskHelper.set_progress ~__context v;
        Thread.delay 1.
    done;
    TaskHelper.set_progress ~__context 1.

let get_user ~__context username =
    let uuids = Db.User.get_all ~__context in
    if List.length uuids = 0 then
        failwith "Failed to find any users";
    List.hd uuids (* FIXME! it assumes that there is only one element in the list (root), username is not used*)

(* Expects only 1 control domain per host; just return first in list for now if multiple.. *)
exception No_domain_zero of string
let domain_zero_ref_cache = ref None
let domain_zero_ref_cache_mutex = Mutex.create ()
let get_domain_zero ~__context : API.ref_VM =
  Threadext.Mutex.execute domain_zero_ref_cache_mutex
    (fun () ->
       match !domain_zero_ref_cache with
       Some r -> r
     | None ->
         let me = get_localhost ~__context in
         let me_str = Ref.string_of me in
         let my_dom0 =
           Db.VM.get_internal_records_where ~__context
         ~expr:(And(Eq (Field "resident_on", Literal me_str),
                Eq (Field "is_control_domain", Literal "true"))) in
           match (List.map fst my_dom0) with
         | [] -> raise (No_domain_zero me_str)
         | (x::xs) ->
             domain_zero_ref_cache := Some x;
             x
    )

let get_size_with_suffix s =
    let s, suffix = if String.length s > 0 then (
        let c = s.[String.length s - 1] in
        if List.mem c [ 'G'; 'g'; 'M'; 'm'; 'K'; 'k'; 'B'; 'b' ] then (
            let suffix = match c with
            | 'G' | 'g' -> 30
            | 'M' | 'm' -> 20
            | 'K' | 'k' -> 10
            | 'B' | 'b' -> 0
            | _ -> 10 in
            String.sub s 0 (String.length s - 1), suffix
        ) else<commit_msg>CA-30573: look up host's dom0 VM record by uuid rather than a 'where resident_on=me' query since (i) the uuid from the inventory file is sufficient; and (ii) with the pool.join changes the resident_on field of the new record is NULL.<commit_after>(*
 * Copyright (C) 2006 XenSource Inc.
 * Author <NAME> <<EMAIL>>
 *
 * Provide some helpers for XAPI
 *)

open Stringext
open Pervasiveext
open Threadext
open Printf
open Xapi_globs
open Db_filter
open Db_filter_types
open Xmlrpc_sexpr
open Api_errors

include Helper_hostname
include Helper_process

module D=Debug.Debugger(struct let name="helpers" end)
open D

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

let choose_network_name_for_pif device =
  Printf.sprintf "Pool-wide network associated with %s" device

(** Once the server functor has been instantiated, set this reference to the appropriate
    "fake_rpc" (loopback non-HTTP) rpc function. This is used by the CLI, which passes in
    the HTTP request headers it has already received together with its active file descriptor. *)
let rpc_fun : (Http.request -> Unix.file_descr -> Xml.xml -> Xml.xml) option ref = ref None

let get_rpc () =
  match !rpc_fun with 
      None -> failwith "No rpc set!"
    | Some f -> f

(* Given a device-name and a VLAN, figure out what the dom0 device name is that corresponds to this: *)
let get_dom0_network_device_name dev vlan =
  if vlan = -1L then dev else Printf.sprintf "%s.%Ld" dev vlan 

(* !! FIXME - trap proper MISSINGREFERENCE exception when this has been defined *)
(* !! FIXME(2) - this code could be shared with the CLI? *)
let checknull f =
  try f() with
      _ -> "<not in database>"

let get_management_ip_addr () =
  try
    let addrs = Netdev.Addr.get (Xapi_inventory.lookup Xapi_inventory._management_interface) in
    let (addr,netmask) = List.hd addrs in
      Some (Unix.string_of_inet_addr addr)
  with e -> None 

let get_localhost_uuid () =
  Xapi_inventory.lookup Xapi_inventory._installation_uuid

let localhost_ref_m = Mutex.create ()
let localhost_ref = ref Ref.null
  
let get_localhost ~__context : API.ref_host  =
  Mutex.execute localhost_ref_m (fun () -> 
    if !localhost_ref <> Ref.null then
      !localhost_ref
    else
      let me = get_localhost_uuid () in
      let my_ref = Db.Host.get_internal_records_where ~__context ~expr:(Eq (Field "uuid", Literal me)) in
      if List.length my_ref <> 1 then
	failwith (sprintf "Found %d hosts which claim to be localhost" (List.length my_ref));
      let my_ref = fst (List.hd my_ref) in
      localhost_ref := my_ref;
      my_ref)

let make_rpc ~__context xml = 
    let subtask_of = Ref.string_of (Context.get_task_id __context) in
    if Pool_role.is_master () then
      (* Master goes via domain socket *)
      (* !!! FIXME - maybe could make this go direct !!! *)
      Xmlrpcclient.do_xml_rpc_unix ~subtask_of ~version:"1.0" 
	~filename:Xapi_globs.unix_domain_socket ~path:"/" xml
    else
      (* Slave has to go back to master via network *)
      Xmlrpcclient.do_secure_xml_rpc 
	~subtask_of
  ~use_stunnel_cache:true
    ~version:"1.1" ~host:(Pool_role.get_master_address ())
    ~port:!Xapi_globs.https_port ~path:"/" xml 
    (* No auth needed over unix domain socket *)

(** Log into pool master using the client code, call a function
    passing it the rpc function and session id, logout when finished. *)
let call_api_functions ~__context f =
  let rpc = make_rpc ~__context in
  let () = debug "logging into master" in
  (* If we're the master then our existing session may be a client one without 'pool' flag set, so
     we consider making a new one. If we're a slave then our existing session (if we have one) must
     have the 'pool' flag set because it would have been created for us in the message forwarding layer
     in the master, so we just re-use it. [If we haven't got an existing session in our context then
     we always make a new one *)
  let require_explicit_logout = ref false in
  let do_master_login () =
    let session = Client.Client.Session.slave_login rpc (get_localhost ~__context) !Xapi_globs.pool_secret in
      require_explicit_logout := true;
      session 
  in
  let session_id =
      try
        if Pool_role.is_master() then 
      begin
        let session_id = Context.get_session_id __context in
          if Db.Session.get_pool ~__context ~self:session_id 
          then session_id
          else do_master_login ()
      end 
      else Context.get_session_id __context
      with _ -> 
      do_master_login ()
  in
  let () = debug "login done" in
  finally 
    (fun () -> f rpc session_id) 
    (fun () ->
       debug "remote client call finished; logging out";
       if !require_explicit_logout 
      then Client.Client.Session.logout rpc session_id)

let call_emergency_mode_functions hostname f = 
  let rpc xml = Xmlrpcclient.do_secure_xml_rpc ~version:"1.0" ~host:hostname
    ~port:!Xapi_globs.https_port ~path:"/" xml in
  let session_id = Client.Client.Session.slave_local_login rpc !Xapi_globs.pool_secret in
  finally
    (fun () -> f rpc session_id)
    (fun () -> Client.Client.Session.local_logout rpc session_id)

let progress ~__context t =
    for i = 0 to int_of_float (t *. 100.) do
        let v = (float_of_int i /. 100.) /. t in

        TaskHelper.set_progress ~__context v;
        Thread.delay 1.
    done;
    TaskHelper.set_progress ~__context 1.

let get_user ~__context username =
    let uuids = Db.User.get_all ~__context in
    if List.length uuids = 0 then
        failwith "Failed to find any users";
    List.hd uuids (* FIXME! it assumes that there is only one element in the list (root), username is not used*)

(* Expects only 1 control domain per host; just return first in list for now if multiple.. *)
exception No_domain_zero of string
let domain_zero_ref_cache = ref None
let domain_zero_ref_cache_mutex = Mutex.create ()
let get_domain_zero ~__context : API.ref_VM =
  Threadext.Mutex.execute domain_zero_ref_cache_mutex
    (fun () ->
       match !domain_zero_ref_cache with
       Some r -> r
     | None ->
	 (* Read the control domain uuid from the inventory file *)
	 let uuid = Xapi_inventory.lookup Xapi_inventory._control_domain_uuid in
	 try
	   let vm = Db.VM.get_by_uuid ~__context ~uuid in
	   if not (Db.VM.get_is_control_domain ~__context ~self:vm) then begin
	     error "VM uuid %s is not a control domain but the uuid is in my inventory file" uuid;
	     raise (No_domain_zero uuid);
	   end;
	   domain_zero_ref_cache := Some vm;
	   vm
	 with _ ->
	   error "Failed to find control domain (uuid = %s)" uuid;
	   raise (No_domain_zero uuid)
    )

let get_size_with_suffix s =
    let s, suffix = if String.length s > 0 then (
        let c = s.[String.length s - 1] in
        if List.mem c [ 'G'; 'g'; 'M'; 'm'; 'K'; 'k'; 'B'; 'b' ] then (
            let suffix = match c with
            | 'G' | 'g' -> 30
            | 'M' | 'm' -> 20
            | 'K' | 'k' -> 10
            | 'B' | 'b' -> 0
            | _ -> 10 in
            String.sub s 0 (String.length s - 1), suffix
        ) else
{'fraction_non_alphanumeric': 0.08916058916058917, 'fraction_numerical': 0.006149006149006149, 'mean_word_length': 2.9690692395005676, 'pattern_counts': {'":': 0, '<': 15, '<?xml version=': 0, '>': 64, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 20}, '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': '7352507', 'n_tokens_mistral': 4615, 'n_tokens_neox': 4466, 'n_words': 1575}