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

open Webdav_xml
open Webdav_http
open Webdav_compat
open Printf

type call_status =
    [ Http_client.status
    | `Multi_status
    ]

type property = Webdav_xml.property
type prepost_code = Webdav_xml.prepost_code
class type propstat_t = Webdav_xml.propstat_t
class type response_t = Webdav_xml.response_t

class type webdav_call_t =
object
  inherit Http_client.http_call
  method response_webdav_status : webdav_status
  method call_status : call_status
  method multistatus : response_t list
  method query_path : string
  method effective_query_path : string
  method paths : string list
  method good_paths : string list
  method bad_paths : string list
  method fully_successful : bool
  method response_of_path : string -> response_t 
  method responsedescription : string
  method status_report : string
end

class type propfind_call_t = webdav_call_t
class type list_t = webdav_call_t
class type filelist_t = webdav_call_t
class type mkcol_call_t = webdav_call_t
class type get_call_t = webdav_call_t
class type delete_call_t = webdav_call_t
class type put_call_t = webdav_call_t
class type copy_call_t = webdav_call_t
class type move_call_t = webdav_call_t


type propfind_request =
  [ `Prop of property list
  | `Propname
  | `Allprop of property list
  ]


type list_request =
    [ `Existence | `Standard ]

type proppatch_instruction = Webdav_xml.proppatch_instruction
type proppatch_request = Webdav_xml.proppatch_request


let status_of_code code =
  if code >= 200 && code <= 299 then
    `Successful
  else if code >= 300 && code <= 399 then
    `Redirection
  else if code >= 400 && code <= 499 then
    `Client_error
  else
    `Server_error
      
let string_of_call_status (st:call_status) =
  match st with
    | `Unserved ->
	"Unserved"
    | `Http_protocol_error e -> 
	"Http_protocol_error(" ^ Printexc.to_string e ^ ")"
    | `Successful ->
	"Successful"
    | `Redirection ->
	"Redirection"
    | `Client_error ->
	"Client_error"
    | `Server_error ->
	"Server_error"
    | `Multi_status ->
	"Multi_status"

let name_of_prop p =
  p#localname  (* CHECK, maybe we want to know more *)


let allowed_xml_types =
  [ "application/xml"; "text/xml" ]


let rm_trailing_slash p =
  let q = List.rev p in
  match q with
    | [] -> [""]
    | [""] -> [""]
    | "" :: q' -> List.rev q'
    | _ -> p


let url_append base_url path =
  let b = Neturl.parse_url base_url in
  let p1 = Neturl.split_path path in
  if p1=[] || List.hd p1 <> "" then 
    failwith "Webdav_client_method.url_append: path is not absolute";
  let p2 = Neturl.norm_path p1 in
  if List.mem "." p2 || List.mem ".." p2 then
    failwith "Webdav_client_method.url_append: bad use of . or .. in path";
  Neturl.string_of_url
    (Neturl.modify_url
       ~path:(rm_trailing_slash(Neturl.url_path b) @ List.tl p2)
       b)

class virtual webdav_call_mixin =
object(self)
  (* from Http_client.http_call: *)
  method virtual response_status_code : int
  method virtual response_status_text : string
  method virtual response_header : Netmime.mime_header
  method virtual response_body : Netmime.mime_body
  method virtual request_uri : string
  method virtual effective_request_uri : string
  method virtual status : Http_client.status

  val mutable multistatus_lz = lazy (assert false)
  val mutable paths = []
  val mutable good_paths = []
  val mutable bad_paths = []
  val mutable response_tbl = Hashtbl.create 1
  val mutable strip_prefix_p = None

  initializer (
    multistatus_lz <- lazy (self # real_multistatus)
  )

  method response_webdav_status =
    let code = self#response_status_code in
    webdav_status_of_int code

  method call_status =
    match self#status with
      | `Successful ->
	  let code = self#response_status_code in
	  if code = 207 then 
	    `Multi_status
	  else
	    `Successful
      | st ->
	  (st :> call_status)

  method query_path =
    url_path ?strip_prefix:strip_prefix_p self#request_uri

  method effective_query_path =
    url_path ?strip_prefix:strip_prefix_p self#effective_request_uri

  method private response_is_good (r : response_t) =
    (* may be overridden in subclass *)
    let rcode = r#status_code in
    rcode >= 200 && rcode <= 299

  method multistatus =
    match self#response_webdav_status with
      | `Multi_status ->
	  (Lazy.force multistatus_lz) # responses
      | _ -> 
	  []

  method responsedescription =
    match self#response_webdav_status with
      | `Multi_status ->
	  (Lazy.force multistatus_lz) # responsedescription
      | _ -> 
	  ""

  method private real_multistatus =
    let hd = self # response_header in
    let content_type = try hd # field "Content-type" with Not_found -> "" in
    let content_type_dec,_ = get_content_type hd in
    if not (List.mem content_type_dec allowed_xml_types) then
      failwith "WebDAV client error: multistatus response is not XML";
    let ms = 
      Webdav_xml.parse_multistatus_body 
	(* ~namespace_manager:XXX *)
        ?strip_prefix:strip_prefix_p
	~content_type
	(self # response_body # open_value_rd()) in
    let tbl = Hashtbl.create 42 in
    List.iter
      (fun r ->
	 List.iter
	   (fun p -> Hashtbl.replace tbl p r)
	   r#paths
      )
      ms#responses;
    let plist =
      List.sort
	String.compare
	(Hashtbl.fold (fun p _ acc -> p::acc) tbl []) in
    paths <- plist;
    response_tbl <- tbl;
    let good, bad =
      List.partition
	(fun p ->
	   let r = Hashtbl.find tbl p  in
	   self # response_is_good r
	)
	plist in
    good_paths <- good;
    bad_paths <- bad;
    ms

  method paths =
    ignore(self#multistatus);
    paths
    
  method good_paths =
    ignore(self#multistatus);
    good_paths
    
  method bad_paths =
    ignore(self#multistatus);
    bad_paths
    
  method response_of_path p =
    ignore(self#multistatus);
    Hashtbl.find response_tbl p

  method fully_successful =
    match self#call_status with
      | `Successful -> true
      | `Multi_status -> self#bad_paths = []
      | _ -> false

  method status_report =
    let b = Buffer.create 1001 in

    let indent = "    " in

    let add_line url msg =
      bprintf b "%s:\n%s%s\n" url indent msg in

    let base_url = self # effective_request_uri in

    let status_class code =
      if code >= 200 && code <= 299 then
	"Success"
      else if code >= 300 && code <= 399 then
	"Redirection"
      else if code >= 400 && code <= 499 then
	"Client-side error"
      else if code >= 500 && code <= 599 then
	"Server-side error"
      else
	"Unknown type" in

    ( match self#status with
	| `Unserved ->
	    add_line base_url "Unserved"
	| `Http_protocol_error e ->
	    add_line base_url ("Exception " ^ Printexc.to_string e)
	| `Redirection | `Client_error | `Server_error ->
	    add_line base_url 
	      (sprintf "%s (%d %s)" 
		 (status_class self#response_status_code)
		 self#response_status_code self#response_status_text)
	| `Successful ->
	    if self#response_status_code = 207 then (
	      let rlist = self # multistatus in
	      List.iter
		(fun r ->
		   List.iter
		     (fun u -> bprintf b "%s:\n" u)
		     r#href;
		   let plist = r # propstat in
		   if plist = [] then
		     bprintf b "%s%s (%d %s)\n"
		       indent (status_class r#status_code)
		       r#status_code r#status_text
		   else (
		     (* Sort props by status_code *)
		     let props_of_code = Hashtbl.create 42 in
		     let text_of_code = Hashtbl.create 42 in
		     List.iter
		       (fun p ->
			  let code = p#status_code in
			  let text = p#status_text in
			  let old_props = 
			    try Hashtbl.find props_of_code code
			    with Not_found -> [] in
			  let new_props =
			    List.map name_of_prop p#properties in
			  Hashtbl.replace 
			    props_of_code code (new_props @ old_props);
			  Hashtbl.replace 
			    text_of_code code text
		       )
		       plist;
		     let codes =
		       Hashtbl.fold (fun k v acc -> k :: acc) props_of_code [] in
		     let codes' =
		       List.sort Pervasives.compare codes in
		     List.iter
		       (fun code ->
			  let props = Hashtbl.find props_of_code code in
			  bprintf b "%s%s properties (%d %s)\n"
			    indent (status_class code) code
			    (Hashtbl.find text_of_code code);
			  List.iter
			    (fun prop ->
			       bprintf b "%s%s%s\n" indent indent prop
			    )
			    props
		       )
		       codes'
		   )
		)
		rlist
	    )
	    else
	      add_line base_url 
		(sprintf "Success (%d %s)" 
		   self#response_status_code self#response_status_text)
    );
    Buffer.contents b
end



let propname_creationdate = 
  Webdav_xml.propname_creationdate
let propname_displayname = 
  Webdav_xml.propname_displayname
let propname_getcontentlanguage =
  Webdav_xml.propname_getcontentlanguage
let propname_getcontentlength = 
  Webdav_xml.propname_getcontentlength
let propname_getcontenttype = 
  Webdav_xml.propname_getcontenttype
let propname_getetag = 
  Webdav_xml.propname_getetag
let propname_getlastmodified = 
  Webdav_xml.propname_getlastmodified
let propname_resourcetype = 
  Webdav_xml.propname_resourcetype


class propfind_call =
object(self)
  inherit Http_client.generic_call
  inherit webdav_call_mixin
  method private fixup_request() = ()
  method private def_request_method = "PROPFIND"
  method private def_is_idempotent = true
  method private def_has_req_body = true
  method private def_has_resp_body = true
  method private def_empty_path_replacement = "/"

end


class propfind ?depth ?propfind_request ?strip_prefix url =
object(self)
  inherit propfind_call

  val mutable ref_body = (new Netmime.memory_mime_body "", 0)

  initializer (
    self # set_request_uri url;
    ( match depth with
	| None -> ()
	| Some d ->
	    Header.set_depth
	      (self # request_header `Base)
	      d
    );
    let b = Buffer.create 507 in
    ( match propfind_request with
	| None -> ()
	| Some req ->
	    let ch = new Netchannels.output_buffer b in
	    Webdav_xml.write_propfind_request ch req;
	    ch # close_out();
    );
    let s = Buffer.contents b in
    let body = ro_mime_body s in
    self # set_request_body body;
    ref_body <- (body, String.length s);
    strip_prefix_p <- strip_prefix;
  )

  method private fixup_request() =
    let (p_body, p_len) = ref_body in
    let body = self # request_body in
    if body == p_body then (
      (* Set the length only when we are sure the user did not mess with
         the body
       *)
      Nethttp.Header.set_content_length
	(self # request_header `Effective)
	(Int64.of_int p_len)
    )

  method private response_is_good (r : response_t) =
    let plist = r#propstat in
    List.for_all
      (fun p ->
	 let pcode = p # status_code in
	 pcode >= 200 && pcode <= 299
      )
      plist

end


class filelist ?depth ?strip_prefix (lreq : list_request) url =
  let propfind_request =
    match lreq with
      | `Existence ->
	  `Prop [ propname_resourcetype ]
      | `Standard ->
	  `Allprop [] in
object(self)
  inherit propfind ?depth ~propfind_request ?strip_prefix url

  method private response_is_good (r : response_t) =
    r # prop_resourcetype_is_collection <> None
end


class type proppatch_call_t = webdav_call_t

class proppatch_call =
object(self)
  inherit Http_client.generic_call
  inherit webdav_call_mixin
  method private fixup_request() = ()
  method private def_request_method = "PROPPATCH"
  method private def_is_idempotent = true
  method private def_has_req_body = true
  method private def_has_resp_body = true
  method private def_empty_path_replacement = "/"
end


class proppatch ?strip_prefix ~proppatch_request url =
object(self)
  inherit proppatch_call

  val mutable ref_body = (new Netmime.memory_mime_body "", 0)

  initializer (
    self # set_request_uri url;
    let b = Buffer.create 507 in
    let ch = new Netchannels.output_buffer b in
    Webdav_xml.write_proppatch_request ch proppatch_request;
    ch # close_out();
    let s = Buffer.contents b in
    let body = ro_mime_body s in
    self # set_request_body body;
    ref_body <- (body, String.length s);
    strip_prefix_p <- strip_prefix;
  )

  method private fixup_request() =
    let (p_body, p_len) = ref_body in
    let body = self # request_body in
    if body == p_body then (
      (* Set the length only when we are sure the user did not mess with
         the body
       *)
      Nethttp.Header.set_content_length
	(self # request_header `Effective)
	(Int64.of_int p_len)
    )

  method private response_is_good (r : response_t) =
    let plist = r#propstat in
    List.for_all
      (fun p ->
	 let pcode = p # status_code in
	 pcode >= 200 && pcode <= 299
      )
      plist
end


class mkcol_call =
object(self)
  inherit Http_client.generic_call
  inherit webdav_call_mixin
  method private fixup_request() = ()
  method private def_request_method = "MKCOL"
  method private def_is_idempotent = true
  method private def_has_req_body = true   (* it may have *)
  method private def_has_resp_body = true
  method private def_empty_path_replacement = "/"
end


class mkcol ?strip_prefix url =
object(self)
  inherit mkcol_call

  initializer
    self # set_request_uri url;
    strip_prefix_p <- strip_prefix

end

class get_call =
object(self)
  inherit Http_client.get_call
  inherit webdav_call_mixin
end


class get ?strip_prefix url =
object(self)
  inherit get_call
  initializer
    self # set_request_uri url;
    strip_prefix_p <- strip_prefix;
end


class delete_call =
object(self)
  inherit Http_client.generic_call
  inherit webdav_call_mixin
  method private fixup_request() = ()
  method private def_request_method = "DELETE"
  method private def_is_idempotent = true
  method private def_has_req_body = true   (* it may have in WebDAV ctx *)
  method private def_has_resp_body = true
  method private def_empty_path_replacement = "/"
end


class delete ?strip_prefix url =
object(self)
  inherit delete_call
  initializer
    self # set_request_uri url;
    strip_prefix_p <- strip_prefix;
end


class put_call =
object(self)
  inherit Http_client.generic_call
  inherit webdav_call_mixin
  method private fixup_request() = ()
  method private def_request_method = "PUT"
  method private def_is_idempotent = true
  method private def_has_req_body = true
  method private def_has_resp_body = true
  method private def_empty_path_replacement = "/"
end


class put ?content_type ?content_length ?(expect_handshake=false) ?strip_prefix
          url body =
object(self)
  inherit put_call
  initializer
    self # set_request_uri url;
    self # set_request_body body;
    ( match content_type with
	| None -> ()
	| Some ct ->
	    (self # request_header `Base) # update_field "Content-type" ct
    );
    ( match content_length with
	| None -> ()
	| Some n ->
	    (self # request_header `Base) # update_field "Content-length"
	      (Int64.to_string n)
    );
    if expect_handshake then
      (self # request_header `Base) # update_field "Expect" "100-continue";
    strip_prefix_p <- strip_prefix;

end


class copy_call =
object(self)
  inherit Http_client.generic_call
  inherit webdav_call_mixin
  method private fixup_request() = ()
  method private def_request_method = "COPY"
  method private def_is_idempotent = true
  method private def_has_req_body = true
  method private def_has_resp_body = true
  method private def_empty_path_replacement = "/"
end


class copy ?depth ?overwrite ?strip_prefix src_url dest_url =
object(self)
  inherit copy_call

  initializer
    self # set_request_uri src_url;
    let hdr = self # request_header `Base in
    Header.set_destination hdr dest_url;
    ( match depth with
	| None -> ()
	| Some d -> Header.set_depth hdr d
    );
    ( match overwrite with
	| None -> ()
	| Some b -> Header.set_overwrite hdr b
    );
    strip_prefix_p <- strip_prefix;
end


class move_call =
object(self)
  inherit Http_client.generic_call
  inherit webdav_call_mixin
  method private fixup_request() = ()
  method private def_request_method = "MOVE"
  method private def_is_idempotent = true
  method private def_has_req_body = true
  method private def_has_resp_body = true
  method private def_empty_path_replacement = "/"
end


class move ?overwrite ?strip_prefix src_url dest_url =
object(self)
  inherit move_call

  initializer
    self # set_request_uri src_url;
    let hdr = self # request_header `Base in
    Header.set_destination hdr dest_url;
    ( match overwrite with
	| None -> ()
	| Some b -> Header.set_overwrite hdr b
    );
    strip_prefix_p <- strip_prefix;
end


class list = filelist