(* $Id: webdav_xml.ml 1 2011-08-26 21:00:39Z gerd $ *)

open Webdav_http
open Pxp_document

type property =
    'node Pxp_document.extension Pxp_document.node as 'node

type prepost_code =
    'node Pxp_document.extension Pxp_document.node as 'node

type known_prepost_code =
    [ `No_external_entities 
    | `Preserved_live_properties
    | `Propfind_finite_depth
    | `Cannot_modify_protected_property
    ]

class type propstat_t =
object
  method properties : property list
  method status : webdav_status
  method status_code : int
  method status_text : string
  method status_protocol : string
  method error : prepost_code list
  method responsedescription : string
end


class type response_t =
object
  method href : string list
  method paths : string list
  method status : webdav_status
  method status_code : int
  method status_text : string
  method status_protocol : string
  method propstat : propstat_t list
  method prop_creationdate : float option
  method prop_displayname : string option
  method prop_getcontentlanguage : string option
  method prop_getcontentlength : int64 option
  method prop_getcontenttype : string option
  method prop_getcontenttype_decoded : (string * (string * string) list) option
  method prop_getetag : string option
  method prop_getetag_decoded : Nethttp.etag option
  method prop_getlastmodified : float option
  method prop_resourcetype_is_collection : bool option
  method find_prop : string -> property * propstat_t
  method error : prepost_code list
  method responsedescription : string
  method location : string option
end


class type multistatus_t =
object
  method responses : response_t list
  method responsedescription : string
end


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

type proppatch_instruction =
    [ `Remove of property list
    | `Set of property list
    ]

type proppatch_request =
    proppatch_instruction list


let spec = Pxp_tree_parser.default_namespace_spec


let namespace_manager() =
  let m = Pxp_dtd.create_namespace_manager() in
  m # add_namespace "DAV" "DAV:";
  m


let check_dtd (dtd : Pxp_dtd.dtd) =
  if dtd#encoding <> `Enc_utf8 then
    failwith "Webdav_xml.check_dtd: The character encoding must be UTF-8";

  if not dtd#arbitrary_allowed then
    failwith "Webdav_xml.check_dtd: DTD is not compatible with well-formedness mode";

  if dtd#element_names <> [] then
    failwith "Webdav_xml.check_dtd: Element declarations not allowed";

  if dtd#notation_names <> [] then
    failwith "Webdav_xml.check_dtd: Notation declarations not allowed";

  List.iter
    (fun name ->
       let (ent,_) = dtd#gen_entity name in
       if Pxp_dtd.Entity.get_type ent <> `Internal then
	 failwith "Webdav_xml.check_dtd: Only internal entities are allowed"
    )
    dtd#gen_entity_names;
  List.iter
    (fun name ->
       let ent = dtd#par_entity name in
       if Pxp_dtd.Entity.get_type ent <> `Internal then
	 failwith "Webdav_xml.check_dtd: Only internal entities are allowed"
    )
    dtd#par_entity_names;

  let m = dtd # namespace_manager in

  ( try
      let u = m # get_uri_list "DAV" in
      if u <> ["DAV:"] then raise Not_found;
      let p = m # get_normprefix "DAV:" in
      if p <> "DAV" then raise Not_found
    with
      | _ ->
	  failwith "Webdav_xml.check_dtd: Bad namespace declaration for DAV"
  );

  ()


let dtd() =
  let dtd = Pxp_dtd.create_dtd `Enc_utf8 in
  dtd # allow_arbitrary;
  dtd # set_namespace_manager (namespace_manager());
  dtd


let rec strip_prefix_path1 prefix path =
  match (prefix,path) with
    | [], path ->
	path
    | [""], [] ->
	[]
    | (p0::prefix'), (p1::path') ->
	if p0=p1 then
	  strip_prefix_path1 prefix' path'
	else
	  if p0="" then
	    path
	  else
	    failwith "Webdav_xml: found URL outside the configured prefix"
    | _, [] ->
	failwith "Webdav_xml: found URL outside the configured prefix"


let strip_prefix_path prefix path =
  match prefix with
    | [] -> path
    | "" :: _ -> "" :: strip_prefix_path1 prefix path
    | _ -> failwith "Webdav_xml: bad prefix"
	

let url_path ?strip_prefix u =
  let up =
    Neturl.url_path 
      (Neturl.parse_url
	 ~base_syntax:Neturl.ip_url_syntax
	 ~accept_8bits:true
	 (Neturl.fixup_url_string 
	    u)) in
  let up' =
    match strip_prefix with
      | None -> up
      | Some prefix ->
	  let q = Neturl.split_path prefix in
	  strip_prefix_path q up in
  let p =
    Neturl.join_path up' in
  Netconversion.verify `Enc_utf8 p;
  p



let date_time_re =
  Netstring_pcre.regexp
    "(\\d\\d\\d\\d)-(\\d\\d)-(\\d\\d)[Tt ](\\d\\d):(\\d\\d):(\\d\\d)(\\.\\d+)?([Zz]|[-+](\\d\\d):(\\d\\d))"


let parse_date_time s =
  (* RFC 3339, date-time *)
  (* TODO: better checks on valid values *)
  match Netstring_pcre.string_match date_time_re s 0 with
    | None ->
        failwith "Bad date-time"
    | Some m ->
        let year_s = Netstring_pcre.matched_group m 1 s in
        let month_s = Netstring_pcre.matched_group m 2 s in
        let mday_s = Netstring_pcre.matched_group m 3 s in
        let hour_s = Netstring_pcre.matched_group m 4 s in
        let min_s = Netstring_pcre.matched_group m 5 s in
        let sec_s = Netstring_pcre.matched_group m 6 s in
        let frac_s = 
	  try Netstring_pcre.matched_group m 7 s with Not_found -> "" in
        let tz_s = Netstring_pcre.matched_group m 8 s in
	let tz_hour_s = 
	  try Netstring_pcre.matched_group m 9 s with Not_found -> "0" in
	let tz_min_s = 
	  try Netstring_pcre.matched_group m 10 s with Not_found -> "0" in

	let tz_hour = int_of_string tz_hour_s in
	let tz_min = int_of_string tz_min_s in
	let offs =
	  if tz_s = "Z" then
	    0.0
	  else
	    float(if tz_s.[0] = '+' then
		    tz_hour * 3600 + tz_min * 60
		  else
		    - (tz_hour * 3600 + tz_min * 60)) in

	let year = int_of_string year_s in
	let month = int_of_string month_s in
	let mday = int_of_string mday_s in
	let hour = int_of_string hour_s in
	let min = int_of_string min_s in
	let sec = int_of_string sec_s in
	let frac = if frac_s <> "" then float_of_string frac_s else 0.0 in
	
	let tm =
	  { Unix.tm_year = year - 1900;
	    tm_mon = month - 1;
	    tm_mday = mday;
	    tm_hour = hour;
	    tm_min = min;
	    tm_sec = sec;
	    tm_wday = 0;
	    tm_yday = 0;
	    tm_isdst = false 
	  } in

	(* Little bug: the time offset could change between localtime and
           mktime calls
	 *)
	let t_local, _ = Unix.mktime tm in   (* assumes local time zone *)
	
	let tm_ref = Unix.localtime 0.0 in
	let local_offs = 
	  if tm_ref.Unix.tm_year = 70 then
	    float(tm_ref.Unix.tm_hour * 3600 + tm_ref.Unix.tm_min * 60)
	  else (* 69 *)
	    float(-86400 + tm_ref.Unix.tm_hour * 3600 + tm_ref.Unix.tm_min * 60) in

	let t_utc = t_local +. local_offs in  (* as if we had Z *)
	let t = t_utc -. offs in
	t +. frac


let scan_pcdata node =
  (* Checks that there are no subelements except data *)
  List.iter
    (fun n ->
       if n # node_type <> T_data then
	 failwith "Element nodes found where only data is expected"
    )
    node#sub_nodes;
  node#data


let scan_subelements node f =
  (* Skip over whitespace, and call for every element f *)
  node # iter_nodes
    (fun sub_node ->
       match sub_node # node_type with
	 | T_element _ ->
	     f sub_node
	 | T_data ->
	     if not (Pxp_lib.only_whitespace sub_node#data) then
	       failwith "Character data found at unexpected position in XML"
	 | _ ->
	     failwith "Bad XML node type found"
    )


class write_pinstr_impl node_of_id =
object(self)
  inherit [_] Pxp_document.pinstr_impl Pxp_tree_parser.default_extension

  method display ?prefixes ?minimization out enc =
    (* Instead of printing the processing instruction, look up the
       property, and print the property name
     *)
    let deep =
      self # node_type = T_pinstr "deepnode" in
    let oo_id = int_of_string self#data in
    let node = 
      try node_of_id oo_id with Not_found -> assert false in
    if deep || node # sub_nodes = [] then 
      node # display ?prefixes ?minimization out enc
    else (
      (* There is no non-recursive version of display *)
      let node' = node # orphaned_flat_clone in
      node' # display ?prefixes ?minimization out enc
    )
end


let write
      ?(namespace_manager = namespace_manager())
      ch get_tree =
  (* How the properties are inserted into the printed text: The properties
     can use their own dtd objects and their own namespace managers.
     Because of this, it is impossible to insert the properties into
     the XML tree representing the PROPFIND request. Instead, we use a
     trick. The spots where properties have to be printed are marked
     in the tree with processing instructions, e.g.

     <D:propfind xmlns:D="DAV:">
       <D:allprop/>
       <D:include>
         <? node 1?>   <!-- <D:supported-live-property-set/> -->
         <? node 2?>   <!-- <D:supported-report-set/> -->
       </D:include>
     </D:propfind>
   *)
  (* The tree is obtained by running
     
     [ let tree = get_tree dtd scope nodes ]

     where [nodes] is the hash table mapping node ID's to nodes
     (for property and pre/postcondition codes).
   *)

  let nodes = (Hashtbl.create 10 : (int, property) Hashtbl.t) in
  let dtd = dtd() in
  let mng = dtd#namespace_manager in
  let scope = 
    Pxp_dtd.create_namespace_scope 
      ~decl:mng#as_declaration mng in
  let tree = get_tree dtd scope nodes in

  let node_of_id id =
    try Hashtbl.find nodes id
    with Not_found -> assert false in
  
  (* Now relocate the tree so the following spec is used *)

  let ext = Pxp_tree_parser.default_extension in
  let write_spec = 
    (* Create a new spec so the above class is used for representing
       processing instructions. The display method is redefined there.
     *)
    Pxp_document.make_spec_from_alist
      ~default_pinstr_exemplar:(new write_pinstr_impl node_of_id)
      ~data_exemplar:(new Pxp_document.data_impl ext)
      ~default_element_exemplar:(new Pxp_document.namespace_element_impl ext)
      ~element_alist:[] 
      () in
  
  let tree' =
    Pxp_marshal.relocate_subtree tree dtd write_spec in
  let doc = 
    new Pxp_document.document 
      (new Pxp_types.drop_warnings)
      `Enc_utf8 in
  let out = `Out_netchannel ch in
  doc # init_root tree' "";
  doc # display ~dtd_style:`Omit ~minimization:`AllEmpty out `Enc_utf8


let create_propstat
      ~properties ~status
      ?(status_code = int_of_webdav_status status)
      ?(status_text = string_of_webdav_status status)
      ?(status_protocol = webdav_proto)
      ?(error = [])
      ?(responsedescription = "") () : propstat_t =
  ( object
      method properties = properties
      method status = status
      method status_code = status_code
      method status_text = status_text
      method status_protocol = status_protocol
      method error = error
      method responsedescription = responsedescription
    end
  )


let decode_string p =
  scan_pcdata p
    
let decode_creationdate p =
  parse_date_time (scan_pcdata p)

let decode_displayname p =
  decode_string p

let decode_getcontentlanguage p =
  scan_pcdata p

let decode_getcontentlength p =
  Int64.of_string(scan_pcdata p)

let decode_getcontenttype p =
  let s = scan_pcdata p in
  let t, params = 
    try Mimestring.scan_mime_type s []
    with _ -> 
      failwith "Cannot parse getcontenttype property" in
  (t,params)

let decode_getetag p =
  let s = scan_pcdata p in
  (* etag parser isn't exported by Nethttp - work around: *)
  let h =
    new Netmime.basic_mime_header [ "etag", s ] in
  Nethttp.Header.get_etag h

let decode_getlastmodified p =
  Netdate.since_epoch  (* RFC 1123 date! *)
    (Netdate.parse (scan_pcdata p))

let decode_resourcetype p =
  let is_collection = ref false in
  scan_subelements p
    (fun n ->
       match n # node_type with
	 | T_element "DAV:collection" -> is_collection := true
	 | _ -> ()
    );
  !is_collection



class response href strip_prefix status status_code status_text status_proto 
               propstat error responsedescription location : response_t =
  let flattened_props =
    lazy (
      List.flatten
	(List.map
	   (fun ps ->
	      List.map (fun p -> (p, ps)) ps#properties
	   )
	   propstat)) in
  let ok_props =
    lazy(
      List.map
	fst
	(List.filter
	   (fun (p,ps) -> ps#status_code >= 200 && ps#status_code < 300)
	   (Lazy.force flattened_props)
	)
    ) in
  let find_prop name =
    List.find 
      (fun p -> 
	 match p#node_type with
	   | T_element n -> n=name
	   | _ -> false
      )
      (Lazy.force ok_props) in
  let prop_creationdate = lazy (
    try Some(decode_creationdate (find_prop "DAV:creationdate"))
    with Not_found -> None
  ) in
  let prop_displayname = lazy (
    try Some(decode_displayname(find_prop "DAV:displayname"))
    with Not_found -> None
  ) in
  let prop_getcontentlanguage = lazy (
    try Some(decode_getcontentlanguage(find_prop "DAV:getcontentlanguage"))
    with Not_found -> None
  ) in
  let prop_getcontentlength = lazy (
    try Some(decode_getcontentlength(find_prop "DAV:getcontentlength"))
    with Not_found -> None
  ) in
  let prop_getcontenttype = lazy (
    try Some(scan_pcdata(find_prop "DAV:getcontenttype"))
    with Not_found -> None
  ) in
  let prop_getcontenttype_decoded = lazy (
    try Some(decode_getcontenttype(find_prop "DAV:getcontenttype"))
    with Not_found -> None
  ) in
  let prop_getetag = lazy (
    try Some(scan_pcdata(find_prop "DAV:getetag"))
    with Not_found -> None
  ) in
  let prop_getetag_decoded = lazy (
    try Some(decode_getetag(find_prop "DAV:getetag"))
    with Not_found -> None
  ) in
  let prop_getlastmodified = lazy (
    try Some(decode_getlastmodified(find_prop "DAV:getlastmodified"))
    with Not_found -> None
  ) in
  let prop_resourcetype_is_collection = lazy (
    try Some(decode_resourcetype(find_prop "DAV:resourcetype"))
    with Not_found -> None
  ) in
  let paths =
    List.map (url_path ?strip_prefix) href in

object (self)
  method href = href
  method paths = paths
  method status = status
  method status_code = status_code
  method status_text = status_text
  method status_protocol = status_proto
  method propstat = propstat
  method error = error
  method responsedescription = responsedescription
  method location = location

  method prop_creationdate = Lazy.force prop_creationdate
  method prop_displayname = Lazy.force prop_displayname
  method prop_getcontentlanguage = Lazy.force prop_getcontentlanguage
  method prop_getcontentlength = Lazy.force prop_getcontentlength
  method prop_getcontenttype = Lazy.force prop_getcontenttype
  method prop_getcontenttype_decoded = Lazy.force prop_getcontenttype_decoded
  method prop_getetag = Lazy.force prop_getetag
  method prop_getetag_decoded = Lazy.force prop_getetag_decoded
  method prop_getlastmodified = Lazy.force prop_getlastmodified
  method prop_resourcetype_is_collection = 
    Lazy.force prop_resourcetype_is_collection

  method find_prop name =
    List.find
      (fun (p,ps) ->
	 match p#node_type with
	   | T_element n -> n=name
	   | _ -> false
      )
      (Lazy.force flattened_props)

end


let create_status_response 
      ~href ~status
      ?(status_code = int_of_webdav_status status)
      ?(status_text = string_of_webdav_status status)
      ?(status_protocol = webdav_proto)
      ?(error = [])
      ?(responsedescription = "")
      ?location
      ?strip_prefix
      () =
  if href = [] then
    invalid_arg "Webdav_xml.create_status_response: href must not be empty";
  new response
    href strip_prefix status status_code status_text status_protocol
    [] error responsedescription location


let create_propstat_response 
      ~href ~propstat
      ?(error = [])
      ?(responsedescription = "")
      ?location
      ?strip_prefix
      () =
  if (propstat : propstat_t list) = [] then
    invalid_arg
      "Webdav_xml.create_propstat_response: propstat must not be empty";
  new response
    [href] strip_prefix `Ok 200 "OK" webdav_proto 
    propstat error responsedescription location


let create_multistatus ~responses ?(responsedescription = "") () =
  ( object
      method responses = responses
      method responsedescription = responsedescription
    end
  )


let create_prop ?(namespace_manager = namespace_manager()) f =
  let dtd = Pxp_dtd.create_dtd `Enc_utf8 in
  dtd # allow_arbitrary;
  dtd # set_namespace_manager namespace_manager;
  f dtd

let create_propname ?(namespace_manager = namespace_manager()) name =
  create_prop ~namespace_manager 
    (fun dtd ->
       <:pxp_tree<
         <:autoscope>
           <(name)/>
       >>
    ) ;;

let propname_creationdate = 
  create_propname "DAV:creationdate"
let propname_displayname = 
  create_propname "DAV:displayname"
let propname_getcontentlanguage =
  create_propname "DAV:getcontentlanguage"
let propname_getcontentlength = 
  create_propname "DAV:getcontentlength"
let propname_getcontenttype = 
  create_propname "DAV:getcontenttype"
let propname_getetag = 
  create_propname "DAV:getetag"
let propname_getlastmodified = 
  create_propname "DAV:getlastmodified"
let propname_resourcetype = 
  create_propname "DAV:resourcetype"


let encode_string name s =
  create_prop
    (fun dtd ->
       <:pxp_tree<
         <:autoscope>
           <(name)> <*> s
       >>
    )
    
let encode_creationdate t =
  let s = Netdate.mk_internet_date ~zone:Netdate.localzone t in
  encode_string "DAV:creationdate" s

let encode_displayname s =
  encode_string "DAV:displayname" s

let encode_getcontentlanguage s =
  encode_string "DAV:getcontentlanguage" s

let encode_getcontentlength n = 
  encode_string "DAV:getcontentlength" (Int64.to_string n)

let encode_getcontenttype ct = 
  let h = new Netmime.basic_mime_header [] in
  Nethttp.Header.set_content_type h ct;
  let s = h # field "Content-Type" in
  encode_string "DAV:getcontenttype" s

let encode_getetag t = 
  let h = new Netmime.basic_mime_header [] in
  Nethttp.Header.set_etag h t;
  let s = h # field "Etag" in
  encode_string "DAV:getetag" s

let encode_getlastmodified t = 
  let s = Netdate.mk_mail_date ~zone:Netdate.localzone t in
  encode_string "DAV:getlastmodified" s

let encode_resourcetype b =
  if b then
    create_prop
      (fun dtd ->
	 <:pxp_tree<
           <:autoscope>
             <DAV:resourcetype> <DAV:collection/>
	 >>
      )
  else
    create_propname "DAV:resourcetype"


let create_prepost_code = create_propname


let parse_prepost_code node =
  match node#node_type with
    | T_element "DAV:no-external-entities" -> 
	`No_external_entities
    | T_element "DAV:preserved-live-properties" ->
	`Preserved_live_properties
    | T_element "DAV:propfind-finite-depth" ->
	`Propfind_finite_depth
    | T_element "DAV:cannot-modify-protected-property" ->
	`Cannot_modify_protected_property
    | T_element other ->
	raise Not_found
    | _ ->
	failwith "Webdav_xml.parse_prepost_code: not an element"


let emit_prepost_code code =
  let name =
    match code with
      | `No_external_entities ->
	  "DAV:no-external-entities"
      | `Preserved_live_properties ->
	  "DAV:preserved-live-properties"
      | `Propfind_finite_depth ->
	  "DAV:propfind-finite-depth"
      | `Cannot_modify_protected_property ->
	  "DAV:cannot-modify-protected-property" in
  create_prepost_code name


(* In the following, we analyze the XML tree. Unknown XML elements
   are skipped. The order of sub elements is not enforced.
 *)

let status_re = 
  Netstring_pcre.regexp
    "^[ \t\r\n]*([^ \t]+)[ \t]+([0-9][0-9][0-9])([ \t]+([^\r\n]*))[ \t\r\n]*$"

let scan_status s =
  match Netstring_pcre.string_match status_re s 0 with
    | None ->
        failwith "Bad status line"
    | Some m ->
        let proto = Netstring_pcre.matched_group m 1 s in
        let code_str = Netstring_pcre.matched_group m 2 s in
        let code = int_of_string code_str in
        let text =
          try Netstring_pcre.matched_group m 4 s 
          with Not_found -> "" in
        if code < 100 || code > 599 then 
          failwith "Bad status code";
	(proto, code, text)


let parse_responsedescription root =
  scan_pcdata root


let emit_responsedescription dtd scope d =
  <:pxp_tree<
    <:scope>
      <DAV:responsedescription> <*> d
  >>


let parse_href root = 
  (* TODO: check that the URL is ok (only ASCII, and satisfies the 
     production rules)
   *)
  scan_pcdata root


let emit_href dtd scope href =
  <:pxp_tree<
    <:scope>
      <DAV:href> <*> href
  >>


let parse_location root =
  let href_opt = ref None in
  scan_subelements root
    (fun node ->
       match node # node_type with
	 | T_element "DAV:href" ->
	     if !href_opt <> None then
	       failwith "XML structure: double href";
	     let href = parse_href node in
	     href_opt := Some href
	 | _ -> ()
    );
  match !href_opt with
    | None ->
	failwith "XML structure: missing href"
    | Some href ->
	href


let emit_location dtd scope href =
  let href_node = emit_href dtd scope href in
  <:pxp_tree<
    <:scope>
      <DAV:location> [ href_node ]
  >>
  


let parse_prop root =
  (* <!ELEMENT prop ANY > *)
  (* The children elements are the properties *)
  let plist = ref [] in
  scan_subelements root
    (fun node ->
       plist := node :: !plist
    );
  List.rev !plist


let emit_prop dtd scope nodes ~deep props =
  (* deep=true: the property is emitted with contents;
     deep=false: the property is emitted without contents (name only)
   *)
  let pi_list =
    List.map
      (fun p ->
	 let oo_id = string_of_int (Oo.id p) in
	 Hashtbl.replace nodes (Oo.id p) p;
	 if deep then
	   <:pxp_tree<  <?> "deepnode" oo_id >>
	 else
	   <:pxp_tree<  <?> "flatnode" oo_id >>
      )
      props in
  <:pxp_tree<
    <:scope>
      <DAV:prop> pi_list
  >> ;;


let parse_include root =
  let plist = ref [] in
  scan_subelements root
    (fun node ->
       plist := node :: !plist
    );
  List.rev !plist
  


let emit_include dtd scope nodes props =
  let pi_list =
    List.map
      (fun p ->
	 let oo_id = string_of_int (Oo.id p) in
	 Hashtbl.replace nodes (Oo.id p) p;
	 <:pxp_tree<  <?> "flatnode" oo_id >>
      )
      props in
  <:pxp_tree<
    <:scope>
      <DAV:include> pi_list
  >> ;;


let parse_status node =
   scan_status (scan_pcdata node)


let emit_status dtd scope (proto, code, text) =
   let line =
     Printf.sprintf "%s %d %s" proto code text in
   <:pxp_tree<
     <:scope>
       <DAV:status> <*> line
   >>;;


let parse_error node =
   let l = ref [] in
   scan_subelements node 
     (fun sn ->
	try
	  match sn#node_type with
	    | T_element _ ->
		l := sn :: !l
	    | _ -> ()
	with
	  | Not_found -> ()
     );
   List.rev !l


let emit_error dtd scope nodes codes =
  let pi_list =
    List.map
      (fun p ->
	 let oo_id = string_of_int (Oo.id p) in
	 Hashtbl.replace nodes (Oo.id p) p;
	 <:pxp_tree<  <?> "deepnode" oo_id >>
      )
      codes in
  <:pxp_tree<
    <:scope>
      <DAV:error> pi_list
  >> ;;



let parse_propstat root =
  (* <!ELEMENT propstat (prop, status, error?, responsedescription?) > *)
  let prop = ref None in
  let status_code = ref 200 in
  let status_text = ref "OK" in
  let status_protocol = ref "HTTP/1.1 200 OK" in
  let status_seen = ref false in
  let responsedescription = ref None in
  let error = ref None in
  scan_subelements root
    (fun node ->
       match node # node_type with
	 | T_element "DAV:prop" ->
	     if !prop <> None then
	       failwith "XML structure: Double prop";
	     let p = parse_prop node in
	     prop := Some p
	 | T_element "DAV:status" ->
	     if !status_seen then
	       failwith "XML structure: Double status";
	     let (proto, code, text) = parse_status node in
	     status_protocol := proto;
	     status_code := code;
	     status_text := text;
	     status_seen := true
	 | T_element "DAV:responsedescription" ->
	     let d = parse_responsedescription node in
	     if !responsedescription <> None then
	       failwith "XML structure: double responsedescription";
	     responsedescription := Some d
	 | T_element "DAV:error" ->
	     let l = parse_error node in
	     if !error <> None then
	       failwith "XML structure: double error";
	     error := Some l
	 | _ ->
	     ()
    );
  let p =
    match !prop with
      | None -> failwith "XML structure: Missing prop"
      | Some p -> p in
  if not !status_seen then
    failwith "XML structure: Missing status";
  let status = webdav_status_of_int !status_code in
  
  ( object
      method properties = p
      method status = status
      method status_code = !status_code
      method status_text = !status_text
      method status_protocol = !status_protocol
      method responsedescription = 
	match !responsedescription with None -> "" | Some s -> s
      method error =
	match !error with None -> [] | Some l -> l
    end : propstat_t
  )


let prefer ~default p v =
  if p v then v else default


let emit_propstat dtd scope nodes (pstat : propstat_t) =
  let proto = webdav_proto in
  let code = int_of_webdav_status pstat#status in
  let text = string_of_webdav_status pstat#status in
  
  let proto = prefer ~default:proto (fun p -> p <> "") pstat#status_protocol in
  let code = prefer ~default:code (fun c -> c <> 0) pstat#status_code in
  let text = prefer ~default:text (fun t -> t <> "") pstat#status_text in

  <:pxp_tree<
    <:scope>
      <DAV:propstat>
        ( [ (: emit_prop dtd scope nodes ~deep:true pstat#properties :)
	    (: emit_status dtd scope (proto,code,text) :)
          ]
	  @ (: match pstat#error with
		| [] -> []
		| codes -> [ emit_error dtd scope nodes codes ]
	    :)
	  @ (: match pstat#responsedescription with
		| "" -> []
		| d -> [ emit_responsedescription dtd scope d ]
            :)
	)
  >>


let parse_response strip_prefix root =
  (* <!ELEMENT response (href, ((href*, status)|(propstat+)),
                         error?, responsedescription? , location?) > *)
  let href_list = ref [] in
  let status_code = ref 200 in
  let status_text = ref "OK" in
  let status_protocol = ref "HTTP/1.1 200 OK" in
  let status_seen = ref false in
  let propstat_list = ref [] in
  let responsedescription = ref None in
  let location = ref None in
  let error = ref None in
  scan_subelements root
    (fun node ->
       match node # node_type with
	 | T_element "DAV:href" ->
	     let href = parse_href node in
	     href_list := href :: !href_list
	 | T_element "DAV:status" ->
	     if !status_seen then
	       failwith "XML structure: Double status";
	     if !propstat_list <> [] then
	       failwith "XML structure: Cannot mix status and propstat";
	     let (proto, code, text) = scan_status (scan_pcdata node) in
	     status_protocol := proto;
	     status_code := code;
	     status_text := text;
	     status_seen := true
	 | T_element "DAV:propstat" ->
	     if !status_seen then
	       failwith "XML structure: Cannot mix status and propstat";
	     let ps = parse_propstat node in
	     propstat_list := ps :: !propstat_list
	 | T_element "DAV:responsedescription" ->
	     let d = parse_responsedescription node in
	     if !responsedescription <> None then
	       failwith "XML structure: double responsedescription";
	     responsedescription := Some d
	 | T_element "DAV:location" ->
	     let d = parse_location node in
	     if !location <> None then
	       failwith "XML structure: double location";
	     location := Some d
	 | T_element "DAV:error" ->
	     let e = parse_error node in
	     if !error <> None then
	       failwith "XML structure: double error";
	     error := Some e
	 | _ ->
	     ()
    );
  if not !status_seen && !propstat_list = [] then
    failwith "XML structure: Neither status nor propstat found";
  href_list := List.rev !href_list;
  propstat_list := List.rev !propstat_list;
  let status = webdav_status_of_int !status_code in
  new response 
    !href_list strip_prefix status !status_code !status_text !status_protocol
    !propstat_list 
    (match !error with None -> [] | Some l -> l)
    (match !responsedescription with None -> "" | Some s -> s)
    !location


let emit_response dtd scope nodes (resp : response_t) =
  let status_or_propstats =
    if resp#propstat = [] then
      [ emit_status
	  dtd scope
	  (resp#status_protocol, resp#status_code, resp#status_text)
      ]
    else
      List.map (emit_propstat dtd scope nodes) resp#propstat in
  <:pxp_tree<
    <:scope>
      <DAV:response>
        ( (: List.map (emit_href dtd scope) resp#href :)
	  @ status_or_propstats
	  @ (: match resp#error with
		| [] -> []
		| codes -> [ emit_error dtd scope nodes codes ]
	    :)
	  @ (: match resp#responsedescription with
		| "" -> []
		| d -> [ emit_responsedescription dtd scope d ]
            :)
	  @ (: match resp#location with
		| None -> []
		| Some loc -> [ emit_location dtd scope loc ]
	    :)
	)
  >>
  

let parse_multistatus strip_prefix root =
  (* Entry point; hence check root type *)
  ( match root#node_type with
      | T_element "DAV:multistatus" -> ()
      | _ ->
	  failwith "The XML document is not a multistatus message"
  );
  (* <!ELEMENT multistatus (response*, responsedescription?)  > *)
  let responses = ref [] in
  let responsedescription = ref None in
  scan_subelements root
    (fun node ->
       match node # node_type with
	 | T_element "DAV:response" ->
	     let r = parse_response strip_prefix node in
	     responses := r :: !responses;
	 | T_element "DAV:responsedescription" ->
	     let d = parse_responsedescription node in
	     if !responsedescription <> None then
	       failwith "XML structure: double responsedescription";
	     responsedescription := Some d
	 | _ -> ()
    );
  responses := List.rev !responses;
  ( object
      method responses = !responses
      method responsedescription =
	match !responsedescription with
	  | None -> ""
	  | Some s -> s
    end
  )


let emit_multistatus dtd scope nodes (mstat : multistatus_t) =
  <:pxp_tree<
    <:scope>
      <DAV:multistatus>
        ( (: List.map (emit_response dtd scope nodes) mstat#responses :)
	  @ (: match mstat#responsedescription with
		| "" -> []
		| d -> [ emit_responsedescription dtd scope d ]
            :)
	)
  >> ;;


let parse_body ~namespace_manager ~content_type ch =
  let _, params = 
    try Mimestring.scan_mime_type content_type []
    with _ -> failwith ("Cannot parse Content-type: " ^ content_type) in
  let content_type_encoding =
    try
      let e = List.assoc "charset" params in
      try
	Some(Netconversion.encoding_of_string e)
      with
	| _ -> failwith ("Unknown charset: " ^ e)
    with
      | Not_found -> None in

  let config = 
    { Pxp_types.default_config with
	Pxp_types.encoding = `Enc_utf8;
	store_element_positions = false;
	enable_namespace_processing = Some namespace_manager;
    } in

  let source = 
    (* The source must reliably prevent that external entities can be
       resolved. This is true for [from_obj_channel] by default.

       If there is a charset in content_type, enforce that this encoding
       is used.
     *)
    Pxp_types.from_obj_channel
      ?fixenc:content_type_encoding
      ch in

  let root = 
    try
      (Pxp_tree_parser.parse_wfdocument_entity
	 ~transform_dtd:(fun dtd -> check_dtd dtd; dtd)
	 config
	 source
	 spec) # root
    with
      | error ->
	  failwith ("Cannot parse XML message: " ^ 
		      Pxp_types.string_of_exn error) in
  root

	

let parse_multistatus_body
      ?strip_prefix
      ?(namespace_manager = namespace_manager())
      ~content_type
      ch =
  
  let root = parse_body ~namespace_manager ~content_type ch in
  parse_multistatus strip_prefix root


let write_multistatus_body ?namespace_manager ch mstat =
  write
    ?namespace_manager
    ch
    (fun dtd scope nodes ->
       emit_multistatus dtd scope nodes mstat
    )

let parse_propfind root =
  (* Entry point; hence check root type *)
  ( match root#node_type with
      | T_element "DAV:propfind" -> ()
      | _ ->
	  failwith "The XML document is not a propfind message"
  );
  let req = ref None in
  scan_subelements root
    (fun node ->
       match node # node_type with
	 | T_element "DAV:propname" ->
	     if !req <> None then
	       failwith "XML structure: bad propfind";
	     req := Some `Propname
	 | T_element "DAV:allprop" ->
	     if !req <> None then
	       failwith "XML structure: bad propfind";
	     req := Some (`Allprop [])
	 | T_element "DAV:include" ->
	     ( match !req with
		 | Some (`Allprop []) ->
		     let props = parse_include node in
		     req := Some(`Allprop props)
		 | _ ->
		     failwith "XML structure: bad propfind";
	     )
	 | T_element "DAV:prop" ->
	     if !req <> None then
	       failwith "XML structure: bad propfind";
	     let props = parse_prop node in
	     req := Some(`Prop props)
	 | _ ->
	     ()
    );
  match !req with
    | None ->
	failwith "XML structure: bad propfind"
    | Some r ->
	r


let parse_propfind_request
      ?(namespace_manager = namespace_manager())
      ~content_type
      ch : propfind_request =
  
  let root = parse_body ~namespace_manager ~content_type ch in
  parse_propfind root


let write_propfind_request
      ?namespace_manager
      ch req =

  write
    ?namespace_manager
    ch
    (fun dtd scope nodes ->
       let t =
	 match req with
	   | `Prop l ->
	       [ emit_prop dtd scope nodes ~deep:false l ]
	   | `Propname ->
	       [ <:pxp_tree<
                   <:scope>
                      <DAV:propname>
                         []
                 >>
	       ]
	   | `Allprop [] ->
	       [ <:pxp_tree<
                   <:scope>
                     <DAV:allprop>
                       []
                 >>
	       ]
	   | `Allprop l ->
	       [ <:pxp_tree< <:scope> <DAV:allprop/> >>;
		 emit_include dtd scope nodes l
               ] in
       <:pxp_tree<
         <:scope>
           <DAV:propfind>
	     t
       >>
    )


let parse_remove root =
  let instr = ref None in
  scan_subelements root
    (fun node ->
       match node # node_type with
	 | T_element "DAV:prop" ->
	     if !instr <> None then
	       failwith "XML structure: bad remove";
	     instr := Some(parse_prop node)
	 | _ -> ()
    );
  match !instr with
    | None ->
	failwith "XML structure: bad remove"
    | Some i ->
	i


let parse_set root =
  let instr = ref None in
  scan_subelements root
    (fun node ->
       match node # node_type with
	 | T_element "DAV:prop" ->
	     if !instr <> None then
	       failwith "XML structure: bad set";
	     instr := Some(parse_prop node)
	 | _ -> ()
    );
  match !instr with
    | None ->
	failwith "XML structure: bad set"
    | Some i ->
	i


let parse_propertyupdate root =
  (* Entry point; hence check root type *)
  ( match root#node_type with
      | T_element "DAV:propertyupdate" -> ()
      | _ ->
	  failwith "The XML document is not a proppatch message"
  );
  let update = ref [] in
  scan_subelements root
    (fun node ->
       match node # node_type with
	 | T_element "DAV:remove" ->
	     update := (`Remove (parse_remove node)) :: !update
	 | T_element "DAV:set" ->
	     update := (`Set (parse_set node)) :: !update
	 | _ ->
	     ()
    );
  List.rev !update


let parse_proppatch_request
      ?(namespace_manager = namespace_manager())
      ~content_type
      ch =
  
  let root = parse_body ~namespace_manager ~content_type ch in
  parse_propertyupdate root


let write_proppatch_request
      ?namespace_manager
      ch req =

  write
    ?namespace_manager
    ch
    (fun dtd scope nodes ->
       let t =
	 List.flatten
	   (List.map
	      (function
		 | `Remove [] -> []
		 | `Remove l ->
		     [ <:pxp_tree<
		         <:scope>
		           <DAV:remove>
                              [ (: emit_prop dtd scope nodes ~deep:false l :) ]
		       >>
		     ]
		 | `Set [] -> []
		 | `Set l ->
		     [ <:pxp_tree<
		         <:scope>
		           <DAV:set>
                              [ (: emit_prop dtd scope nodes ~deep:true l :) ]
		       >>
		     ]
	      )
	      req
	   ) in
       if t=[] then
	 failwith "Webdav_xml: proppatch is empty";
       <:pxp_tree<
	 <:scope>
	   <DAV:propertyupdate> t
       >>
    )