(* $Id: webdav_http.ml 9 2015-01-12 20:00:52Z gerd $ *)
(* FIXME: Once Mimestring implements the new Delimited token class,
use this class for scanning URLs of the form ["<" url ">"]
*)
open Webdav_compat
type webdav_status =
[ Nethttp.http_status
| `Multi_status
| `Unprocessable_entity
| `Locked
| `Failed_dependency
| `Insufficient_storage
]
type dav = [ `Class1 | `Class2 | `Class3 | `Token of string | `URL of string ]
type depth = [ `Zero | `One | `Infinity ]
let int_of_webdav_status s =
match s with
| `Multi_status -> 207
| `Unprocessable_entity -> 422
| `Locked -> 423
| `Failed_dependency -> 424
| `Insufficient_storage -> 507
| #Nethttp.http_status as s' ->
Nethttp.int_of_http_status s'
let string_of_webdav_status s =
match s with
| `Multi_status -> "Multi-Status"
| `Unprocessable_entity -> "Unprocessable Entity"
| `Locked -> "Locked"
| `Failed_dependency -> "Failed Dependency"
| `Insufficient_storage -> "Insufficient Storage"
| #Nethttp.http_status as s' ->
Nethttp.string_of_http_status s'
let webdav_status_of_int s =
match s with
| 207 -> `Multi_status
| 422 -> `Unprocessable_entity
| 423 -> `Locked
| 424 -> `Failed_dependency
| 507 -> `Insufficient_storage
| _ -> (Nethttp.http_status_of_int s :> webdav_status)
let webdav_proto = "HTTP/1.1"
type if_condition =
[ `Self_target of if_self_or_condition
| `URL_target of if_url_or_condition
]
and if_self_or_condition =
[ `Or of if_and_condition list ]
and if_url_or_condition =
[ `Or of (string * if_and_condition) list ]
and if_and_condition =
[ `And of if_atom list ]
and if_atom =
[ `Not of if_atom
| `State_token of string
| `Etag of Nethttp.etag
]
module Header = struct
open Mimestring
open Printf
let scan_dav s =
let rec parse_list stream =
match stream with parser
| [< '(Atom "1"); r = parse_rest >] ->
`Class1 :: r
| [< '(Atom "2"); r = parse_rest >] ->
`Class2 :: r
| [< '(Atom "3"); r = parse_rest >] ->
`Class3 :: r
| [< '(Atom tok); r = parse_rest >] ->
`Token tok :: r
| [< '(Special '<'); u = parse_url; r = parse_rest >] ->
`URL u :: r
and parse_rest stream =
match stream with parser
| [< '(Special ','); r = parse_list >] ->
r
| [< 'End >] ->
[]
and parse_url stream =
match stream with parser
| [< '(Atom u); '(Special '>') >] ->
u
in
let scanner =
Mimestring.create_mime_scanner
~specials:[ '('; ')'; '['; ']'; '<'; '>'; ',' ]
~scan_options:[]
s in
let stream =
Stream.from (fun _ -> Some(snd(Mimestring.scan_token scanner))) in
parse_list stream
let get_dav mh =
let l = mh # multiple_field "DAV" in
let p =
try List.flatten (List.map scan_dav l)
with _ ->
raise(Nethttp.Bad_header_field "Webdav_http.Header.get_dav") in
if p = [] then raise Not_found;
p
let set_dav mh l =
let s =
String.concat ", "
(List.map
(function
| `Class1 -> "1"
| `Class2 -> "2"
| `Class3 -> "3"
| `Token tok -> tok
| `URL u -> "<" ^ u ^ ">"
)
l
) in
mh # update_field "DAV" s
let get_depth mh =
let d = mh # field "Depth" in
match d with
| "0" -> `Zero
| "1" -> `One
| "infinity" -> `Infinity
| _ -> raise (Nethttp.Bad_header_field "Webdav_http.Header.get_depth")
let set_depth mh d =
let s =
match d with
| `Zero -> "0"
| `One -> "1"
| `Infinity -> "infinity" in
mh # update_field "Depth" s
let get_destination mh =
mh # field "Destination"
let set_destination mh s =
mh # update_field "Destination" s
let get_overwrite mh =
let s = mh # field "Overwrite" in
match s with
| "F" -> false
| "T" -> true
| _ ->
raise (Nethttp.Bad_header_field "Webdav_http.Header.get_overwrite")
let set_overwrite mh b =
let s = if b then "T" else "F" in
mh # update_field "Overwrite" s
module If_header = struct
(* For the If parsing *)
let if_scan s =
(* Returns a list of Mimestring.s_token for the string s *)
let scanner =
Mimestring.create_mime_scanner
~specials:[ '('; ')'; '['; ']'; '<'; '>' ]
~scan_options:[]
s in
List.map snd (Mimestring.scan_token_list scanner) @ [ End ]
let rec parse_self_or_list stream =
match stream with parser
| [< or_atom = parse_and_list; or_rest = parse_self_or_rest >] ->
`Or (or_atom :: or_rest)
and parse_self_or_rest stream =
match stream with parser
| [< or_atom = parse_and_list; or_rest = parse_self_or_rest >] ->
or_atom :: or_rest
| [< 'End >] ->
[]
and parse_url_or_list stream =
match stream with parser
| [< or_atom = parse_url_or_atom; or_rest = parse_url_or_rest >] ->
`Or (or_atom @ or_rest)
and parse_url_or_rest stream =
match stream with parser
| [< or_atom = parse_url_or_atom; or_rest = parse_url_or_rest >] ->
or_atom @ or_rest
| [< 'End >] ->
[]
and parse_url_or_atom stream =
match stream with parser
| [< '(Special '<'); u = parse_url; l = parse_url_or_atom_rest u >] ->
l
and parse_url_or_atom_rest u stream =
match stream with parser
| [< l = parse_and_list; r = parse_url_or_atom_rest u >] ->
(u, l) :: r
| [< >] ->
[]
and parse_and_list stream =
match stream with parser
| [< '(Special '('); l = parse_and_rest >] ->
`And l
and parse_and_rest stream =
match stream with parser
| [< '(Special ')') >] ->
[]
| [< c = parse_atom; r = parse_and_rest >] ->
c :: r
and parse_atom stream =
match stream with parser
| [< '(Atom "Not"); a = parse_atom_rest >] ->
`Not a
| [< a = parse_atom_rest >] ->
a
and parse_atom_rest stream =
match stream with parser
| [< '(Special '<'); u = parse_url >] ->
`State_token u
| [< '(Special '['); e = parse_entity_tag; '(Special ']') >] ->
`Etag e
and parse_entity_tag stream =
match stream with parser
| [< '(Atom "W/"); '(QString weak) >] ->
`Weak weak
| [< '(QString strong) >] ->
`Strong strong
and parse_url stream =
(* This is criminal... We need to support '[' and ']' because these
chars may occur inside URLs to denote IPv6 addresses
CHECK: maybe also allow double quotes, '(', ')' for maximum
compatibility. This needs changes in the scanner, though.
*)
match stream with parser
| [< '(Atom s); r = parse_url >] ->
s ^ r
| [< '(Special '['); r = parse_url >] ->
"[" ^ r
| [< '(Special ']'); r = parse_url >] ->
"]" ^ r
| [< '(Special '>') >] ->
""
let scan_if s =
let tokens = if_scan s in
let stream = Stream.of_list tokens in
match tokens with
| Special '<' :: _ ->
`URL_target (parse_url_or_list stream)
| Special '(' :: _ ->
`Self_target (parse_self_or_list stream)
| _ ->
failwith "scan_if"
let emit_if (c:if_condition) =
let b = Buffer.create 80 in
let rec emit_list f l =
match l with
| [] -> ()
| x :: l' ->
f x;
if l' <> [] then Buffer.add_char b ' ';
emit_list f l'
in
let rec emit_url_or_atom (u, (`And atoms)) =
bprintf b "<%s> " u;
bprintf b "(";
emit_list emit_atom atoms;
bprintf b ")"
and emit_self_or_atom (`And atoms) =
bprintf b "(";
emit_list emit_atom atoms;
bprintf b ")"
and emit_atom (atom : if_atom) =
match atom with
| `Not (`Not atom') ->
emit_atom atom'
| `Not atom' ->
bprintf b "Not ";
emit_atom atom'
| `State_token u ->
bprintf b "<%s>" u
| `Etag t ->
let h = new Netmime.basic_mime_header [ ] in
Nethttp.Header.set_etag h t;
let s = h#field "Etag" in
bprintf b "[%s]" s
in
( match c with
| `URL_target(`Or l : if_url_or_condition) ->
emit_list emit_url_or_atom l
| `Self_target(`Or l : if_self_or_condition) ->
emit_list emit_self_or_atom l
);
Buffer.contents b
end
let get_if hdr =
let s = hdr # field "If" in
try
If_header.scan_if s
with
| _ ->
raise(Nethttp.Bad_header_field "Webdav_http.Header.get_if")
let set_if hdr (c:if_condition) =
let s = If_header.emit_if c in
hdr # update_field "If" s
end
