(* $Id: webdav_client_ha.ml 9 2015-01-12 20:00:52Z gerd $ *)

open Webdav_client
open Webdav_compat

exception Service_unavailable of string


let configure_pipeline p host ip tmo retry =
  let opts = p # get_options in
  let opts' =
    { opts with
	Http_client.maximum_connection_failures = retry;
	maximum_message_errors = retry;
	connection_timeout = tmo;
	resolver = (fun _esys h p -> 
		      if h=host then
			p (Some ip)
		      else
			opts.Http_client.resolver _esys h p);
    } in
  p # set_options opts';
  ()


let pre_resolve base_urls =
  (* Returns list (base_url, host, ip) for the input list *)
  List.flatten
    (List.map
       (fun u ->
	  try
	    let h =
	      Neturl.url_host
		(Neturl.parse_url
		   ~base_syntax:Neturl.ip_url_syntax
		   ~accept_8bits:true
		   (Neturl.fixup_url_string 
		      u)) in
	    let ip_opt =
	      try Some(Unix.inet_addr_of_string h)
	      with _ -> None in
	    match ip_opt with
	      | Some ip ->
		  [ u, h, ip ]
	      | None ->
		  let he = Unix.gethostbyname h in
		  Array.to_list
		    (Array.map
		       (fun ip -> ( u, h, ip ))
		       he.Unix.h_addr_list
		    )
	  with
	    | _ -> []
       )
       base_urls)


let select_endpoint base_urls tmo =
  let l = pre_resolve base_urls in
  if l=[] then
    raise(Service_unavailable "Hostname resolution error");
  let esys = Unixqueue.create_unix_event_system() in
  let r = List.map (fun _ -> ref None) l in
  let t0 = Unix.gettimeofday() in
  List.iter2
    (fun (u, h, ip) d_opt ->
       let p = new Http_client.pipeline in
       configure_pipeline p h ip tmo 0;
       p # set_event_system esys;
       let m = new Http_client.options u in
       p # add_with_callback
	 m
	 (fun _ ->
	    let t1 = Unix.gettimeofday() in
	    let ok =
	      match m#status with
		| `Successful | `Redirection | `Client_error -> true
		| _ -> false in
	    if ok then
	      d_opt := Some (t1 -. t0)
	 )
    )
    l
    r;
  Unixqueue.run esys;
  let best = ref None in
  List.iter2
    (fun (u, h, ip) d_opt ->
       match !d_opt with
	 | None -> ()
	 | Some d ->
	     ( match !best with
		 | None ->
		     best := Some(u, h, ip, d)
		 | Some (_,_,_,d1) ->
		     if d < 2. *. d1 then
		       best := Some(u, h, ip, d)
	     )
    )
    l
    r;
  match !best with
    | None ->
	raise(Service_unavailable "No endpoint ready for service")
    | Some(u,h,ip,_) ->
	(u, ip)


let webdav_client ?pipeline (url, ip) =
  let wc = new Webdav_client.webdav_client ?pipeline url in
  let h =
    Neturl.url_host
      (Neturl.parse_url
	 ~base_syntax:Neturl.ip_url_syntax
	 ~accept_8bits:true
	 (Neturl.fixup_url_string 
	    url)) in
  configure_pipeline wc#pipeline h ip 300.0 2;
  wc