(* $Id: webdav_http.ml 1 2011-08-26 21:00:39Z gerd $ *) (* FIXME: Once Mimestring implements the new Delimited token class, use this class for scanning URLs of the form ["<" url ">"] *) 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