forked from mirage/ocaml-cohttp
/
cookie.ml
162 lines (147 loc) · 5.47 KB
/
cookie.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
(*
* Copyright (C) <2012> Anil Madhavapeddy <anil@recoil.org>
* Copyright (C) <2009> David Sheets <sheets@alum.mit.edu>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
* copyright notice and this permission notice appear in all copies.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*
*)
type expiration = [
| `Session
| `Max_age of int64
]
type cookie = string * string
module Set_cookie_hdr = struct
type t = {
cookie: cookie;
expiration : expiration;
domain : string option;
path : string option;
secure : bool;
http_only: bool } with fields
(* Does not check the contents of name or value for ';', ',', '\s', or name[0]='$' *)
let make ?(expiration=`Session) ?path ?domain ?(secure=false) ?(http_only=false) cookie =
{ cookie ; expiration ; domain ; path ; secure ; http_only }
(* TODO: deprecated by RFC 6265 and almost certainly buggy without
reference to cookie field *)
let serialize_1_1 c =
let attrs = ["Version=1"] in
let attrs = if c.secure then ("Secure" :: attrs) else attrs in
let attrs = match c.path with None -> attrs
| Some p -> ("Path=" ^ p) :: attrs in
let attrs = match c.expiration with
| `Session -> "Discard" :: attrs
| `Max_age age -> ("Max-Age=" ^ (Int64.to_string age)) :: attrs
in
let attrs = match c.domain with None -> attrs
| Some d -> ("Domain=" ^ d) :: attrs in
("Set-Cookie2", String.concat "; " attrs)
let serialize_1_0 c =
let attrs = if c.http_only then ["httponly"] else [] in
let attrs = if c.secure then "secure"::attrs else attrs in
let attrs = match c.path with None -> attrs
| Some p -> ("path=" ^ p) :: attrs in
let attrs = match c.domain with None -> attrs
| Some d -> ("domain=" ^ d) :: attrs in
let attrs = match c.expiration with
| `Session -> attrs
| `Max_age age -> ("Max-Age=" ^ (Int64.to_string age)) :: attrs
in
let n, c = c.cookie in
(* TODO: may be buggy, some UAs will ignore cookie-strings without '='*)
let attrs = (n ^ (match c with "" -> ""
| v -> "=" ^ v)) :: attrs in
("Set-Cookie", String.concat "; " attrs)
let serialize ?(version=`HTTP_1_0) c =
match version with
| `HTTP_1_0 -> serialize_1_0 c
| `HTTP_1_1 -> serialize_1_1 c
(* TODO: implement *)
let extract_1_1 cstr alist = alist
let extract_1_0 cstr alist =
let attrs = Re_str.split_delim (Re_str.regexp ";[ \t]*") cstr in
let attrs = List.map (fun attr ->
match Re_str.split_delim (Re_str.regexp_string "=") attr with
| [] -> ("","")
| n::v -> (n,String.concat "=" v)
) attrs in
try
let cookie = List.hd attrs in
let attrs = List.map (fun (n,v) -> (String.lowercase n, v))
(List.tl attrs) in
let path =
try
let v = List.assoc "path" attrs in
if v = "" || v.[0] <> '/'
then raise Not_found
else Some v
with Not_found -> None
in
let domain =
try
let v = List.assoc "domain" attrs in
if v = "" then raise Not_found
else Some
(String.lowercase
(if v.[0] = '.' then Re_str.string_after v 1 else v))
with Not_found -> None
in
(* TODO: trim wsp *)
(fst cookie, {
cookie;
(* TODO: respect expires attribute *)
expiration = `Session;
domain;
path;
http_only=List.mem_assoc "httponly" attrs;
secure = List.mem_assoc "secure" attrs;
})::alist
with (Failure "hd") -> alist
(* TODO: check dupes+order *)
let extract hdr =
Header.fold (function
| "set-cookie" -> extract_1_0
| "set-cookie2" -> extract_1_1
| _ -> (fun _ a -> a)
) hdr []
let value { cookie=(_,v) } = v
end
module Cookie_hdr = struct
(* RFC 2965 has
cookie = "Cookie:" cookie-version 1*((";" | ",") cookie-value)
cookie-value = NAME "=" VALUE [";" path] [";" domain] [";" port]
cookie-version = "$Version" "=" value
NAME = attr
VALUE = value
path = "$Path" "=" value
domain = "$Domain" "=" value
port = "$Port" [ "=" <"> value <"> ]
*)
let cookie_re = Re_str.regexp "[;,][ \t]*"
let equals_re = Re_str.regexp_string "="
let extract hdr =
List.fold_left
(fun acc header ->
let comps = Re_str.split_delim cookie_re header in
(* We don't handle $Path, $Domain, $Port, $Version (or $anything
$else) *)
let cookies = List.filter (fun s -> s.[0] != '$') comps in
let split_pair nvp =
match Re_str.bounded_split equals_re nvp 2 with
| [] -> ("","")
| n :: [] -> (n, "")
| n :: v :: _ -> (n, v)
in (List.map split_pair cookies) @ acc
) [] (Header.get_multi hdr "cookie")
let serialize cookies =
"cookie", String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) cookies)
end