(* $Id: webdav_xml.ml 9 2015-01-12 20:00:52Z gerd $ *)
open Webdav_http
open Webdav_compat
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_str.regexp
"\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\)[Tt ]\\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)\\(\\.[0-9]+\\)?\\([Zz]|[-+]\\([0-9][0-9]\\):\\([0-9][0-9]\\)\\)"
let parse_date_time s =
(* RFC 3339, date-time *)
(* TODO: better checks on valid values *)
match Netstring_str.string_match date_time_re s 0 with
| None ->
failwith "Bad date-time"
| Some m ->
let year_s = Netstring_str.matched_group m 1 s in
let month_s = Netstring_str.matched_group m 2 s in
let mday_s = Netstring_str.matched_group m 3 s in
let hour_s = Netstring_str.matched_group m 4 s in
let min_s = Netstring_str.matched_group m 5 s in
let sec_s = Netstring_str.matched_group m 6 s in
let frac_s =
try Netstring_str.matched_group m 7 s with Not_found -> "" in
let tz_s = Netstring_str.matched_group m 8 s in
let tz_hour_s =
try Netstring_str.matched_group m 9 s with Not_found -> "0" in
let tz_min_s =
try Netstring_str.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_str.regexp
"^[ \t\r\n]*\\([^ \t]+\\)[ \t]+\\([0-9][0-9][0-9]\\)\\([ \t]+\\([^\r\n]*\\)\\)[ \t\r\n]*$"
let scan_status s =
match Netstring_str.string_match status_re s 0 with
| None ->
failwith "Bad status line"
| Some m ->
let proto = Netstring_str.matched_group m 1 s in
let code_str = Netstring_str.matched_group m 2 s in
let code = int_of_string code_str in
let text =
try Netstring_str.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
>>
)
