1
(* $Id: nethttp.mlp 1588 2011-04-28 13:59:54Z gerd $
2
* ----------------------------------------------------------------------
3
* Nethttp: Basic definitions for the HTTP protocol
6
type protocol_version =
8
type protocol_attribute =
12
[ `Http of (protocol_version * protocol_attribute list)
16
let string_of_protocol =
18
| `Http((m,n),_) -> "HTTP/" ^ string_of_int m ^ "." ^ string_of_int n
19
| `Other -> failwith "string_of_protocol"
21
let http_re = Netstring_str.regexp "HTTP/\\([0-9]+\\)\\.\\([0-9]+\\)$"
23
let protocol_of_string s =
24
match Netstring_str.string_match http_re s 0 with
27
`Http ((int_of_string (Netstring_str.matched_group m 1 s),
28
int_of_string (Netstring_str.matched_group m 2 s)), [])
30
Failure _ -> `Other (* Probably denial-of-service attack! *)
36
(* 1xx: (informational) *)
38
| `Switching_protocols
39
(* 2xx: (successful) *)
47
(* 3xx: (redirection) *)
55
(* 4xx: (client error) *)
63
| `Proxy_auth_required
68
| `Precondition_failed
69
| `Request_entity_too_large
70
| `Request_uri_too_long
71
| `Unsupported_media_type
72
| `Requested_range_not_satisfiable
74
(* 5xx: (server error) *)
75
| `Internal_server_error
78
| `Service_unavailable
80
| `Http_version_not_supported
83
let int_of_http_status =
85
(* 1xx: (informational) *)
87
| `Switching_protocols -> 101
88
(* 2xx: (successful) *)
92
| `Non_authoritative -> 203
94
| `Reset_content -> 205
95
| `Partial_content -> 206
96
(* 3xx: (redirection) *)
97
| `Multiple_choices -> 300
98
| `Moved_permanently -> 301
101
| `Not_modified -> 304
103
| `Temporary_redirect -> 307
104
(* 4xx: (client error) *)
105
| `Bad_request -> 400
106
| `Unauthorized -> 401
107
| `Payment_required -> 402
110
| `Method_not_allowed -> 405
111
| `Not_acceptable -> 406
112
| `Proxy_auth_required -> 407
113
| `Request_timeout -> 408
116
| `Length_required -> 411
117
| `Precondition_failed -> 412
118
| `Request_entity_too_large -> 413
119
| `Request_uri_too_long -> 414
120
| `Unsupported_media_type -> 415
121
| `Requested_range_not_satisfiable -> 416
122
| `Expectation_failed -> 417
123
(* 5xx: (server error) *)
124
| `Internal_server_error -> 500
125
| `Not_implemented -> 501
126
| `Bad_gateway -> 502
127
| `Service_unavailable -> 503
128
| `Gateway_timeout -> 504
129
| `Http_version_not_supported -> 505
132
let string_of_http_status =
134
(* 1xx: (informational) *)
135
| `Continue -> "Continue"
136
| `Switching_protocols -> "Switching Protocols"
137
(* 2xx: (successful) *)
139
| `Created -> "Created"
140
| `Accepted -> "Accepted"
141
| `Non_authoritative -> "Non-authoritative Information"
142
| `No_content -> "No Content"
143
| `Reset_content -> "Reset Content"
144
| `Partial_content -> "Partial Content"
145
(* 3xx: (redirection) *)
146
| `Multiple_choices -> "Multiple Choices"
147
| `Moved_permanently -> "Moved Permanently"
149
| `See_other -> "See Other"
150
| `Not_modified -> "Not Modified"
151
| `Use_proxy -> "Use Proxy"
152
| `Temporary_redirect -> "Temporary Redirect"
153
(* 4xx: (client error) *)
154
| `Bad_request -> "Bad Request"
155
| `Unauthorized -> "Unauthorized"
156
| `Payment_required -> "Payment Required"
157
| `Forbidden -> "Forbidden"
158
| `Not_found -> "Not Found"
159
| `Method_not_allowed -> "Method Not Allowed"
160
| `Not_acceptable -> "Not Acceptable"
161
| `Proxy_auth_required -> "Proxy Authorization Required"
162
| `Request_timeout -> "Request Timeout"
163
| `Conflict -> "Conflict"
165
| `Length_required -> "Length Required"
166
| `Precondition_failed -> "Precondition Failed"
167
| `Request_entity_too_large -> "Request Entity Too Large"
168
| `Request_uri_too_long -> "Request URI Too Long"
169
| `Unsupported_media_type -> "Unsupported Media Type"
170
| `Requested_range_not_satisfiable -> "Request Range Not Satisfiable"
171
| `Expectation_failed -> "Expectation Failed"
172
(* 5xx: (server error) *)
173
| `Internal_server_error -> "Internal Server Error"
174
| `Not_implemented -> "Not Implemented"
175
| `Bad_gateway -> "Bad Gateway"
176
| `Service_unavailable -> "Service Unavailable"
177
| `Gateway_timeout -> "Gateway Timeout"
178
| `Http_version_not_supported -> "HTTP Version Not Supported"
181
let http_status_of_int =
183
(* 1xx: (informational) *)
185
| 101 -> `Switching_protocols
186
(* 2xx: (successful) *)
190
| 203 -> `Non_authoritative
192
| 205 -> `Reset_content
193
| 206 -> `Partial_content
194
(* 3xx: (redirection) *)
195
| 300 -> `Multiple_choices
196
| 301 -> `Moved_permanently
199
| 304 -> `Not_modified
201
| 307 -> `Temporary_redirect
202
(* 4xx: (client error) *)
203
| 400 -> `Bad_request
204
| 401 -> `Unauthorized
205
| 402 -> `Payment_required
208
| 405 -> `Method_not_allowed
209
| 406 -> `Not_acceptable
210
| 407 -> `Proxy_auth_required
211
| 408 -> `Request_timeout
214
| 411 -> `Length_required
215
| 412 -> `Precondition_failed
216
| 413 -> `Request_entity_too_large
217
| 414 -> `Request_uri_too_long
218
| 415 -> `Unsupported_media_type
219
| 416 -> `Requested_range_not_satisfiable
220
| 417 -> `Expectation_failed
221
(* 5xx: (server error) *)
222
| 500 -> `Internal_server_error
223
| 501 -> `Not_implemented
224
| 502 -> `Bad_gateway
225
| 503 -> `Service_unavailable
226
| 504 -> `Gateway_timeout
227
| 505 -> `Http_version_not_supported
228
| _ -> raise Not_found
230
type http_method = string * string
231
(** Method name, URI *)
233
type cache_control_token =
236
| `Max_stale of int option
241
| `Private of string list
242
| `No_cache of string list
246
| `Extension of string * string option
254
let weak_validator_match e1 e2 =
256
| (`Strong s1, `Strong s2) -> s1 = s2
257
| (`Strong s1, `Weak w2) -> s1 = w2
258
| (`Weak w1, `Strong s2) -> w1 = s2
259
| (`Weak w1, `Weak w2) -> w1 = w2
261
let strong_validator_match e1 e2 =
263
| (`Strong s1, `Strong s2) -> s1 = s2
266
exception Bad_header_field of string
268
class type http_header = Netmime.mime_header
269
class type http_header_ro = Netmime.mime_header_ro
270
class type http_trailer = Netmime.mime_header
271
class type http_trailer_ro = Netmime.mime_header_ro
274
type netscape_cookie =
275
{ cookie_name : string;
276
cookie_value : string;
277
cookie_expires : float option;
278
cookie_domain : string option;
279
cookie_path : string option;
280
cookie_secure : bool;
283
type cookie = netscape_cookie
287
Netstring_str.regexp "^\\([0-9]+\\)\\([ \t]+\\(.*\\)\\)?$"
289
let status_of_cgi_header hdr =
292
let status = hdr # field "Status" in
293
( match Netstring_str.string_match status_re status 0 with
295
(int_of_string (Netstring_str.matched_group m 1 status),
296
(try Netstring_str.matched_group m 3 status with Not_found -> "")
299
failwith "Bad Status response header field"
300
(* Don't know what to do *)
304
(* Maybe there is a [Location] header: *)
306
let _location = hdr # field "Location" in
310
(* Default: 200 OK *)
314
(* Repair [phrase] if empty: *)
317
( try string_of_http_status (http_status_of_int code)
318
with Not_found -> "Unknown"
327
Netstring_str.regexp "^\\([^?]*\\)\\?\\(.*\\)$"
329
let decode_query req_uri =
330
match Netstring_str.string_match query_re req_uri 0 with
332
(Netstring_str.matched_group m 1 req_uri,
333
Netstring_str.matched_group m 2 req_uri)
338
Netstring_str.regexp "\\([^]: \t[]+\\)\\(:\\([0-9]+\\)\\)?$" (* CHECK *)
341
Netstring_str.regexp "\\[\\([^ \t]+\\)\\]\\(:\\([0-9]+\\)\\)?$"
343
let split_host_port s =
344
match Netstring_str.string_match host4_re s 0 with
346
let host_name = Netstring_str.matched_group m 1 s in
348
try Some(int_of_string(Netstring_str.matched_group m 3 s))
352
(host_name, host_port)
354
( match Netstring_str.string_match host6_re s 0 with
356
let host_name = Netstring_str.matched_group m 1 s in
358
try Some(int_of_string(Netstring_str.matched_group m 3 s))
362
(host_name, host_port)
364
failwith "Invalid hostname"
367
let uripath_encode s =
368
let l = Neturl.split_path s in
369
let l' = List.map (Netencoding.Url.encode ~plus:false) l in
372
let uripath_decode s =
373
let l = Neturl.split_path s in
377
let u' = Netencoding.Url.decode ~plus:false u in
378
if String.contains u' '/' then
379
failwith "Nethttp.uripath_decode";
384
let rev_split is_cut s =
386
let rec seek_cut acc i0 i1 =
387
if i1 >= String.length s then
388
(String.sub s i0 (i1 - i0)) :: acc
389
else if is_cut(String.unsafe_get s i1) then
390
skip ((String.sub s i0 (i1 - i0)) :: acc) (i1 + 1) (i1 + 1)
392
seek_cut acc i0 (i1 + 1)
394
if i1 >= String.length s then acc
395
else if is_cut(String.unsafe_get s i1) then skip acc i0 (i1 + 1)
396
else seek_cut acc i1 i1 in
400
module Cookie = struct
401
(* This module has been written by Christophe Troestler.
402
For full copyright message see netcgi.ml
405
(* Cookies are chosen to be mutable because they are stored on the
406
client -- there is no rollback possible -- and mutability kind of
410
mutable name : string;
411
mutable value : string;
412
mutable max_age : int option;
413
mutable domain : string option;
414
mutable path : string option;
415
mutable secure : bool;
416
mutable comment : string;
417
mutable comment_url : string;
418
mutable ports : int list option;
421
let make ?max_age ?domain ?path ?(secure=false)
422
?(comment="") ?(comment_url="") ?ports name value =
430
comment_url = comment_url;
434
(* Old version of cookies *)
435
let of_netscape_cookie c =
436
{ name = c.cookie_name;
437
value = c.cookie_value;
438
max_age = (match c.cookie_expires with
440
| Some t -> Some(truncate(t -. Unix.time())));
441
domain = c.cookie_domain;
442
path = c.cookie_path;
443
secure = c.cookie_secure;
448
let to_netscape_cookie cookie =
449
{ cookie_name = cookie.name;
450
cookie_value = cookie.value;
451
cookie_expires = (match cookie.max_age with
453
| Some t -> Some(float t +. Unix.time()));
454
cookie_domain = cookie.domain;
455
cookie_path = cookie.path;
456
cookie_secure = cookie.secure;
459
let name cookie = cookie.name
460
let value cookie = cookie.value
461
let max_age cookie = cookie.max_age
462
let domain cookie = cookie.domain
463
let path cookie = cookie.path
464
let secure cookie = cookie.secure
465
let comment cookie = cookie.comment
466
let comment_url cookie = cookie.comment_url
467
let ports cookie = cookie.ports
469
let set_value cookie v = cookie.value <- v
470
let set_max_age cookie t = cookie.max_age <- t
471
let set_domain cookie dom = cookie.domain <- dom
472
let set_path cookie s = cookie.path <- s
473
let set_secure cookie b = cookie.secure <- b
474
let set_comment cookie s = cookie.comment <- s
475
let set_comment_url cookie s = cookie.comment_url <- s
476
let set_ports cookie p = cookie.ports <- p
478
(* Set -------------------------------------------------- *)
480
(* Escape '"', '\\',... and surround the string with quotes. *)
482
let len = String.length s0 in
483
let encoded_length = ref len in
484
for i = 0 to len - 1 do
485
match String.unsafe_get s0 i with
486
| '\"' | '\\' | '\n' | '\r' -> incr encoded_length
487
| '\000' .. '\031' -> decr encoded_length (* ignore *)
490
let s = String.create (!encoded_length + 2) in
491
String.unsafe_set s 0 '\"';
493
for i = 0 to len - 1 do
494
(match String.unsafe_get s0 i with
495
| '\"' | '\\' as c ->
496
String.unsafe_set s !j '\\'; incr j;
497
String.unsafe_set s !j c; incr j
499
String.unsafe_set s !j '\\'; incr j;
500
String.unsafe_set s !j 'n'; incr j
502
String.unsafe_set s !j '\\'; incr j;
503
String.unsafe_set s !j 'r'; incr j
504
| '\000' .. '\031' ->
505
() (* Ignore these control chars, useless for comments *)
507
String.unsafe_set s !j c; incr j
510
String.unsafe_set s !j '\"';
513
(* [gen_cookie c] returns a buffer containing an attribute suitable
514
for "Set-Cookie" (RFC 2109) and "Set-Cookie2" (RFC 2965).
515
which is backward compatible with Netscape spec. It is the
516
minimal denominator. *)
518
let buf = Buffer.create 128 in
519
(* Encode, do not quote, key-val for compatibility with old browsers. *)
520
Buffer.add_string buf (Netencoding.Url.encode ~plus:false c.name);
521
Buffer.add_string buf "=";
522
Buffer.add_string buf (Netencoding.Url.encode ~plus:false c.value);
523
Buffer.add_string buf ";Version=1";
524
(* FIXME: Although values of Domain and Path can be quoted since
525
RFC2109, it seems that browsers do not understand them -- they
526
take the quotes as part of the value. One way to get correct
527
headers is to strip [d] and [p] of unsafe chars -- if they have any. *)
531
Buffer.add_string buf ";Domain=";
532
Buffer.add_string buf d);
536
Buffer.add_string buf ";Path=";
537
Buffer.add_string buf p);
538
if c.secure then Buffer.add_string buf ";secure";
539
(match c.max_age with
542
Buffer.add_string buf ";Max-Age=";
543
Buffer.add_string buf (if s > 0 then string_of_int s else "0");
544
(* For compatibility with old browsers: *)
545
Buffer.add_string buf ";Expires=";
546
Buffer.add_string buf
547
(if s > 0 then Netdate.mk_mail_date (Unix.time() +. float s)
548
else "Thu, 1 Jan 1970 00:00:00 GMT");
550
if c.comment <> "" then (
551
Buffer.add_string buf ";Comment=";
552
Buffer.add_string buf (escape c.comment);
557
let set_set_cookie_ct (http_header:#Netmime.mime_header) cookies =
558
let add_cookie (c1, c2) c =
559
let buf = gen_cookie c in
560
(* In any case, we set a "Set-Cookie" header *)
561
let c1 = (Buffer.contents buf) :: c1 in
563
if c.comment_url = "" && c.ports = None then c2 else (
564
(* When this is relevant, also set a "Set-Cookie2" header *)
565
if c.comment_url <> "" then (
566
Buffer.add_string buf ";CommentURL=";
567
Buffer.add_string buf (escape c.comment_url));
571
Buffer.add_string buf ";Port=\"";
572
Buffer.add_string buf (String.concat ","
573
(List.map string_of_int p));
574
Buffer.add_string buf "\""
576
(Buffer.contents buf) :: c2
579
let cookie, cookie2 = List.fold_left add_cookie ([], []) cookies in
580
http_header#update_multiple_field "Set-Cookie" cookie;
581
(* "Set-Cookie2" must come after in order, when they are
582
understood, to override the "Set-Cookie". *)
583
http_header#update_multiple_field "Set-Cookie2" cookie2
586
(* Get -------------------------------------------------- *)
588
(* According to RFC 2068:
589
quoted-string = ( <"> *(qdtext) <"> )
590
qdtext = <any TEXT except '\"'>
591
quoted-pair = "\\" CHAR
592
As there a no details, we decode the usual escapes and treat
593
other "\x" as simply "x". *)
594
let unescape_range s low up =
595
if low >= up then "" else
596
let len = up - low in
597
let s = String.sub s low len in
600
match String.unsafe_get s i with
604
(match String.unsafe_get s i with
605
| '\"' | '\\' as c -> String.unsafe_set s j c
606
| 'n' -> String.unsafe_set s j '\n'
607
| 'r' -> String.unsafe_set s j '\r'
608
| 't' -> String.unsafe_set s j '\t'
609
| c -> String.unsafe_set s j c
611
decode (i + 1) (j + 1)
615
String.unsafe_set s j c;
616
decode (i + 1) (j + 1)
619
let j = decode 0 0 in
620
if j < len then String.sub s 0 j else s
623
let ports_of_string s =
624
let l = rev_split (fun c -> c = ',' || c = ' ') s in
625
List.fold_left (fun pl p ->
626
try int_of_string p :: pl with _ -> pl) [] l
628
(* Given a new key-val data, update the list of cookies accordingly
629
(new cookie or update attributes of the current one). *)
630
let add_key_val key value cl =
631
if key <> "" && String.unsafe_get key 0 = '$' then
632
(* Keys starting with '$' are for control; ignore the ones we do
637
(if key = "$Path" then c.path <- Some value
638
else if key = "$Domain" then c.domain <- Some value
639
else if key = "$Port" then
640
c.ports <- Some (ports_of_string value));
643
else make key value :: cl
646
let decode_range s start _end =
647
Netencoding.Url.decode ~pos:start ~len:(_end - start) s
649
(* The difference between version 0 and version 1 cookies is that
650
the latter start with $Version (present 1st or omitted). Our
651
decoding function can handle both versions transparently, so
652
$Version is ignored. In the absence of "=", the string is
653
treated as the VALUE. *)
655
(* [get_key cs i0 i len] scan the cookie string [cs] and get the
656
key-val pairs. keys and values are stripped of heading and
657
trailing spaces, except for quoted values. *)
658
let rec get_key cs i0 i len cl =
660
let value = decode_range cs i0 len in
661
if value = "" then cl else make "" value :: cl
663
match String.unsafe_get cs i with
665
(* No "=", interpret as a value as Mozilla does. We choose
666
this over MSIE which is reported to return just "n"
667
instead of "n=" when the value is empty. *)
668
let cl = make "" (decode_range cs i0 i) :: cl in
669
skip_space_before_key cs (i + 1) len cl
672
skip_value_space cs i1 len (decode_range cs i0 i) cl
674
get_key cs i0 (i + 1) len cl
675
and skip_space_before_key cs i len cl =
678
match String.unsafe_get cs i with
679
| ' ' | '\t' | '\n' | '\r' -> skip_space_before_key cs (i + 1) len cl
680
| _ -> get_key cs i i len cl
681
and skip_value_space cs i len key cl =
682
if i >= len then add_key_val key "" cl (* no value *)
684
match String.unsafe_get cs i with
685
| ' ' | '\t' | '\n' | '\r' -> (* skip linear white space *)
686
skip_value_space cs (i + 1) len key cl
688
get_quoted_value cs (i + 1) (i + 1) len key cl
690
get_value cs i i len key cl
691
and get_value cs i0 i len key cl =
692
if i >= len then add_key_val key (decode_range cs i0 len) cl
694
match String.unsafe_get cs i with
696
let cl = add_key_val key (decode_range cs i0 i) cl in
697
(* Usually there is a space after ';' to skip *)
698
skip_space_before_key cs (i + 1) len cl
700
get_value cs i0 (i + 1) len key cl
701
and get_quoted_value cs i0 i len key cl =
702
if i >= len then (* quoted string not closed; try anyway *)
703
add_key_val key (unescape_range cs i0 len) cl
705
match String.unsafe_get cs i with
706
| '\\' -> get_quoted_value cs i0 (i + 2) len key cl
708
let cl = add_key_val key (unescape_range cs i0 i) cl in
709
skip_to_next cs (i + 1) len cl
710
| _ -> get_quoted_value cs i0 (i + 1) len key cl
711
and skip_to_next cs i len cl =
714
match String.unsafe_get cs i with
715
| ',' | ';' -> skip_space_before_key cs (i + 1) len cl
716
| _ -> skip_to_next cs (i + 1) len cl
720
let get_cookie_ct (http_header:#http_header_ro) =
721
let cookies = http_header#multiple_field "Cookie" in
722
let cl = List.fold_left
723
(fun cl cs -> get_key cs 0 0 (String.length cs) cl) [] cookies in
724
(* The order of cookies is important for the Netscape ones since
725
"more specific path mapping should be sent before cookies with
726
less specific path mappings" -- for those, there will be only a
727
single "Cookie" line. *)
732
module Header = struct
736
(* As scanner we use the scanner for mail header fields from Mimestring. It
737
* is very configurable.
740
let std_special_chars =
742
(* CHECK: Maybe we should add more characters, e.g. '@'. They are not
743
* used in HTTP, and including them here would cause that field values
744
* containing them are rejected. Maybe we want that.
747
let scan_value ?(specials = std_special_chars) s =
748
let scanner = create_mime_scanner ~specials ~scan_options:[] s in
751
Some (snd (scan_token scanner)))
753
(* ---- Parser combinators for stream parsers: ---- *)
755
let rec parse_comma_separated_list subparser stream =
756
(* The [subparser] is required to return its value when it finds a
757
* comma (i.e. [Special ','], or when it finds [End]. These tokens
758
* must not be swallowed.
760
match stream with parser
761
| [< expr = subparser; rest = parse_comma_separated_rest subparser >] ->
766
and parse_comma_separated_rest subparser stream =
767
match stream with parser
768
| [< '(Special ','); _ = parse_commas; list = parse_comma_separated_list subparser >] ->
773
and parse_commas stream =
774
match stream with parser
775
| [< '(Special ','); _ = parse_commas >] ->
780
let merge_lists mh fieldparser fieldname =
781
let fields = mh # multiple_field fieldname in
782
if fields = [] then raise Not_found;
783
List.flatten (List.map fieldparser fields)
785
let parse_field mh fn_name f_parse fieldname =
787
let field = mh # field fieldname in
788
f_parse (scan_value field)
792
raise (Bad_header_field fn_name)
794
let parse_comma_separated_field ?specials mh fn_name f_parse fieldname =
795
let fieldparser field =
797
parse_comma_separated_list f_parse (scan_value ?specials field)
801
raise (Bad_header_field fn_name) in
802
merge_lists mh fieldparser fieldname
804
(* ----- Common parsers/printer: ---- *)
806
let parse_token_list mh fn_name fieldname =
807
let parse_token stream =
808
match stream with parser
809
| [< '(Atom tok) >] -> tok
811
parse_comma_separated_field mh fn_name parse_token fieldname
813
let parse_token_or_qstring stream =
814
match stream with parser
815
| [< '(Atom tok) >] -> tok
816
| [< '(QString v) >] -> v
818
let rec parse_params stream =
819
match stream with parser
821
'(Atom name); '(Special '='); v = parse_token_or_qstring;
828
let parse_extended_token_list mh fn_name fieldname =
829
(* token [ '=' (token|qstring) ( ';' token '=' (token|qstring) ) * ] *)
830
let rec parse_extended_token stream =
831
match stream with parser
832
| [< '(Atom tok); extension = parse_equation >] ->
833
( match extension with
834
Some (eq_val, params) ->
835
(tok, Some eq_val, params)
839
and parse_equation stream =
840
match stream with parser
841
| [< '(Special '='); v = parse_token_or_qstring; params = parse_params >] ->
846
parse_comma_separated_field mh fn_name parse_extended_token fieldname
848
let qstring_indicator_re =
849
Netstring_str.regexp "[]\\\"()<>@,;:/[?={} \x00-\x1f\x7f]"
850
(* Netstring_pcre.regexp "[\\\\\"()<>@,;:/[\\]?={} \\x00-\\x1f\\x7f]" *)
853
Netstring_str.regexp "[\\\"]"
854
(* Netstring_pcre.regexp "[\\\\\\\"]" *)
856
let qstring_of_value s =
857
(* Returns a qstring *)
858
"\"" ^ Netstring_str.global_replace qstring_re "\\\\\\0" s ^ "\""
859
(* Escape qstring_re with a backslash *)
861
let string_of_value s =
862
(* Returns a token or a qstring, depending on the value of [s] *)
864
ignore(Netstring_str.search_forward qstring_indicator_re s 0);
869
let string_of_params l =
878
n ^ "=" ^ string_of_value s)
881
let string_of_extended_token fn_name =
887
| (tok, Some eq_val, params) ->
888
tok ^ "=" ^ eq_val ^ string_of_params params
890
let parse_parameterized_token_list mh fn_name fieldname =
891
(* token ( ';' token '=' (token|qstring) ) * *)
892
let rec parse_parameterized_token stream =
893
match stream with parser
894
| [< '(Atom tok); params = parse_params >] ->
897
parse_comma_separated_field mh fn_name parse_parameterized_token fieldname
899
let string_of_parameterized_token (tok, params) =
900
tok ^ string_of_params params
902
let q_split ( l : (string * (string * string) list) list )
903
: (string * (string * string) list * (string * string) list) list
905
(* Find the "q" param, and split [params] at that position *)
906
let rec split params =
909
| ("q", q) :: rest -> ([], params)
911
let before, after = split rest in
912
(other :: before), after
915
(fun (tok, params) ->
916
let before, after = split params in
917
(tok, before, after))
920
let q_merge fn_name (tok, params, q_params) =
921
if List.mem_assoc "q" params then invalid_arg fn_name;
922
( match q_params with
925
(tok, (params @ q_params))
931
let date_of_string fn_name s =
933
Netdate.parse_epoch s
935
Invalid_argument _ ->
936
raise(Bad_header_field fn_name)
938
let string_of_date f =
939
Netdate.format ~fmt:"%a, %d %b %Y %H:%M:%S GMT" (Netdate.create ~zone:0 f)
941
let sort_by_q ?(default=1.0) toks_with_params =
942
(* Sorts [toks_with_params] such that the highest [q] values come first.
943
* Tokens with a [q] value of 0 are removed. Tokens without [q] value
944
* are assumed to have the [default] value. This is also done with
945
* unparseable [q] values.
950
(fun (q1, tok_param1) (q2, tok_param2) ->
951
Pervasives.compare q2 q1)
953
(fun (q, tok_param) ->
956
(fun (tok, params) ->
958
let q_str = List.assoc "q" params in
959
(float_of_string q_str, (tok, params))
961
| Not_found -> (default, (tok, params))
962
| Failure _ -> (default, (tok, params))
966
let sort_by_q' ?default tok_with_params_and_qparams =
968
(fun ((tok, tok_params), q_params) -> (tok, tok_params, q_params))
972
(fun (tok, tok_params, q_params) -> ((tok, tok_params), q_params))
973
tok_with_params_and_qparams))
975
(* ---- The field accessors: ---- *)
979
(parse_parameterized_token_list mh "Nethttp.get_accept" "Accept")
981
let set_accept mh av =
986
string_of_parameterized_token (q_merge "Nethttp.set_accept" triple))
988
mh # update_field "Accept" s
990
let best_media_type mh supp =
992
(* All of [supp] not mentioned in the [Accept] field *)
993
let toks = try get_accept mh with Not_found -> [] in
994
List.filter (fun supp_type ->
995
not (List.exists (fun (t,_,_) -> t=supp_type) toks)) supp
997
let rec find_best toks =
999
| (tok, params, qparams) :: toks' ->
1000
( if List.mem tok supp then
1003
let (main_type, sub_type) = Mimestring.split_mime_type tok in
1004
if sub_type = "*" then (
1008
(main_type = "*") ||
1010
main_type = fst(Mimestring.split_mime_type supp_type))
1015
Not_found -> find_best toks'
1017
else find_best toks'
1020
(* Nothing acceptable: *)
1024
let mt_list = sort_by_q' (get_accept mh) in (* or Not_found *)
1027
Not_found -> ("*/*", [])
1029
let get_accept_charset mh =
1030
parse_parameterized_token_list mh
1031
"Nethttp.get_accept_charset" "Accept-Charset"
1033
let set_accept_charset mh l =
1036
(String.concat "," (List.map string_of_parameterized_token l))
1038
let best_tok_of_list toks supp =
1041
(fun tok -> tok = "*" || List.mem tok supp)
1044
List.find (fun tok -> not (List.mem tok toks)) supp
1048
let best_charset mh supp =
1050
let toks_with_params = get_accept_charset mh in (* or Not_found *)
1051
(* Special handling of ISO-8859-1: *)
1052
let toks_with_params' =
1053
if not(List.mem_assoc "*" toks_with_params) &&
1055
(fun (tok,_) -> String.lowercase tok = "iso-8859-1")
1058
toks_with_params @ [ "ISO-8859-1", ["q", "1.0"] ]
1061
let toks' = List.map fst (sort_by_q toks_with_params') in
1062
best_tok_of_list toks' supp
1066
let get_accept_encoding mh =
1067
parse_parameterized_token_list mh
1068
"Nethttp.get_accept_encoding" "Accept-Encoding"
1070
let set_accept_encoding mh l =
1073
(String.concat "," (List.map string_of_parameterized_token l))
1075
let best_encoding mh supp =
1077
let toks_with_params = sort_by_q (get_accept_encoding mh) in
1078
best_tok_of_list (List.map fst toks_with_params) supp
1080
Not_found -> "identity"
1082
let get_accept_language mh =
1083
parse_parameterized_token_list mh
1084
"Nethttp.get_accept_language" "Accept-Language"
1086
let set_accept_language mh l =
1089
(String.concat "," (List.map string_of_parameterized_token l))
1091
let get_accept_ranges mh =
1092
parse_token_list mh "Nethttp.get_accept_ranges" "Accept-Ranges"
1094
let set_accept_ranges mh toks =
1095
mh # update_field "Accept-Ranges" (String.concat "," toks)
1099
float_of_string (mh # field "Age")
1101
Failure _ -> raise(Bad_header_field "Nethttp.get_age")
1104
mh # update_field "Age" (Printf.sprintf "%0.f" v)
1107
parse_token_list mh "Nethttp.get_allow" "Allow"
1109
let set_allow mh toks =
1110
mh # update_field "Allow" (String.concat "," toks)
1112
let comma_split_re = Netstring_str.regexp "\\([ \t]*,\\)+[ \t]*"
1115
Netstring_str.split comma_split_re
1117
let parse_opt_eq_token stream =
1118
match stream with parser
1119
| [< '(Special '=');
1121
match stream with parser
1122
| [< '(Atom v) >] -> v
1123
| [< '(QString v) >] -> v);
1127
let parse_cc_directive stream =
1128
match stream with parser
1129
| [< '(Atom "no-cache"); name_opt = parse_opt_eq_token >] ->
1130
( match name_opt with
1131
| None -> `No_cache []
1132
| Some names -> `No_cache(comma_split names)
1134
| [< '(Atom "no-store") >] ->
1136
| [< '(Atom "max-age"); '(Special '='); '(Atom seconds) >] ->
1137
`Max_age(int_of_string seconds)
1138
| [< '(Atom "max-stale"); delta_opt = parse_opt_eq_token >] ->
1139
( match delta_opt with
1140
| None -> `Max_stale None
1141
| Some seconds -> `Max_stale(Some(int_of_string seconds))
1143
| [< '(Atom "min-fresh"); '(Special '='); '(Atom seconds) >] ->
1144
`Min_fresh(int_of_string seconds)
1145
| [< '(Atom "no-transform") >] ->
1147
| [< '(Atom "only-if-cached") >] ->
1149
| [< '(Atom "public") >] ->
1151
| [< '(Atom "private"); name_opt = parse_opt_eq_token >] ->
1152
( match name_opt with
1153
| None -> `Private []
1154
| Some names -> `Private(comma_split names)
1156
| [< '(Atom "must-revalidate") >] ->
1158
| [< '(Atom "proxy-revalidate") >] ->
1160
| [< '(Atom "s-maxage"); '(Special '='); '(Atom seconds)>] ->
1161
`S_maxage(int_of_string seconds)
1162
| [< '(Atom extension); val_opt = parse_opt_eq_token >] ->
1163
`Extension(extension, val_opt)
1165
let get_cache_control mh =
1166
parse_comma_separated_field
1167
mh "Nethttp.get_cache_control" parse_cc_directive "Cache-Control"
1169
let set_cache_control mh l =
1174
| `No_store -> "no-store"
1175
| `Max_age n -> "max-age=" ^ string_of_int n
1176
| `Max_stale None -> "max-stale"
1177
| `Max_stale(Some n) -> "max-stale=" ^ string_of_int n
1178
| `Min_fresh n -> "min-fresh=" ^ string_of_int n
1179
| `No_transform -> "no-transform"
1180
| `Only_if_cached -> "only-if-cached"
1181
| `Public -> "public"
1182
| `Private names -> "private=\"" ^ String.concat "," names ^ "\""
1183
| `No_cache [] -> "no-cache"
1184
| `No_cache names -> "no-cache=\"" ^ String.concat "," names ^ "\""
1185
| `Must_revalidate -> "must-revalidate"
1186
| `Proxy_revalidate -> "proxy-revalidate"
1187
| `S_maxage n -> "s-maxage=" ^ string_of_int n
1188
| `Extension(tok,None) -> tok
1189
| `Extension(tok, Some param) -> tok ^ "=" ^ string_of_value param
1192
mh # update_field "Cache-Control" s
1194
let get_connection mh =
1195
parse_token_list mh "Nethttp.get_connection" "Connection"
1197
let set_connection mh toks =
1198
mh # update_field "Connection" (String.concat "," toks)
1200
let get_content_encoding mh =
1201
parse_token_list mh "Nethttp.get_content_encoding" "Content-Encoding"
1203
let set_content_encoding mh toks =
1204
mh # update_field "Content-Encoding" (String.concat "," toks)
1206
let get_content_language mh =
1207
parse_token_list mh "Nethttp.get_content_language" "Content-Language"
1209
let set_content_language mh toks =
1210
mh # update_field "Content-Language" (String.concat "," toks)
1212
let get_content_length mh =
1214
Int64.of_string (mh # field "Content-Length")
1216
Failure _ -> raise (Bad_header_field "Nethttp.get_content_length")
1218
let set_content_length mh n =
1219
mh # update_field "Content-Length" (Int64.to_string n)
1221
let get_content_location mh =
1222
mh # field "Content-Location"
1224
let set_content_location mh s =
1225
mh # update_field "Content-Location" s
1227
let get_content_md5 mh =
1228
mh # field "Content-MD5"
1230
let set_content_md5 mh s =
1231
mh # update_field "Content-MD5" s
1233
let parse_byte_range_resp_spec stream =
1234
match stream with parser
1235
| [< '(Special '*') >] ->
1237
| [< '(Atom first); '(Special '-'); '(Atom last) >] ->
1238
Some(Int64.of_string first, Int64.of_string last)
1240
let parse_byte_range_resp_length stream =
1241
match stream with parser
1242
| [< '(Special '*') >] ->
1244
| [< '(Atom length) >] ->
1245
Some(Int64.of_string length)
1247
let parse_content_range_spec stream =
1248
match stream with parser
1249
| [< '(Atom "bytes");
1250
br=parse_byte_range_resp_spec;
1252
l=parse_byte_range_resp_length;
1257
let get_content_range mh =
1258
let s = mh # field "Content-Range" in
1259
let stream = scan_value ~specials:[ ','; ';'; '='; '*'; '-'; '/' ] s in
1261
parse_content_range_spec stream
1266
raise (Bad_header_field "Nethttp.get_content_range")
1268
let set_content_range mh (`Bytes(range_opt,length_opt)) =
1270
( match range_opt with
1271
| Some (first,last) -> Int64.to_string first ^ "-" ^ Int64.to_string last
1274
( match length_opt with
1275
| Some length -> Int64.to_string length
1278
mh # update_field "Content-Range" s
1280
let get_content_type mh =
1283
(parse_parameterized_token_list mh
1284
"Nethttp.get_content_type" "Content-Type")
1286
Failure _ -> raise(Bad_header_field "Nethttp.get_content_type")
1288
let set_content_type mh (tok,params) =
1291
(string_of_parameterized_token (tok,params))
1294
date_of_string "Nethttp.get_date" (mh # field "Date")
1297
mh # update_field "Date" (string_of_date d)
1299
let parse_etag_token stream =
1300
match stream with parser
1301
| [< '(Atom "W"); '(Special '/'); '(QString e) >] ->
1303
| [< '(QString e) >] ->
1306
let parse_etag stream =
1307
match stream with parser
1308
| [< etag=parse_etag_token; 'End >] -> etag
1311
let s = mh # field "ETag" in
1312
let stream = scan_value ~specials:[ ','; ';'; '='; '/' ] s in
1313
try parse_etag stream
1318
raise (Bad_header_field "Nethttp.get_etag")
1320
let string_of_etag =
1322
| `Weak s -> "W/" ^ qstring_of_value s
1323
| `Strong s -> qstring_of_value s
1325
let set_etag mh etag =
1326
mh # update_field "ETag" (string_of_etag etag)
1329
parse_extended_token_list mh "Nethttp.get_expect" "Expect"
1331
let set_expect mh expectation =
1332
mh # update_field "Expect"
1334
(List.map (string_of_extended_token "Nethttp.set_expect") expectation))
1336
let get_expires mh =
1337
date_of_string "Nethttp.get_expires" (mh # field "Expires")
1339
let set_expires mh d =
1340
mh # update_field "Expires" (string_of_date d)
1346
mh # update_field "From" v
1349
let s = mh # field "Host" in
1353
| Failure _ -> raise(Bad_header_field "Nethttp.get_host")
1355
let set_host mh (host,port_opt) =
1358
( match port_opt with Some p -> ":" ^ string_of_int p | None -> "") in
1359
mh # update_field "Host" s
1361
let parse_etag_or_star_tok stream =
1362
match stream with parser
1363
| [< '(Special '*') >] -> None
1364
| [< etag=parse_etag_token >] -> Some etag
1366
let get_etag_list mh fn_name fieldname =
1367
let specials = [ ','; ';'; '='; '/'; '*' ] in
1369
parse_comma_separated_field
1370
~specials mh fn_name parse_etag_or_star_tok fieldname in
1371
if List.mem None l then
1374
Some(List.map (function Some e -> e | None -> assert false) l)
1376
let set_etag_list mh fieldname l_opt =
1381
String.concat "," (List.map string_of_etag l) in
1382
mh # update_field fieldname v
1384
let get_if_match mh =
1385
get_etag_list mh "Nethttp.get_if_match" "If-Match"
1387
let set_if_match mh =
1388
set_etag_list mh "If-Match"
1390
let get_if_modified_since mh =
1391
date_of_string "Nethttp.get_if_modified_since" (mh # field "If-Modified-Since")
1393
let set_if_modified_since mh d =
1394
mh # update_field "If-Modified-Since" (string_of_date d)
1396
let get_if_none_match mh =
1397
get_etag_list mh "Nethttp.get_if_none_match" "If-None-Match"
1399
let set_if_none_match mh =
1400
set_etag_list mh "If-None-Match"
1402
let get_if_range mh =
1403
let s = mh # field "If-Range" in
1404
let stream = scan_value ~specials:[ ','; ';'; '='; '/' ] s in
1405
try `Etag (parse_etag stream)
1410
`Date (date_of_string "Nethttp.get_if_range" s)
1412
let set_if_range mh v =
1415
| `Etag e -> string_of_etag e
1416
| `Date d -> string_of_date d in
1417
mh # update_field "If-Range" s
1419
let get_if_unmodified_since mh =
1420
date_of_string "Nethttp.get_if_unmodified_since"
1421
(mh # field "If-Unmodified-Since")
1423
let set_if_unmodified_since mh d =
1424
mh # update_field "If-Unmodified-Since" (string_of_date d)
1426
let get_last_modified mh =
1427
date_of_string "Nethttp.get_last_modified" (mh # field "Last-Modified")
1429
let set_last_modified mh d =
1430
mh # update_field "Last-Modified" (string_of_date d)
1432
let get_location mh =
1433
mh # field "Location"
1435
let set_location mh s =
1436
mh # update_field "Location" s
1438
let get_max_forwards mh =
1440
int_of_string (mh # field "Max-Forwards")
1442
Failure _ -> raise(Bad_header_field "Nethttp.get_max_forwards")
1444
let set_max_forwards mh n =
1445
mh # update_field "Max-Forwards" (string_of_int n)
1447
let parse_pragma_directive stream =
1448
match stream with parser
1449
| [< '(Atom tok); param_opt = parse_opt_eq_token >] -> (tok, param_opt)
1452
parse_comma_separated_field
1453
mh "Nethttp.get_pragma" parse_pragma_directive "Pragma"
1455
let set_pragma mh l =
1460
| (tok, None) -> tok
1461
| (tok, Some param) -> tok ^ "=" ^ string_of_value param)
1463
mh # update_field "Pragma" s
1465
let parse_opt_last_pos stream =
1466
match stream with parser
1467
| [< '(Atom last) >] -> Some(Int64.of_string last)
1470
let rec parse_byte_range_spec stream =
1471
match stream with parser
1472
| [< '(Atom first); '(Special '-'); last=parse_opt_last_pos;
1473
r=parse_byte_range_spec_rest
1475
(Some (Int64.of_string first), last) :: r
1476
| [< '(Special '-'); '(Atom suffix_length);
1477
r=parse_byte_range_spec_rest
1479
(None, Some(Int64.of_string suffix_length)) :: r
1483
and parse_byte_range_spec_rest stream =
1484
match stream with parser
1485
| [< '(Special ','); _=parse_commas; r=parse_byte_range_spec >] -> r
1488
let parse_ranges_specifier stream =
1489
match stream with parser
1490
| [< '(Atom "bytes");
1492
r=parse_byte_range_spec;
1498
let s = mh # field "Range" in
1499
let stream = scan_value ~specials:[ ','; ';'; '='; '*'; '-'; '/' ] s in
1501
parse_ranges_specifier stream
1506
raise (Bad_header_field "Nethttp.get_range")
1508
let set_range mh (`Bytes l) =
1514
| (Some first, Some last) ->
1515
Int64.to_string first ^ "-" ^ Int64.to_string last
1516
| (Some first, None) ->
1517
Int64.to_string first ^ "-"
1518
| (None, Some last) ->
1519
"-" ^ Int64.to_string last
1521
invalid_arg "Nethttp.set_range")
1523
mh # update_field "Range" s
1525
let get_referer mh =
1526
mh # field "Referer"
1528
let get_referrer = get_referer
1530
let set_referer mh s =
1531
mh # update_field "Referer" s
1533
let set_referrer = set_referer
1535
let get_retry_after mh =
1536
let s = mh # field "Retry-After" in
1538
`Seconds(int_of_string s)
1540
Failure _ -> `Date(date_of_string "Nethttp.get_retry_after" s)
1542
let set_retry_after mh v =
1545
| `Seconds n -> string_of_int n
1546
| `Date d -> string_of_date d in
1547
mh # update_field "Retry-After" s
1552
let set_server mh name =
1553
mh # update_field "Server" name
1557
(parse_parameterized_token_list mh "Nethttp.get_te" "TE")
1564
string_of_parameterized_token (q_merge "Nethttp.set_te" triple))
1566
mh # update_field "TE" s
1568
let get_trailer mh =
1569
parse_token_list mh "Nethttp.get_trailer" "Trailer"
1571
let set_trailer mh fields =
1572
mh # update_field "Trailer" (String.concat "," fields)
1574
let get_transfer_encoding mh =
1575
parse_parameterized_token_list mh "Nethttp.get_transfer_encoding" "Transfer-Encoding"
1577
let set_transfer_encoding mh te =
1580
(List.map string_of_parameterized_token te) in
1581
mh # update_field "Transfer-Encoding" s
1583
let get_upgrade mh =
1584
parse_token_list mh "Nethttp.get_upgrade" "Upgrade"
1586
let set_upgrade mh fields =
1587
mh # update_field "Upgrade" (String.concat "," fields)
1589
let get_user_agent mh =
1590
mh # field "User-Agent"
1592
let set_user_agent mh s =
1593
mh # update_field "User-Agent" s
1596
let l = parse_token_list mh "Nethttp.get_vary" "Vary" in
1597
if List.mem "*" l then
1606
| `Fields l -> String.concat "," l in
1607
mh # update_field "Vary" s
1610
(* --- Authentication --- *)
1612
let parse_challenges mh fn_name fieldname =
1613
let rec parse_auth_params stream =
1614
match stream with parser
1615
| [< '(Atom ap_name); '(Special '='); ap_val = parse_token_or_qstring;
1616
rest = parse_auth_param_rest
1618
(ap_name, ap_val) :: rest
1620
and parse_auth_param_rest stream =
1621
match Stream.npeek 3 stream with
1622
| [ (Special ','); (Atom _); (Special '=') ] ->
1623
( match stream with parser
1624
| [< '(Special ',');
1625
'(Atom ap_name); '(Special '=');
1626
ap_val = parse_token_or_qstring;
1627
rest = parse_auth_param_rest
1629
(ap_name, ap_val) :: rest
1630
| [< >] -> (* should not happen... *)
1636
and parse_challenge stream =
1637
match stream with parser
1638
| [< '(Atom auth_scheme); auth_params = parse_auth_params >] ->
1639
(auth_scheme, auth_params)
1641
parse_comma_separated_field mh fn_name parse_challenge fieldname
1643
let mk_challenges fields =
1646
(fun (auth_name, auth_params) ->
1650
(fun (p_name, p_val) ->
1651
p_name ^ "=" ^ string_of_value p_val)
1656
let get_www_authenticate mh =
1657
parse_challenges mh "Nethttp.get_www_authenticate" "WWW-Authenticate"
1659
let set_www_authenticate mh fields =
1660
mh # update_field "WWW-Authenticate" (mk_challenges fields)
1662
let get_proxy_authenticate mh =
1663
parse_challenges mh "Nethttp.get_proxy_authenticate" "Proxy-Authenticate"
1665
let set_proxy_authenticate mh fields =
1666
mh # update_field "Proxy-Authenticate" (mk_challenges fields)
1668
let ws_re = Netstring_str.regexp "[ \t\r\n]+";;
1670
let parse_credentials mh fn_name fieldname =
1671
let rec parse_creds stream =
1672
match stream with parser
1673
| [< '(Atom auth_name);
1674
params = parse_auth_params
1678
and parse_auth_params stream =
1679
match stream with parser
1680
| [< '(Atom ap_name); '(Special '='); ap_val = parse_token_or_qstring;
1681
rest = parse_auth_param_rest
1683
(ap_name, ap_val) :: rest
1685
and parse_auth_param_rest stream =
1686
match stream with parser
1687
| [< '(Special ',');
1688
'(Atom ap_name); '(Special '=');
1689
ap_val = parse_token_or_qstring;
1690
rest = parse_auth_param_rest
1692
(ap_name, ap_val) :: rest
1697
(* Basic authentication is a special case! *)
1698
let v = mh # field fieldname in (* or Not_found *)
1699
match Netstring_str.split ws_re v with
1700
| [ name; creds ] when String.lowercase name = "basic" ->
1701
("basic", ["credentials", creds])
1703
parse_field mh fn_name parse_creds fieldname
1705
let mk_credentials (auth_name, auth_params) =
1706
if String.lowercase auth_name = "basic" then (
1708
try List.assoc "credentials" auth_params
1710
failwith "Nethttp.mk_credentials: basic credentials not found" in
1717
(fun (p_name, p_val) ->
1718
p_name ^ "=" ^ string_of_value p_val)
1721
let get_authorization mh =
1722
parse_credentials mh "Nethttp.get_authorization" "authorization"
1724
let set_authorization mh v =
1725
mh # update_field "Authorization" (mk_credentials v)
1727
let get_proxy_authorization mh =
1728
parse_credentials mh "Nethttp.get_proxy_authorization" "proxy-authorization"
1730
let set_proxy_authorization mh v =
1731
mh # update_field "Proxy-Authorization" (mk_credentials v)
1736
(* --- Cookies --- *)
1738
exception No_equation of string
1740
let split_name_is_value s =
1741
(* Recognizes a string "name=value" and returns the pair (name,value).
1742
* If the string has the wrong format, the function will raise
1743
* No_equation, and the argument of the exception is the unparseable
1747
let p = String.index s '=' in
1748
(String.sub s 0 p, String.sub s (p+1) (String.length s - p - 1))
1751
raise(No_equation s)
1753
let spaces_at_beginning_re = Netstring_str.regexp "^[ \t\r\n]+"
1754
let spaces_at_end_re = Netstring_str.regexp "[ \t\r\n]+$"
1756
let strip_spaces s = (* Remove leading and trailing spaces: *)
1757
Netstring_str.global_replace
1759
(Netstring_str.global_replace
1760
spaces_at_beginning_re "" s)
1762
let split_cookies_re = Netstring_str.regexp "[ \t\r\n]*;[ \t\r\n]*" ;;
1765
let cstrings = mh # multiple_field "Cookie" in
1766
(* Remove leading and trailing spaces: *)
1767
let cstrings' = List.map strip_spaces cstrings in
1768
let partss = List.map
1770
Netstring_str.split split_cookies_re cstring
1773
let parts = List.flatten partss in
1778
try split_name_is_value part
1779
with No_equation _ -> (part, "")
1780
(* Because it is reported that MSIE returns just "n" instead
1781
* of "n=" when the value v is empty
1784
let n_dec = Netencoding.Url.decode n in
1785
let v_dec = Netencoding.Url.decode v in
1791
Cookie.get_cookie_ct
1793
let set_cookie mh l =
1798
Netencoding.Url.encode n ^ "=" ^ Netencoding.Url.encode v)
1800
mh # update_field "Cookie" s
1804
let nv_re = Pcre.regexp "^([a-zA-Z0-9_.]+)(=(.*))?$"
1806
let nv_re = Netstring_str.regexp "^\\([^=;]+\\)\\(=\\(.*\\)\\)?$"
1809
let get_set_cookie_1 s =
1813
( match Netstring_str.string_match nv_re item 0 with
1815
raise(Bad_header_field "Nethttp.Header.get_set_cookie")
1817
let name = Netstring_str.matched_group m 1 item in
1819
try Netstring_str.matched_group m 3 item
1820
with Not_found -> "" in
1824
(Netstring_str.split split_cookies_re s)
1827
| (n,v) :: params ->
1829
List.map (fun (n,v) -> (String.lowercase n, v)) params in
1830
{ cookie_name = Netencoding.Url.decode ~plus:false n;
1831
cookie_value = Netencoding.Url.decode ~plus:false v;
1832
cookie_expires = (try
1833
let exp_str = List.assoc "expires" params in
1834
Some(Netdate.since_epoch
1835
(Netdate.parse exp_str))
1837
| Not_found -> None);
1838
cookie_domain = ( try
1839
Some(List.assoc "domain" params)
1844
Some(List.assoc "path" params)
1848
cookie_secure = ( try
1849
List.mem_assoc "secure" params
1851
| Not_found -> false
1855
raise(Bad_header_field "Nethttp.Header.get_set_cookie")
1858
let get_set_cookie mh =
1859
let fields = mh # multiple_field "Set-Cookie" in
1860
List.map get_set_cookie_1 fields
1863
let set_set_cookie mh l =
1867
let enc_name = Netencoding.Url.encode ~plus:false c.cookie_name in
1868
let enc_value = Netencoding.Url.encode ~plus:false c.cookie_value in
1869
enc_name ^ "=" ^ enc_value ^
1870
( match c.cookie_expires with
1873
";EXPIRES=" ^ Netdate.mk_usenet_date t
1875
(match c.cookie_domain with
1880
(match c.cookie_path with
1885
if c.cookie_secure then ";SECURE" else ""
1889
mh # update_multiple_field "Set-cookie" cookie_fields
1891
let set_set_cookie_ct =
1892
Cookie.set_set_cookie_ct
added
removed
src/netstring/nethttp.mlp
