(* $Id: nethttp.ml 2033 2014-09-06 15:39:30Z gerd $
* ----------------------------------------------------------------------
* Nethttp: Basic definitions for the HTTP protocol
*)
type protocol_version =
int * int
type protocol_attribute =
[ `Secure_https
]
type protocol =
[ `Http of (protocol_version * protocol_attribute list)
| `Other
]
let string_of_protocol =
function
| `Http((m,n),_) -> "HTTP/" ^ string_of_int m ^ "." ^ string_of_int n
| `Other -> failwith "string_of_protocol"
let http_re = Netstring_str.regexp "HTTP/\\([0-9]+\\)\\.\\([0-9]+\\)$"
let protocol_of_string s =
match Netstring_str.string_match http_re s 0 with
| Some m ->
( try
`Http ((int_of_string (Netstring_str.matched_group m 1 s),
int_of_string (Netstring_str.matched_group m 2 s)), [])
with
Failure _ -> `Other (* Probably denial-of-service attack! *)
)
| None ->
`Other
type http_status =
(* 1xx: (informational) *)
[ `Continue
| `Switching_protocols
(* 2xx: (successful) *)
| `Ok
| `Created
| `Accepted
| `Non_authoritative
| `No_content
| `Reset_content
| `Partial_content
(* 3xx: (redirection) *)
| `Multiple_choices
| `Moved_permanently
| `Found
| `See_other
| `Not_modified
| `Use_proxy
| `Temporary_redirect
(* 4xx: (client error) *)
| `Bad_request
| `Unauthorized
| `Payment_required
| `Forbidden
| `Not_found
| `Method_not_allowed
| `Not_acceptable
| `Proxy_auth_required
| `Request_timeout
| `Conflict
| `Gone
| `Length_required
| `Precondition_failed
| `Request_entity_too_large
| `Request_uri_too_long
| `Unsupported_media_type
| `Requested_range_not_satisfiable
| `Expectation_failed
(* 5xx: (server error) *)
| `Internal_server_error
| `Not_implemented
| `Bad_gateway
| `Service_unavailable
| `Gateway_timeout
| `Http_version_not_supported
]
let int_of_http_status =
function
(* 1xx: (informational) *)
| `Continue -> 100
| `Switching_protocols -> 101
(* 2xx: (successful) *)
| `Ok -> 200
| `Created -> 201
| `Accepted -> 202
| `Non_authoritative -> 203
| `No_content -> 204
| `Reset_content -> 205
| `Partial_content -> 206
(* 3xx: (redirection) *)
| `Multiple_choices -> 300
| `Moved_permanently -> 301
| `Found -> 302
| `See_other -> 303
| `Not_modified -> 304
| `Use_proxy -> 305
| `Temporary_redirect -> 307
(* 4xx: (client error) *)
| `Bad_request -> 400
| `Unauthorized -> 401
| `Payment_required -> 402
| `Forbidden -> 403
| `Not_found -> 404
| `Method_not_allowed -> 405
| `Not_acceptable -> 406
| `Proxy_auth_required -> 407
| `Request_timeout -> 408
| `Conflict -> 409
| `Gone -> 410
| `Length_required -> 411
| `Precondition_failed -> 412
| `Request_entity_too_large -> 413
| `Request_uri_too_long -> 414
| `Unsupported_media_type -> 415
| `Requested_range_not_satisfiable -> 416
| `Expectation_failed -> 417
(* 5xx: (server error) *)
| `Internal_server_error -> 500
| `Not_implemented -> 501
| `Bad_gateway -> 502
| `Service_unavailable -> 503
| `Gateway_timeout -> 504
| `Http_version_not_supported -> 505
let string_of_http_status =
function
(* 1xx: (informational) *)
| `Continue -> "Continue"
| `Switching_protocols -> "Switching Protocols"
(* 2xx: (successful) *)
| `Ok -> "OK"
| `Created -> "Created"
| `Accepted -> "Accepted"
| `Non_authoritative -> "Non-authoritative Information"
| `No_content -> "No Content"
| `Reset_content -> "Reset Content"
| `Partial_content -> "Partial Content"
(* 3xx: (redirection) *)
| `Multiple_choices -> "Multiple Choices"
| `Moved_permanently -> "Moved Permanently"
| `Found -> "Found"
| `See_other -> "See Other"
| `Not_modified -> "Not Modified"
| `Use_proxy -> "Use Proxy"
| `Temporary_redirect -> "Temporary Redirect"
(* 4xx: (client error) *)
| `Bad_request -> "Bad Request"
| `Unauthorized -> "Unauthorized"
| `Payment_required -> "Payment Required"
| `Forbidden -> "Forbidden"
| `Not_found -> "Not Found"
| `Method_not_allowed -> "Method Not Allowed"
| `Not_acceptable -> "Not Acceptable"
| `Proxy_auth_required -> "Proxy Authorization Required"
| `Request_timeout -> "Request Timeout"
| `Conflict -> "Conflict"
| `Gone -> "Gone"
| `Length_required -> "Length Required"
| `Precondition_failed -> "Precondition Failed"
| `Request_entity_too_large -> "Request Entity Too Large"
| `Request_uri_too_long -> "Request URI Too Long"
| `Unsupported_media_type -> "Unsupported Media Type"
| `Requested_range_not_satisfiable -> "Request Range Not Satisfiable"
| `Expectation_failed -> "Expectation Failed"
(* 5xx: (server error) *)
| `Internal_server_error -> "Internal Server Error"
| `Not_implemented -> "Not Implemented"
| `Bad_gateway -> "Bad Gateway"
| `Service_unavailable -> "Service Unavailable"
| `Gateway_timeout -> "Gateway Timeout"
| `Http_version_not_supported -> "HTTP Version Not Supported"
let http_status_of_int =
function
(* 1xx: (informational) *)
| 100 -> `Continue
| 101 -> `Switching_protocols
(* 2xx: (successful) *)
| 200 -> `Ok
| 201 -> `Created
| 202 -> `Accepted
| 203 -> `Non_authoritative
| 204 -> `No_content
| 205 -> `Reset_content
| 206 -> `Partial_content
(* 3xx: (redirection) *)
| 300 -> `Multiple_choices
| 301 -> `Moved_permanently
| 302 -> `Found
| 303 -> `See_other
| 304 -> `Not_modified
| 305 -> `Use_proxy
| 307 -> `Temporary_redirect
(* 4xx: (client error) *)
| 400 -> `Bad_request
| 401 -> `Unauthorized
| 402 -> `Payment_required
| 403 -> `Forbidden
| 404 -> `Not_found
| 405 -> `Method_not_allowed
| 406 -> `Not_acceptable
| 407 -> `Proxy_auth_required
| 408 -> `Request_timeout
| 409 -> `Conflict
| 410 -> `Gone
| 411 -> `Length_required
| 412 -> `Precondition_failed
| 413 -> `Request_entity_too_large
| 414 -> `Request_uri_too_long
| 415 -> `Unsupported_media_type
| 416 -> `Requested_range_not_satisfiable
| 417 -> `Expectation_failed
(* 5xx: (server error) *)
| 500 -> `Internal_server_error
| 501 -> `Not_implemented
| 502 -> `Bad_gateway
| 503 -> `Service_unavailable
| 504 -> `Gateway_timeout
| 505 -> `Http_version_not_supported
| _ -> raise Not_found
let base_code code =
if code >= 100 && code < 200 then
100
else if code >= 200 && code < 300 then
200
else if code >= 300 && code < 400 then
300
else if code >= 400 && code < 500 then
400
else
500
type http_method = string * string
(** Method name, URI *)
type cache_control_token =
[ `No_store
| `Max_age of int
| `Max_stale of int option
| `Min_fresh of int
| `No_transform
| `Only_if_cached
| `Public
| `Private of string list
| `No_cache of string list
| `Must_revalidate
| `Proxy_revalidate
| `S_maxage of int
| `Extension of string * string option
]
type etag =
[ `Weak of string
| `Strong of string
]
let weak_validator_match e1 e2 =
match (e1,e2) with
| (`Strong s1, `Strong s2) -> s1 = s2
| (`Strong s1, `Weak w2) -> s1 = w2
| (`Weak w1, `Strong s2) -> w1 = s2
| (`Weak w1, `Weak w2) -> w1 = w2
let strong_validator_match e1 e2 =
match (e1,e2) with
| (`Strong s1, `Strong s2) -> s1 = s2
| _ -> false
exception Bad_header_field of string
class type http_header = Netmime.mime_header
class type http_header_ro = Netmime.mime_header_ro
class type http_trailer = Netmime.mime_header
class type http_trailer_ro = Netmime.mime_header_ro
type netscape_cookie =
{ cookie_name : string;
cookie_value : string;
cookie_expires : float option;
cookie_domain : string option;
cookie_path : string option;
cookie_secure : bool;
}
type cookie = netscape_cookie
let status_re =
Netstring_str.regexp "^\\([0-9]+\\)\\([ \t]+\\(.*\\)\\)?$"
let status_of_cgi_header hdr =
let (code, phrase) =
try
let status = hdr # field "Status" in
( match Netstring_str.string_match status_re status 0 with
| Some m ->
(int_of_string (Netstring_str.matched_group m 1 status),
(try Netstring_str.matched_group m 3 status with Not_found -> "")
)
| None ->
failwith "Bad Status response header field"
(* Don't know what to do *)
)
with
Not_found ->
(* Maybe there is a [Location] header: *)
( try
let _location = hdr # field "Location" in
(302, "Found")
with
Not_found ->
(* Default: 200 OK *)
(200, "OK")
)
in
(* Repair [phrase] if empty: *)
let phrase =
if phrase = "" then
( try string_of_http_status (http_status_of_int code)
with Not_found -> "Unknown"
)
else
phrase in
(code, phrase)
;;
let query_re =
Netstring_str.regexp "^\\([^?]*\\)\\?\\(.*\\)$"
let decode_query req_uri =
match Netstring_str.string_match query_re req_uri 0 with
| Some m ->
(Netstring_str.matched_group m 1 req_uri,
Netstring_str.matched_group m 2 req_uri)
| None ->
(req_uri, "")
let host4_re =
Netstring_str.regexp "\\([^]: \t[]+\\)\\(:\\([0-9]+\\)\\)?$" (* CHECK *)
let host6_re =
Netstring_str.regexp "\\[\\([^ \t]+\\)\\]\\(:\\([0-9]+\\)\\)?$"
let split_host_port s =
match Netstring_str.string_match host4_re s 0 with
| Some m ->
let host_name = Netstring_str.matched_group m 1 s in
let host_port =
try Some(int_of_string(Netstring_str.matched_group m 3 s))
with
| Not_found -> None
in
(host_name, host_port)
| None ->
( match Netstring_str.string_match host6_re s 0 with
| Some m ->
let host_name = Netstring_str.matched_group m 1 s in
let host_port =
try Some(int_of_string(Netstring_str.matched_group m 3 s))
with
| Not_found -> None
in
(host_name, host_port)
| None ->
failwith "Invalid hostname"
)
let uripath_encode s =
let l = Neturl.split_path s in
let l' = List.map (Netencoding.Url.encode ~plus:false) l in
Neturl.join_path l'
let uripath_decode s =
let l = Neturl.split_path s in
let l' =
List.map
(fun u ->
let u' = Netencoding.Url.decode ~plus:false u in
if String.contains u' '/' then
failwith "Nethttp.uripath_decode";
u')
l in
Neturl.join_path l'
let rev_split is_cut s =
(* exported *)
let rec seek_cut acc i0 i1 =
if i1 >= String.length s then
(String.sub s i0 (i1 - i0)) :: acc
else if is_cut(String.unsafe_get s i1) then
skip ((String.sub s i0 (i1 - i0)) :: acc) (i1 + 1) (i1 + 1)
else
seek_cut acc i0 (i1 + 1)
and skip acc i0 i1 =
if i1 >= String.length s then acc
else if is_cut(String.unsafe_get s i1) then skip acc i0 (i1 + 1)
else seek_cut acc i1 i1 in
skip [] 0 0
module Cookie = struct
(* This module has been written by Christophe Troestler.
For full copyright message see netcgi.ml
*)
(* Cookies are chosen to be mutable because they are stored on the
client -- there is no rollback possible -- and mutability kind of
reflects that... *)
type t = {
mutable name : string;
mutable value : string;
mutable max_age : int option;
mutable domain : string option;
mutable path : string option;
mutable secure : bool;
mutable comment : string;
mutable comment_url : string;
mutable ports : int list option;
}
let make ?max_age ?domain ?path ?(secure=false)
?(comment="") ?(comment_url="") ?ports name value =
{ name = name;
value = value;
max_age = max_age;
domain = domain;
path = path;
secure = secure;
comment = comment;
comment_url = comment_url;
ports = ports;
}
(* Old version of cookies *)
let of_netscape_cookie c =
{ name = c.cookie_name;
value = c.cookie_value;
max_age = (match c.cookie_expires with
| None -> None
| Some t -> Some(truncate(t -. Unix.time())));
domain = c.cookie_domain;
path = c.cookie_path;
secure = c.cookie_secure;
comment = "";
comment_url = "";
ports = None
}
let to_netscape_cookie cookie =
{ cookie_name = cookie.name;
cookie_value = cookie.value;
cookie_expires = (match cookie.max_age with
| None -> None
| Some t -> Some(float t +. Unix.time()));
cookie_domain = cookie.domain;
cookie_path = cookie.path;
cookie_secure = cookie.secure;
}
let name cookie = cookie.name
let value cookie = cookie.value
let max_age cookie = cookie.max_age
let domain cookie = cookie.domain
let path cookie = cookie.path
let secure cookie = cookie.secure
let comment cookie = cookie.comment
let comment_url cookie = cookie.comment_url
let ports cookie = cookie.ports
let set_value cookie v = cookie.value <- v
let set_max_age cookie t = cookie.max_age <- t
let set_domain cookie dom = cookie.domain <- dom
let set_path cookie s = cookie.path <- s
let set_secure cookie b = cookie.secure <- b
let set_comment cookie s = cookie.comment <- s
let set_comment_url cookie s = cookie.comment_url <- s
let set_ports cookie p = cookie.ports <- p
(* Set -------------------------------------------------- *)
(* Escape '"', '\\',... and surround the string with quotes. *)
let escape s0 =
let len = String.length s0 in
let encoded_length = ref len in
for i = 0 to len - 1 do
match String.unsafe_get s0 i with
| '\"' | '\\' | '\n' | '\r' -> incr encoded_length
| '\000' .. '\031' -> decr encoded_length (* ignore *)
| _ -> ()
done;
let s = String.create (!encoded_length + 2) in
String.unsafe_set s 0 '\"';
let j = ref 1 in
for i = 0 to len - 1 do
(match String.unsafe_get s0 i with
| '\"' | '\\' as c ->
String.unsafe_set s !j '\\'; incr j;
String.unsafe_set s !j c; incr j
| '\n' ->
String.unsafe_set s !j '\\'; incr j;
String.unsafe_set s !j 'n'; incr j
| '\r' ->
String.unsafe_set s !j '\\'; incr j;
String.unsafe_set s !j 'r'; incr j
| '\000' .. '\031' ->
() (* Ignore these control chars, useless for comments *)
| c ->
String.unsafe_set s !j c; incr j
);
done;
String.unsafe_set s !j '\"';
s
(* [gen_cookie c] returns a buffer containing an attribute suitable
for "Set-Cookie" (RFC 2109) and "Set-Cookie2" (RFC 2965).
which is backward compatible with Netscape spec. It is the
minimal denominator. *)
let gen_cookie c =
let buf = Buffer.create 128 in
(* Encode, do not quote, key-val for compatibility with old browsers. *)
Buffer.add_string buf (Netencoding.Url.encode ~plus:false c.name);
Buffer.add_string buf "=";
Buffer.add_string buf (Netencoding.Url.encode ~plus:false c.value);
Buffer.add_string buf ";Version=1";
(* FIXME: Although values of Domain and Path can be quoted since
RFC2109, it seems that browsers do not understand them -- they
take the quotes as part of the value. One way to get correct
headers is to strip [d] and [p] of unsafe chars -- if they have any. *)
(match c.domain with
| None -> ()
| Some d ->
Buffer.add_string buf ";Domain=";
Buffer.add_string buf d);
(match c.path with
| None -> ()
| Some p ->
Buffer.add_string buf ";Path=";
Buffer.add_string buf p);
if c.secure then Buffer.add_string buf ";secure";
(match c.max_age with
| None -> ()
| Some s ->
Buffer.add_string buf ";Max-Age=";
Buffer.add_string buf (if s > 0 then string_of_int s else "0");
(* For compatibility with old browsers: *)
Buffer.add_string buf ";Expires=";
Buffer.add_string buf
(if s > 0 then Netdate.mk_mail_date (Unix.time() +. float s)
else "Thu, 1 Jan 1970 00:00:00 GMT");
);
if c.comment <> "" then (
Buffer.add_string buf ";Comment=";
Buffer.add_string buf (escape c.comment);
);
buf
let set_set_cookie_ct (http_header:#Netmime.mime_header) cookies =
let add_cookie (c1, c2) c =
let buf = gen_cookie c in
(* In any case, we set a "Set-Cookie" header *)
let c1 = (Buffer.contents buf) :: c1 in
let c2 =
if c.comment_url = "" && c.ports = None then c2 else (
(* When this is relevant, also set a "Set-Cookie2" header *)
if c.comment_url <> "" then (
Buffer.add_string buf ";CommentURL=";
Buffer.add_string buf (escape c.comment_url));
(match c.ports with
| None -> ()
| Some p ->
Buffer.add_string buf ";Port=\"";
Buffer.add_string buf (String.concat ","
(List.map string_of_int p));
Buffer.add_string buf "\""
);
(Buffer.contents buf) :: c2
) in
(c1, c2) in
let cookie, cookie2 = List.fold_left add_cookie ([], []) cookies in
http_header#update_multiple_field "Set-Cookie" cookie;
(* "Set-Cookie2" must come after in order, when they are
understood, to override the "Set-Cookie". *)
http_header#update_multiple_field "Set-Cookie2" cookie2
(* Get -------------------------------------------------- *)
(* According to RFC 2068:
quoted-string = ( <"> *(qdtext) <"> )
qdtext = <any TEXT except '\"'>
quoted-pair = "\\" CHAR
As there a no details, we decode the usual escapes and treat
other "\x" as simply "x". *)
let unescape_range s low up =
if low >= up then "" else
let len = up - low in
let s = String.sub s low len in
let rec decode i j =
if i < len then (
match String.unsafe_get s i with
| '\\' ->
let i = i + 1 in
if i < len then (
(match String.unsafe_get s i with
| '\"' | '\\' as c -> String.unsafe_set s j c
| 'n' -> String.unsafe_set s j '\n'
| 'r' -> String.unsafe_set s j '\r'
| 't' -> String.unsafe_set s j '\t'
| c -> String.unsafe_set s j c
);
decode (i + 1) (j + 1)
)
else j
| c ->
String.unsafe_set s j c;
decode (i + 1) (j + 1)
)
else j in
let j = decode 0 0 in
if j < len then String.sub s 0 j else s
let ports_of_string s =
let l = rev_split (fun c -> c = ',' || c = ' ') s in
List.fold_left (fun pl p ->
try int_of_string p :: pl with _ -> pl) [] l
(* Given a new key-val data, update the list of cookies accordingly
(new cookie or update attributes of the current one). *)
let add_key_val key value cl =
if key <> "" && String.unsafe_get key 0 = '$' then
(* Keys starting with '$' are for control; ignore the ones we do
not know about. *)
(match cl with
| [] -> []
| c :: _ ->
(if key = "$Path" then c.path <- Some value
else if key = "$Domain" then c.domain <- Some value
else if key = "$Port" then
c.ports <- Some (ports_of_string value));
cl
)
else make key value :: cl
let decode_range s start _end =
Netencoding.Url.decode ~pos:start ~len:(_end - start) s
(* The difference between version 0 and version 1 cookies is that
the latter start with $Version (present 1st or omitted). Our
decoding function can handle both versions transparently, so
$Version is ignored. In the absence of "=", the string is
treated as the VALUE. *)
(* [get_key cs i0 i len] scan the cookie string [cs] and get the
key-val pairs. keys and values are stripped of heading and
trailing spaces, except for quoted values. *)
let rec get_key cs i0 i len cl =
if i >= len then
let value = decode_range cs i0 len in
if value = "" then cl else make "" value :: cl
else
match String.unsafe_get cs i with
| ',' | ';' ->
(* No "=", interpret as a value as Mozilla does. We choose
this over MSIE which is reported to return just "n"
instead of "n=" when the value is empty. *)
let cl = make "" (decode_range cs i0 i) :: cl in
skip_space_before_key cs (i + 1) len cl
| '=' ->
let i1 = i + 1 in
skip_value_space cs i1 len (decode_range cs i0 i) cl
| c ->
get_key cs i0 (i + 1) len cl
and skip_space_before_key cs i len cl =
if i >= len then cl
else
match String.unsafe_get cs i with
| ' ' | '\t' | '\n' | '\r' -> skip_space_before_key cs (i + 1) len cl
| _ -> get_key cs i i len cl
and skip_value_space cs i len key cl =
if i >= len then add_key_val key "" cl (* no value *)
else
match String.unsafe_get cs i with
| ' ' | '\t' | '\n' | '\r' -> (* skip linear white space *)
skip_value_space cs (i + 1) len key cl
| '\"' ->
get_quoted_value cs (i + 1) (i + 1) len key cl
| _ ->
get_value cs i i len key cl
and get_value cs i0 i len key cl =
if i >= len then add_key_val key (decode_range cs i0 len) cl
else
match String.unsafe_get cs i with
| ',' | ';' ->
let cl = add_key_val key (decode_range cs i0 i) cl in
(* Usually there is a space after ';' to skip *)
skip_space_before_key cs (i + 1) len cl
| _ ->
get_value cs i0 (i + 1) len key cl
and get_quoted_value cs i0 i len key cl =
if i >= len then (* quoted string not closed; try anyway *)
add_key_val key (unescape_range cs i0 len) cl
else
match String.unsafe_get cs i with
| '\\' -> get_quoted_value cs i0 (i + 2) len key cl
| '\"' ->
let cl = add_key_val key (unescape_range cs i0 i) cl in
skip_to_next cs (i + 1) len cl
| _ -> get_quoted_value cs i0 (i + 1) len key cl
and skip_to_next cs i len cl =
if i >= len then cl
else
match String.unsafe_get cs i with
| ',' | ';' -> skip_space_before_key cs (i + 1) len cl
| _ -> skip_to_next cs (i + 1) len cl
let get_cookie_ct (http_header:#http_header_ro) =
let cookies = http_header#multiple_field "Cookie" in
let cl = List.fold_left
(fun cl cs -> get_key cs 0 0 (String.length cs) cl) [] cookies in
(* The order of cookies is important for the Netscape ones since
"more specific path mapping should be sent before cookies with
less specific path mappings" -- for those, there will be only a
single "Cookie" line. *)
List.rev cl
end
module Header = struct
open Netmime
open Mimestring
(* As scanner we use the scanner for mail header fields from Mimestring. It
* is very configurable.
*)
let std_special_chars =
[ ','; ';'; '=' ]
(* CHECK: Maybe we should add more characters, e.g. '@'. They are not
* used in HTTP, and including them here would cause that field values
* containing them are rejected. Maybe we want that.
*)
let scan_value ?(specials = std_special_chars) s =
let scanner = create_mime_scanner ~specials ~scan_options:[] s in
Stream.from
(fun _ ->
Some (snd (scan_token scanner)))
(* ---- Parser combinators for stream parsers: ---- *)
let rec parse_comma_separated_list subparser stream =
(* The [subparser] is required to return its value when it finds a
* comma (i.e. [Special ','], or when it finds [End]. These tokens
* must not be swallowed.
*)
let expr_opt = subparser stream in
match expr_opt with
| Some expr ->
expr ::
parse_comma_separated_rest subparser stream
| None ->
[]
and parse_comma_separated_rest subparser stream =
match Stream.peek stream with
| Some(Special ',') ->
Stream.junk stream;
ignore(parse_commas stream);
parse_comma_separated_list subparser stream
| _ ->
[]
and parse_commas stream =
match Stream.peek stream with
| Some(Special ',') ->
Stream.junk stream;
parse_commas stream
| _ ->
()
let parse_end stream =
match Stream.peek stream with
| Some End -> Stream.junk stream; ()
| _ -> raise Stream.Failure
let merge_lists mh fieldparser fieldname =
let fields = mh # multiple_field fieldname in
if fields = [] then raise Not_found;
List.flatten (List.map fieldparser fields)
let parse_field mh fn_name f_parse fieldname =
try
let field = mh # field fieldname in
f_parse (scan_value field)
with
| Stream.Failure
| Stream.Error _ ->
raise (Bad_header_field fn_name)
let parse_comma_separated_field ?specials mh fn_name f_parse fieldname =
let fieldparser field =
try
let stream = scan_value ?specials field in
let r = parse_comma_separated_list f_parse stream in
parse_end stream;
r
with
| Stream.Failure
| Stream.Error _ ->
raise (Bad_header_field fn_name) in
merge_lists mh fieldparser fieldname
(* ----- Common parsers/printer: ---- *)
let parse_token_list mh fn_name fieldname =
let parse_token stream =
match Stream.peek stream with
| Some (Atom tok) -> Stream.junk stream; Some tok
| _ -> None in
parse_comma_separated_field mh fn_name parse_token fieldname
let parse_token_or_qstring stream =
match Stream.peek stream with
| Some(Atom tok) -> Stream.junk stream; tok
| Some(QString v) -> Stream.junk stream; v
| _ -> raise Stream.Failure
let rec parse_params stream =
match Stream.npeek 3 stream with
| [ Special ';'; Atom name; Special '=' ] ->
for k=1 to 3 do Stream.junk stream done;
let v = parse_token_or_qstring stream in
(name,v) :: parse_params stream
| _ ->
[]
let parse_extended_token_list mh fn_name fieldname =
(* token [ '=' (token|qstring) ( ';' token '=' (token|qstring) ) * ] *)
let rec parse_extended_token stream =
match Stream.peek stream with
| Some(Atom tok) ->
Stream.junk stream;
let extension = parse_equation stream in
( match extension with
| Some (eq_val, params) ->
Some (tok, Some eq_val, params)
| None ->
Some (tok, None, [])
)
| _ ->
None
and parse_equation stream =
match Stream.peek stream with
| Some(Special '=') ->
Stream.junk stream;
let v = parse_token_or_qstring stream in
let params = parse_params stream in
Some (v, params)
| _ ->
None in
parse_comma_separated_field mh fn_name parse_extended_token fieldname
let qstring_indicator_re =
Netstring_str.regexp "[]\\\"()<>@,;:/[?={} \x00-\x1f\x7f]"
(* Netstring_pcre.regexp "[\\\\\"()<>@,;:/[\\]?={} \\x00-\\x1f\\x7f]" *)
let qstring_re =
Netstring_str.regexp "[\\\"]"
(* Netstring_pcre.regexp "[\\\\\\\"]" *)
let qstring_of_value s =
(* Returns a qstring *)
"\"" ^ Netstring_str.global_replace qstring_re "\\\\\\0" s ^ "\""
(* Escape qstring_re with a backslash *)
let string_of_value s =
(* Returns a token or a qstring, depending on the value of [s] *)
try
ignore(Netstring_str.search_forward qstring_indicator_re s 0);
qstring_of_value s
with
Not_found -> s
let string_of_params l =
if l = [] then
""
else
";" ^
String.concat
";"
(List.map
(fun (n,s) ->
n ^ "=" ^ string_of_value s)
l)
let string_of_extended_token fn_name =
function
| (tok, None, []) ->
tok
| (tok, None, _) ->
invalid_arg fn_name
| (tok, Some eq_val, params) ->
tok ^ "=" ^ eq_val ^ string_of_params params
let parse_parameterized_token_list mh fn_name fieldname =
(* token ( ';' token '=' (token|qstring) ) * *)
let rec parse_parameterized_token stream =
match Stream.peek stream with
| Some (Atom tok) ->
Stream.junk stream;
let params = parse_params stream in
Some(tok, params)
| _ ->
None
in
parse_comma_separated_field mh fn_name parse_parameterized_token fieldname
let string_of_parameterized_token (tok, params) =
tok ^ string_of_params params
let q_split ( l : (string * (string * string) list) list )
: (string * (string * string) list * (string * string) list) list
=
(* Find the "q" param, and split [params] at that position *)
let rec split params =
match params with
| [] -> ([], [])
| ("q", q) :: rest -> ([], params)
| other :: rest ->
let before, after = split rest in
(other :: before), after
in
List.map
(fun (tok, params) ->
let before, after = split params in
(tok, before, after))
l
let q_merge fn_name (tok, params, q_params) =
if List.mem_assoc "q" params then invalid_arg fn_name;
( match q_params with
| ( "q", _ ) :: _
| [] ->
(tok, (params @ q_params))
| _ ->
invalid_arg fn_name
)
let date_of_string fn_name s =
try
Netdate.parse_epoch s
with
Invalid_argument _ ->
raise(Bad_header_field fn_name)
let string_of_date f =
Netdate.format ~fmt:"%a, %d %b %Y %H:%M:%S GMT" (Netdate.create ~zone:0 f)
let sort_by_q ?(default=1.0) toks_with_params =
(* Sorts [toks_with_params] such that the highest [q] values come first.
* Tokens with a [q] value of 0 are removed. Tokens without [q] value
* are assumed to have the [default] value. This is also done with
* unparseable [q] values.
*)
List.map
snd
(List.stable_sort
(fun (q1, tok_param1) (q2, tok_param2) ->
Pervasives.compare q2 q1)
(List.filter
(fun (q, tok_param) ->
q > 0.0)
(List.map
(fun (tok, params) ->
try
let q_str = List.assoc "q" params in
(float_of_string q_str, (tok, params))
with
| Not_found -> (default, (tok, params))
| Failure _ -> (default, (tok, params))
)
toks_with_params)))
let sort_by_q' ?default tok_with_params_and_qparams =
List.map
(fun ((tok, tok_params), q_params) -> (tok, tok_params, q_params))
(sort_by_q
?default
(List.map
(fun (tok, tok_params, q_params) -> ((tok, tok_params), q_params))
tok_with_params_and_qparams))
(* ---- The field accessors: ---- *)
let get_accept mh =
q_split
(parse_parameterized_token_list mh "Nethttp.get_accept" "Accept")
let set_accept mh av =
let s =
String.concat ","
(List.map
(fun triple ->
string_of_parameterized_token (q_merge "Nethttp.set_accept" triple))
av) in
mh # update_field "Accept" s
let best_media_type mh supp =
let match_mime a b =
let (main_type, sub_type) = Mimestring.split_mime_type b
in
sub_type = "*" (*Ignore non-wildcard types*) &&
(main_type = "*" ||
main_type = (fst (Mimestring.split_mime_type a)))
in
let filter p l =
List.fold_right
(fun ((tok, _, _) as e) l -> if p tok then e :: l else l)
l
[]
in
let accept = try get_accept mh with Not_found -> [ "*/*",[],[] ] in
match
sort_by_q' (List.flatten (List.map
(fun t ->
filter ((=) t) accept
@
filter (match_mime t) accept
)
supp))
with
(tok, params, qparams) :: _ -> (tok, params)
| [] -> ("", [])
let get_accept_charset mh =
parse_parameterized_token_list mh
"Nethttp.get_accept_charset" "Accept-Charset"
let set_accept_charset mh l =
mh # update_field
"Accept-Charset"
(String.concat "," (List.map string_of_parameterized_token l))
let best_tok_of_list toks supp =
let tok =
List.find
(fun tok -> tok = "*" || List.mem tok supp)
toks in
if tok = "*" then
List.find (fun tok -> not (List.mem tok toks)) supp
else
tok
let best_charset mh supp =
try
let toks_with_params = get_accept_charset mh in (* or Not_found *)
(* Special handling of ISO-8859-1: *)
let toks_with_params' =
if not(List.mem_assoc "*" toks_with_params) &&
not(List.exists
(fun (tok,_) -> String.lowercase tok = "iso-8859-1")
toks_with_params)
then
toks_with_params @ [ "ISO-8859-1", ["q", "1.0"] ]
else
toks_with_params in
let toks' = List.map fst (sort_by_q toks_with_params') in
best_tok_of_list toks' supp
with
Not_found -> "*"
let get_accept_encoding mh =
parse_parameterized_token_list mh
"Nethttp.get_accept_encoding" "Accept-Encoding"
let set_accept_encoding mh l =
mh # update_field
"Accept-Encoding"
(String.concat "," (List.map string_of_parameterized_token l))
let best_encoding mh supp =
try
let toks_with_params = sort_by_q (get_accept_encoding mh) in
best_tok_of_list (List.map fst toks_with_params) supp
with
Not_found -> "identity"
let get_accept_language mh =
parse_parameterized_token_list mh
"Nethttp.get_accept_language" "Accept-Language"
let set_accept_language mh l =
mh # update_field
"Accept-Language"
(String.concat "," (List.map string_of_parameterized_token l))
let get_accept_ranges mh =
parse_token_list mh "Nethttp.get_accept_ranges" "Accept-Ranges"
let set_accept_ranges mh toks =
mh # update_field "Accept-Ranges" (String.concat "," toks)
let get_age mh =
try
float_of_string (mh # field "Age")
with
Failure _ -> raise(Bad_header_field "Nethttp.get_age")
let set_age mh v =
mh # update_field "Age" (Printf.sprintf "%.0f" v)
let get_allow mh =
parse_token_list mh "Nethttp.get_allow" "Allow"
let set_allow mh toks =
mh # update_field "Allow" (String.concat "," toks)
let comma_split_re = Netstring_str.regexp "\\([ \t]*,\\)+[ \t]*"
let comma_split =
Netstring_str.split comma_split_re
let parse_opt_eq_token stream =
match Stream.peek stream with
| Some(Special '=') ->
Stream.junk stream;
( match Stream.peek stream with
| Some (Atom v) -> Stream.junk stream; Some v
| Some (QString v) -> Stream.junk stream; Some v
| _ -> raise Stream.Failure
)
| _ ->
None
let parse_cc_directive_1 stream =
match Stream.npeek 3 stream with
| (Atom "no-cache") :: _ ->
Stream.junk stream;
( match parse_opt_eq_token stream with
| None -> `No_cache []
| Some names -> `No_cache(comma_split names)
)
| (Atom "no-store") :: _ ->
Stream.junk stream;
`No_store
| [ Atom "max-age"; Special '='; Atom seconds ] ->
for k = 1 to 3 do Stream.junk stream done;
`Max_age(int_of_string seconds)
| (Atom "max-stale") :: _ ->
Stream.junk stream;
( match parse_opt_eq_token stream with
| None -> `Max_stale None
| Some seconds -> `Max_stale(Some(int_of_string seconds))
)
| [ Atom "min-fresh"; Special '='; Atom seconds ] ->
for k = 1 to 3 do Stream.junk stream done;
`Min_fresh(int_of_string seconds)
| ( Atom "no-transform") :: _ ->
Stream.junk stream;
`No_transform
| ( Atom "only-if-cached") :: _ ->
Stream.junk stream;
`Only_if_cached
| ( Atom "public") :: _ ->
Stream.junk stream;
`Public
| ( Atom "private") :: _ ->
( match parse_opt_eq_token stream with
| None -> `Private []
| Some names -> `Private(comma_split names)
)
| ( Atom "must-revalidate") :: _ ->
Stream.junk stream;
`Must_revalidate
| ( Atom "proxy-revalidate") :: _ ->
Stream.junk stream;
`Proxy_revalidate
| [ Atom "s-maxage"; Special '='; Atom seconds ] ->
for k = 1 to 3 do Stream.junk stream done;
`S_maxage(int_of_string seconds)
| ( Atom extension ) :: _ ->
Stream.junk stream;
let val_opt = parse_opt_eq_token stream in
`Extension(extension, val_opt)
| _ ->
raise Stream.Failure
let parse_cc_directive stream =
try
Some (parse_cc_directive_1 stream)
with Stream.Failure -> None
let get_cache_control mh =
parse_comma_separated_field
mh "Nethttp.get_cache_control" parse_cc_directive "Cache-Control"
let set_cache_control mh l =
let s =
String.concat ","
(List.map
(function
| `No_store -> "no-store"
| `Max_age n -> "max-age=" ^ string_of_int n
| `Max_stale None -> "max-stale"
| `Max_stale(Some n) -> "max-stale=" ^ string_of_int n
| `Min_fresh n -> "min-fresh=" ^ string_of_int n
| `No_transform -> "no-transform"
| `Only_if_cached -> "only-if-cached"
| `Public -> "public"
| `Private names -> "private=\"" ^ String.concat "," names ^ "\""
| `No_cache [] -> "no-cache"
| `No_cache names -> "no-cache=\"" ^ String.concat "," names ^ "\""
| `Must_revalidate -> "must-revalidate"
| `Proxy_revalidate -> "proxy-revalidate"
| `S_maxage n -> "s-maxage=" ^ string_of_int n
| `Extension(tok,None) -> tok
| `Extension(tok, Some param) -> tok ^ "=" ^ string_of_value param
)
l) in
mh # update_field "Cache-Control" s
let get_connection mh =
parse_token_list mh "Nethttp.get_connection" "Connection"
let set_connection mh toks =
mh # update_field "Connection" (String.concat "," toks)
let get_content_encoding mh =
parse_token_list mh "Nethttp.get_content_encoding" "Content-Encoding"
let set_content_encoding mh toks =
mh # update_field "Content-Encoding" (String.concat "," toks)
let get_content_language mh =
parse_token_list mh "Nethttp.get_content_language" "Content-Language"
let set_content_language mh toks =
mh # update_field "Content-Language" (String.concat "," toks)
let get_content_length mh =
try
Int64.of_string (mh # field "Content-Length")
with
Failure _ -> raise (Bad_header_field "Nethttp.get_content_length")
let set_content_length mh n =
mh # update_field "Content-Length" (Int64.to_string n)
let get_content_location mh =
mh # field "Content-Location"
let set_content_location mh s =
mh # update_field "Content-Location" s
let get_content_md5 mh =
mh # field "Content-MD5"
let set_content_md5 mh s =
mh # update_field "Content-MD5" s
let parse_byte_range_resp_spec stream =
match Stream.npeek 3 stream with
| (Special '*') :: _ ->
Stream.junk stream;
None
| [ Atom first; Special '-'; Atom last ] ->
for k = 1 to 3 do Stream.junk stream done;
Some(Int64.of_string first, Int64.of_string last)
| _ ->
raise Stream.Failure
let parse_byte_range_resp_length stream =
match Stream.peek stream with
| Some (Special '*') ->
Stream.junk stream;
None
| Some (Atom length) ->
Stream.junk stream;
Some(Int64.of_string length)
| _ ->
raise Stream.Failure
let parse_content_range_spec stream =
if Stream.next stream <> Atom "bytes" then raise Stream.Failure;
let br = parse_byte_range_resp_spec stream in
if Stream.next stream <> Special '/' then raise Stream.Failure;
let l = parse_byte_range_resp_length stream in
if Stream.next stream <> End then raise Stream.Failure;
`Bytes(br,l)
let get_content_range mh =
let s = mh # field "Content-Range" in
let stream = scan_value ~specials:[ ','; ';'; '='; '*'; '-'; '/' ] s in
try
parse_content_range_spec stream
with
| Stream.Failure
| Stream.Error _
| Failure _ ->
raise (Bad_header_field "Nethttp.get_content_range")
let set_content_range mh (`Bytes(range_opt,length_opt)) =
let s =
( match range_opt with
| Some (first,last) -> Int64.to_string first ^ "-" ^ Int64.to_string last
| None -> "*"
) ^ "/" ^
( match length_opt with
| Some length -> Int64.to_string length
| None -> "*"
) in
mh # update_field "Content-Range" s
let get_content_type mh =
try
List.hd
(parse_parameterized_token_list mh
"Nethttp.get_content_type" "Content-Type")
with
Failure _ -> raise(Bad_header_field "Nethttp.get_content_type")
let set_content_type mh (tok,params) =
mh # update_field
"Content-Type"
(string_of_parameterized_token (tok,params))
let get_date mh =
date_of_string "Nethttp.get_date" (mh # field "Date")
let set_date mh d =
mh # update_field "Date" (string_of_date d)
let parse_etag_token stream =
match Stream.npeek 3 stream with
| [ Atom "W"; Special '/'; QString e ] ->
for k = 1 to 3 do Stream.junk stream done;
`Weak e
| (QString e) :: _ ->
Stream.junk stream;
`Strong e
| _ ->
raise Stream.Failure
let parse_etag stream =
let etag = parse_etag_token stream in
parse_end stream;
etag
let get_etag mh =
let s = mh # field "ETag" in
let stream = scan_value ~specials:[ ','; ';'; '='; '/' ] s in
try parse_etag stream
with
| Stream.Failure
| Stream.Error _
| Failure _ ->
raise (Bad_header_field "Nethttp.get_etag")
let string_of_etag =
function
| `Weak s -> "W/" ^ qstring_of_value s
| `Strong s -> qstring_of_value s
let set_etag mh etag =
mh # update_field "ETag" (string_of_etag etag)
let get_expect mh =
parse_extended_token_list mh "Nethttp.get_expect" "Expect"
let set_expect mh expectation =
mh # update_field "Expect"
(String.concat ","
(List.map (string_of_extended_token "Nethttp.set_expect") expectation))
let get_expires mh =
date_of_string "Nethttp.get_expires" (mh # field "Expires")
let set_expires mh d =
mh # update_field "Expires" (string_of_date d)
let get_from mh =
mh # field "From"
let set_from mh v =
mh # update_field "From" v
let get_host mh =
let s = mh # field "Host" in
try
split_host_port s
with
| Failure _ -> raise(Bad_header_field "Nethttp.get_host")
let set_host mh (host,port_opt) =
let s =
host ^
( match port_opt with Some p -> ":" ^ string_of_int p | None -> "") in
mh # update_field "Host" s
let parse_etag_or_star_tok stream =
match Stream.peek stream with
| Some (Special '*') ->
Stream.junk stream; Some None
| _ ->
try
Some(Some(parse_etag_token stream))
with
| Stream.Failure -> None
let get_etag_list mh fn_name fieldname =
let specials = [ ','; ';'; '='; '/'; '*' ] in
let l =
parse_comma_separated_field
~specials mh fn_name parse_etag_or_star_tok fieldname in
if List.mem None l then
None
else
Some(List.map (function Some e -> e | None -> assert false) l)
let set_etag_list mh fieldname l_opt =
let v =
match l_opt with
| None -> "*"
| Some l ->
String.concat "," (List.map string_of_etag l) in
mh # update_field fieldname v
let get_if_match mh =
get_etag_list mh "Nethttp.get_if_match" "If-Match"
let set_if_match mh =
set_etag_list mh "If-Match"
let get_if_modified_since mh =
date_of_string "Nethttp.get_if_modified_since" (mh # field "If-Modified-Since")
let set_if_modified_since mh d =
mh # update_field "If-Modified-Since" (string_of_date d)
let get_if_none_match mh =
get_etag_list mh "Nethttp.get_if_none_match" "If-None-Match"
let set_if_none_match mh =
set_etag_list mh "If-None-Match"
let get_if_range mh =
let s = mh # field "If-Range" in
let stream = scan_value ~specials:[ ','; ';'; '='; '/' ] s in
try `Etag (parse_etag stream)
with
| Stream.Failure
| Stream.Error _
| Failure _ ->
`Date (date_of_string "Nethttp.get_if_range" s)
let set_if_range mh v =
let s =
match v with
| `Etag e -> string_of_etag e
| `Date d -> string_of_date d in
mh # update_field "If-Range" s
let get_if_unmodified_since mh =
date_of_string "Nethttp.get_if_unmodified_since"
(mh # field "If-Unmodified-Since")
let set_if_unmodified_since mh d =
mh # update_field "If-Unmodified-Since" (string_of_date d)
let get_last_modified mh =
date_of_string "Nethttp.get_last_modified" (mh # field "Last-Modified")
let set_last_modified mh d =
mh # update_field "Last-Modified" (string_of_date d)
let get_location mh =
mh # field "Location"
let set_location mh s =
mh # update_field "Location" s
let get_max_forwards mh =
try
int_of_string (mh # field "Max-Forwards")
with
Failure _ -> raise(Bad_header_field "Nethttp.get_max_forwards")
let set_max_forwards mh n =
mh # update_field "Max-Forwards" (string_of_int n)
let parse_pragma_directive stream =
match Stream.peek stream with
| Some (Atom tok) ->
Stream.junk stream;
let param_opt = parse_opt_eq_token stream in
Some (tok, param_opt)
| _ ->
None
let get_pragma mh =
parse_comma_separated_field
mh "Nethttp.get_pragma" parse_pragma_directive "Pragma"
let set_pragma mh l =
let s =
String.concat ","
(List.map
(function
| (tok, None) -> tok
| (tok, Some param) -> tok ^ "=" ^ string_of_value param)
l) in
mh # update_field "Pragma" s
let parse_opt_last_pos stream =
match Stream.peek stream with
| Some(Atom last) ->
Stream.junk stream;
Some(Int64.of_string last)
| _ ->
None
let rec parse_byte_range_spec stream =
match Stream.npeek 2 stream with
| [ Atom first; Special '-' ] ->
Stream.junk stream;
Stream.junk stream;
let last = parse_opt_last_pos stream in
let r = parse_byte_range_spec_rest stream in
(Some (Int64.of_string first), last) :: r
| [ Special '-'; Atom suffix_length ] ->
Stream.junk stream;
Stream.junk stream;
let r = parse_byte_range_spec_rest stream in
(None, Some(Int64.of_string suffix_length)) :: r
| _ ->
[]
and parse_byte_range_spec_rest stream =
match Stream.peek stream with
| Some (Special ',') ->
Stream.junk stream;
parse_commas stream;
parse_byte_range_spec stream
| _ -> []
let parse_ranges_specifier stream =
if Stream.next stream <> Atom "bytes" then raise Stream.Failure;
if Stream.next stream <> Special '=' then raise Stream.Failure;
let r = parse_byte_range_spec stream in
if Stream.next stream <> End then raise Stream.Failure;
`Bytes r
let get_range mh =
let s = mh # field "Range" in
let stream = scan_value ~specials:[ ','; ';'; '='; '*'; '-'; '/' ] s in
try
parse_ranges_specifier stream
with
| Stream.Failure
| Stream.Error _
| Failure _ ->
raise (Bad_header_field "Nethttp.get_range")
let set_range mh (`Bytes l) =
let s =
"bytes=" ^
String.concat ","
(List.map
(function
| (Some first, Some last) ->
Int64.to_string first ^ "-" ^ Int64.to_string last
| (Some first, None) ->
Int64.to_string first ^ "-"
| (None, Some last) ->
"-" ^ Int64.to_string last
| (None, None) ->
invalid_arg "Nethttp.set_range")
l) in
mh # update_field "Range" s
let get_referer mh =
mh # field "Referer"
let get_referrer = get_referer
let set_referer mh s =
mh # update_field "Referer" s
let set_referrer = set_referer
let get_retry_after mh =
let s = mh # field "Retry-After" in
try
`Seconds(int_of_string s)
with
Failure _ -> `Date(date_of_string "Nethttp.get_retry_after" s)
let set_retry_after mh v =
let s =
match v with
| `Seconds n -> string_of_int n
| `Date d -> string_of_date d in
mh # update_field "Retry-After" s
let get_server mh =
mh # field "Server"
let set_server mh name =
mh # update_field "Server" name
let get_te mh =
q_split
(parse_parameterized_token_list mh "Nethttp.get_te" "TE")
let set_te mh te =
let s =
String.concat ","
(List.map
(fun triple ->
string_of_parameterized_token (q_merge "Nethttp.set_te" triple))
te) in
mh # update_field "TE" s
let get_trailer mh =
parse_token_list mh "Nethttp.get_trailer" "Trailer"
let set_trailer mh fields =
mh # update_field "Trailer" (String.concat "," fields)
let get_transfer_encoding mh =
parse_parameterized_token_list mh "Nethttp.get_transfer_encoding" "Transfer-Encoding"
let set_transfer_encoding mh te =
let s =
String.concat ","
(List.map string_of_parameterized_token te) in
mh # update_field "Transfer-Encoding" s
let get_upgrade mh =
parse_token_list mh "Nethttp.get_upgrade" "Upgrade"
let set_upgrade mh fields =
mh # update_field "Upgrade" (String.concat "," fields)
let get_user_agent mh =
mh # field "User-Agent"
let set_user_agent mh s =
mh # update_field "User-Agent" s
let get_vary mh =
let l = parse_token_list mh "Nethttp.get_vary" "Vary" in
if List.mem "*" l then
`Star
else
`Fields l
let set_vary mh v =
let s =
match v with
| `Star -> "*"
| `Fields l -> String.concat "," l in
mh # update_field "Vary" s
(* --- Authentication --- *)
let parse_challenges mh fn_name fieldname =
let rec parse_auth_params stream =
match Stream.npeek 2 stream with
| [ Atom ap_name; Special '=' ] ->
Stream.junk stream;
Stream.junk stream;
let ap_val = parse_token_or_qstring stream in
let rest = parse_auth_param_rest stream in
(ap_name, ap_val) :: rest
| _ ->
raise Stream.Failure
and parse_auth_param_rest stream =
match Stream.npeek 3 stream with
| [ (Special ','); (Atom ap_name); (Special '=') ] ->
Stream.junk stream;
Stream.junk stream;
Stream.junk stream;
let ap_val = parse_token_or_qstring stream in
let rest = parse_auth_param_rest stream in
(ap_name, ap_val) :: rest
| _ ->
[]
and parse_challenge stream =
match Stream.peek stream with
| Some (Atom auth_scheme) ->
Stream.junk stream;
let auth_params = parse_auth_params stream in
Some(auth_scheme, auth_params)
| _ ->
None
in
parse_comma_separated_field mh fn_name parse_challenge fieldname
let mk_challenges fields =
String.concat ","
(List.map
(fun (auth_name, auth_params) ->
auth_name ^ " " ^
(String.concat ","
(List.map
(fun (p_name, p_val) ->
p_name ^ "=" ^ string_of_value p_val)
auth_params))
)
fields)
let get_www_authenticate mh =
parse_challenges mh "Nethttp.get_www_authenticate" "WWW-Authenticate"
let set_www_authenticate mh fields =
mh # update_field "WWW-Authenticate" (mk_challenges fields)
let get_proxy_authenticate mh =
parse_challenges mh "Nethttp.get_proxy_authenticate" "Proxy-Authenticate"
let set_proxy_authenticate mh fields =
mh # update_field "Proxy-Authenticate" (mk_challenges fields)
let ws_re = Netstring_str.regexp "[ \t\r\n]+";;
let parse_credentials mh fn_name fieldname =
let rec parse_creds stream =
match Stream.peek stream with
| Some (Atom auth_name) ->
Stream.junk stream;
let params = parse_auth_params stream in
(auth_name, params)
| _ ->
raise Stream.Failure
and parse_auth_params stream =
match Stream.npeek 2 stream with
| [ Atom ap_name; Special '=' ] ->
Stream.junk stream;
Stream.junk stream;
let ap_val = parse_token_or_qstring stream in
let rest = parse_auth_param_rest stream in
(ap_name, ap_val) :: rest
| _ ->
raise Stream.Failure
and parse_auth_param_rest stream =
match Stream.npeek 3 stream with
| [ Special ','; Atom ap_name; Special '=' ] ->
Stream.junk stream;
Stream.junk stream;
Stream.junk stream;
let ap_val = parse_token_or_qstring stream in
let rest = parse_auth_param_rest stream in
(ap_name, ap_val) :: rest
| _ ->
[]
in
(* Basic authentication is a special case! *)
let v = mh # field fieldname in (* or Not_found *)
match Netstring_str.split ws_re v with
| [ name; creds ] when String.lowercase name = "basic" ->
("basic", ["credentials", creds])
| _ ->
parse_field mh fn_name parse_creds fieldname
let mk_credentials (auth_name, auth_params) =
if String.lowercase auth_name = "basic" then (
let creds =
try List.assoc "credentials" auth_params
with Not_found ->
failwith "Nethttp.mk_credentials: basic credentials not found" in
"Basic " ^ creds
)
else
auth_name ^ " " ^
(String.concat ","
(List.map
(fun (p_name, p_val) ->
p_name ^ "=" ^ string_of_value p_val)
auth_params))
let get_authorization mh =
parse_credentials mh "Nethttp.get_authorization" "authorization"
let set_authorization mh v =
mh # update_field "Authorization" (mk_credentials v)
let get_proxy_authorization mh =
parse_credentials mh "Nethttp.get_proxy_authorization" "proxy-authorization"
let set_proxy_authorization mh v =
mh # update_field "Proxy-Authorization" (mk_credentials v)
(* --- Cookies --- *)
exception No_equation of string
let split_name_is_value s =
(* Recognizes a string "name=value" and returns the pair (name,value).
* If the string has the wrong format, the function will raise
* No_equation, and the argument of the exception is the unparseable
* string.
*)
try
let p = String.index s '=' in
(String.sub s 0 p, String.sub s (p+1) (String.length s - p - 1))
with
Not_found ->
raise(No_equation s)
let spaces_at_beginning_re = Netstring_str.regexp "^[ \t\r\n]+"
let spaces_at_end_re = Netstring_str.regexp "[ \t\r\n]+$"
let strip_spaces s = (* Remove leading and trailing spaces: *)
Netstring_str.global_replace
spaces_at_end_re ""
(Netstring_str.global_replace
spaces_at_beginning_re "" s)
let split_cookies_re = Netstring_str.regexp "[ \t\r\n]*;[ \t\r\n]*" ;;
let get_cookie mh =
let cstrings = mh # multiple_field "Cookie" in
(* Remove leading and trailing spaces: *)
let cstrings' = List.map strip_spaces cstrings in
let partss = List.map
(fun cstring ->
Netstring_str.split split_cookies_re cstring
)
cstrings' in
let parts = List.flatten partss in
List.map
(fun part ->
let n,v =
try split_name_is_value part
with No_equation _ -> (part, "")
(* Because it is reported that MSIE returns just "n" instead
* of "n=" when the value v is empty
*)
in
let n_dec = Netencoding.Url.decode n in
let v_dec = Netencoding.Url.decode v in
(n_dec, v_dec)
)
parts
let get_cookie_ct =
Cookie.get_cookie_ct
let set_cookie mh l =
let s =
String.concat ";"
(List.map
(fun (n,v) ->
Netencoding.Url.encode n ^ "=" ^ Netencoding.Url.encode v)
l) in
mh # update_field "Cookie" s
let nv_re = Netstring_str.regexp "^\\([^=;]+\\)\\(=\\(.*\\)\\)?$"
let get_set_cookie_1 s =
let nv_list =
List.map
(fun item ->
( match Netstring_str.string_match nv_re item 0 with
| None ->
raise(Bad_header_field "Nethttp.Header.get_set_cookie")
| Some m ->
let name = Netstring_str.matched_group m 1 item in
let value =
try Netstring_str.matched_group m 3 item
with Not_found -> "" in
(name, value)
)
)
(Netstring_str.split split_cookies_re s)
in
match nv_list with
| (n,v) :: params ->
let params =
List.map (fun (n,v) -> (String.lowercase n, v)) params in
{ cookie_name = Netencoding.Url.decode ~plus:false n;
cookie_value = Netencoding.Url.decode ~plus:false v;
cookie_expires = (try
let exp_str = List.assoc "expires" params in
Some(Netdate.since_epoch
(Netdate.parse exp_str))
with
| Not_found -> None);
cookie_domain = ( try
Some(List.assoc "domain" params)
with
| Not_found -> None
);
cookie_path = ( try
Some(List.assoc "path" params)
with
| Not_found -> None
);
cookie_secure = ( try
List.mem_assoc "secure" params
with
| Not_found -> false
)
}
| _ ->
raise(Bad_header_field "Nethttp.Header.get_set_cookie")
let get_set_cookie mh =
let fields = mh # multiple_field "Set-Cookie" in
List.map get_set_cookie_1 fields
let set_set_cookie mh l =
let cookie_fields =
List.map
(fun c ->
let enc_name = Netencoding.Url.encode ~plus:false c.cookie_name in
let enc_value = Netencoding.Url.encode ~plus:false c.cookie_value in
enc_name ^ "=" ^ enc_value ^
( match c.cookie_expires with
None -> ""
| Some t ->
";EXPIRES=" ^ Netdate.mk_usenet_date t
) ^
(match c.cookie_domain with
None -> ""
| Some d ->
";DOMAIN=" ^ d
) ^
(match c.cookie_path with
None -> ""
| Some p ->
";PATH=" ^ p
) ^
if c.cookie_secure then ";SECURE" else ""
)
l
in
mh # update_multiple_field "Set-cookie" cookie_fields
let set_set_cookie_ct =
Cookie.set_set_cookie_ct
end
