Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 370 lines (328 sloc) 14.895 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 @author Laurent Le Brun
20 **)
21 #<Debugvar:HTTP_DEBUG>
22
23 (* This module provides a way to have secure cookies. Each time a client
24 * comes on the webpage, a new cookie is generated, and the old cookie
25 * will expire a few seconds later. This way, it's quite difficult to
26 *)
27
28 (* ic: internal cookie, doesn't change, the server can use it to identify someone *)
29 (* ec: external cookie, change often, given to the browser *)
30
31 let sprintf = Printf.sprintf
32
33 module List = Base.List
34 module String = Base.String
35
36 module HST = HttpServerTypes
37
38 (* Configuration parameters *)
39 let cookie_gc_period = ref 100
40 let cookie_pool_size_min = ref 100
41 let cookie_pool_size_max = ref 10000
42 let cookie_connection_count = ref 0
43 let cookie_timer_stop = ref false
44 let cookie_timer_interval = ref 1
45 let cookie_rotation_period = ref 1
46 let cookie_rotation_period_max = ref 5
47 let cookie_rotation_period_ultimate = ref 10
48 let cookie_rotation_connection_rate_max = ref 5.0
49 let cookie_rotation_connection_rate_ultimate = ref 10.0
50 let cookie_expires_short = ref (Time.seconds 5)
51 let cookie_expires_long = ref (Time.seconds 50)
52 let cookie_max_external_cookies = ref 25
53 let cookie_rotate_cookies = ref true
54
55 let cookie_timer_functions = ref []
56
57 type ext_entry = (string * Time.t) list
58
59 (* The hash tables, int->ext and ext->int *)
60 let to_internal = ((Hashtbl.create 1000):(string, string) Hashtbl.t);;
61 let to_external = ((Hashtbl.create 1000):(string, ext_entry) Hashtbl.t);;
62 let to_resource = ((Hashtbl.create 1000):(string,(unit,unit)ResourceTracker.t) Hashtbl.t)
63
64 let chars = "abcdefghijklmnopqrstuvwxyz0123456789"
65 let nchars = String.length chars
66 let chars256 = String.init 256 (fun i -> chars.[i mod nchars])
67 let rand4 () =
68 let r = Random.bits () in
69 (chars256.[r land 0x7f],
70 chars256.[(r lsr 7) land 0x7f],
71 chars256.[(r lsr 14) land 0x7f],
72 chars256.[(r lsr 21) land 0x7f])
73 let cookie_len = 32
74 let random _ = String.init cookie_len (fun _ -> chars.[Random.int nchars])
75 let randomd str =
76 let rec aux = function
77 | n when n < 0 -> str
78 (*| n -> String.unsafe_set str n (String.unsafe_get chars (Random.int nchars)); aux (n-1)*)
79 | 0 ->
80 let (c1,_,_,_) = rand4 () in
81 String.unsafe_set str 0 c1;
82 aux (-1)
83 | 1 ->
84 let (c1,c2,_,_) = rand4 () in
85 String.unsafe_set str 0 c1;
86 String.unsafe_set str 1 c2;
87 aux (-1)
88 | 2 ->
89 let (c1,c2,c3,_) = rand4 () in
90 String.unsafe_set str 0 c1;
91 String.unsafe_set str 1 c2;
92 String.unsafe_set str 2 c3;
93 aux (-1)
94 | n ->
95 let (c1,c2,c3,c4) = rand4 () in
96 String.unsafe_set str n c1;
97 String.unsafe_set str (n-1) c2;
98 String.unsafe_set str (n-2) c3;
99 String.unsafe_set str (n-3) c4;
100 aux (n-4)
101 in
102 aux (cookie_len - 1)
103
104 let cookie_pool = ref ([]:string list)
105 let cookie_dead = ref ([]:string list)
106 let cookie_pool_size = ref 0
107 let cookie_dead_size = ref 0
108
109 let get_dead_cookie () =
110 match !cookie_dead with
111 | str::rest -> cookie_dead := rest; decr cookie_dead_size; str
112 | [] -> String.create cookie_len
113
114 let return_dead_cookie str =
115 #<If>Logger.debug "return_dead_cookie: %s" str#<End>; cookie_dead := str::!cookie_dead; incr cookie_dead_size
116
117 let populate_cookie_dead cnt =
118 while !cookie_dead_size < cnt do
119 cookie_dead := (String.create cookie_len)::!cookie_dead;
120 incr cookie_dead_size
121 done
122
123 let populate_cookie_pool cnt =
124 while !cookie_pool_size < cnt do
125 cookie_pool := (randomd (get_dead_cookie()))::!cookie_pool;
126 incr cookie_pool_size
127 done
128
129 let get_cookie_string () =
130 match !cookie_pool with
131 | cookie_string::rest ->
132 (#<If>Logger.debug "get_cookie_string: pool"#<End>; cookie_pool := rest; decr cookie_pool_size; cookie_string)
133 | [] -> (#<If>Logger.debug "get_cookie_string: random"#<End>; random ())
134
135 let last_cookie_check_time = ref Time.zero
136 let cookie_connect_rate = ref 0.0
137 let last_cookie_rotation_period = ref 0
138
139 let check_cookie_pool now =
140 let dT = Time.to_unix_time (Time.difference !last_cookie_check_time now) in
141 last_cookie_check_time := now;
142 if dT <= 0.0
143 then
144 (cookie_connection_count := 0;
145 cookie_rotation_period := 1;
146 #<If>Logger.debug "check_cookie_pool: dT=%f <= 0.0" dT#<End>)
147 else
148 (cookie_connect_rate := (float_of_int !cookie_connection_count) /. dT;
149 #<If$minlevel 10>Logger.debug "check_cookie_pool: dT=%f cookie_connection_count=%d cookie_connect_rate=%f"
150 dT !cookie_connection_count !cookie_connect_rate#<End>;
151 cookie_connection_count := 0;
152 cookie_rotation_period := (if !cookie_connect_rate <= !cookie_rotation_connection_rate_max
153 then 1
154 else if !cookie_connect_rate <= !cookie_rotation_connection_rate_ultimate
155 then !cookie_rotation_period_max
156 else !cookie_rotation_period_ultimate);
157 if !last_cookie_rotation_period <> !cookie_rotation_period
158 then (#<If>Logger.debug "check_cookie_pool: setting cookie rotation to %d" !cookie_rotation_period#<End>;
159 last_cookie_rotation_period := !cookie_rotation_period);
160 if !cookie_pool_size < !cookie_pool_size_min && !cookie_connect_rate <= !cookie_rotation_connection_rate_max
161 then
162 (let cnt = max !cookie_pool_size_min (!cookie_pool_size_max - !cookie_pool_size) in
163 #<If>Logger.debug "check_cookie_pool: repopulating %d" cnt#<End>;
164 populate_cookie_pool cnt);
165 )
166 let _ = cookie_timer_functions := check_cookie_pool::!cookie_timer_functions
167
168 let update_current_time now =
169 let lc = Time.localtime now in
170 HST.current_time_string :=
171 sprintf "%02d/%02d/%02d:%02d:%02d:%02d %s" lc.Unix.tm_mday (lc.Unix.tm_mon + 1) (lc.Unix.tm_year + 1900)
172 lc.Unix.tm_hour lc.Unix.tm_min lc.Unix.tm_sec !(HST.time_diff);
173 #<If$minlevel 10>Logger.debug "update_current_time: current_time_string=%s" !(HST.current_time_string)#<End>
174 let _ = cookie_timer_functions := update_current_time::!cookie_timer_functions
175
176 let check_cookie_timer () =
177 if !cookie_timer_stop
178 then raise Scheduler.StopTimer
179 else
180 let now = Time.now () in
181 List.iter (fun f -> f now) !cookie_timer_functions
182
183 let abbrev s = if String.length s < 5 then s else String.sub s 0 5
184
185 let strint () = (Hashtbl.fold (fun k e s -> s^" "^(abbrev k)^" -> "^(abbrev e)^"\n |") to_internal "[|")^"]";;
186 let pintern () = Logger.debug "%s" (strint()); flush stderr;;
187
188 let sp32 = " ";;
189 let strexl sep l =
190 "["^(String.concat sep (List.map (fun (a,c) ->
191 Printf.sprintf "(%s,%d)" (abbrev a) (Time.in_milliseconds c)) l))^"]";;
192 let strext () = (Hashtbl.fold (fun k e s -> s^" "^(abbrev k)^" -> "^(strexl (";\n"^sp32) e)^"\n |") to_external "[|")^"]";;
193 let pextern () = Logger.debug "%s" (strext()); flush stderr;;
194
195 (* Remove expired cookies *)
196 let remove_expired (now:Time.t) (li:ext_entry) (ec:string) : bool * bool * ext_entry =
197 List.fold_right (fun ((c, date) as e) (alt,has_ec,li) ->
198 if date < now
199 then (Hashtbl.remove to_internal c;
200 #<If>Logger.debug "remove_expired(to_internal[%d])=%s" (Hashtbl.length to_internal) (abbrev c)#<End>;
201 (true,has_ec,li))
202 else (alt,(has_ec||c=ec),e::li)) li (false,false,[])
203
204 let rth = ResourceTracker.Default.handler
205 "Cookie"
206 (fun _ _ -> ())
207 (fun _ -> None)
208 (fun _ _ _ -> (),())
209 (fun _ _ _ -> ())
210
211 let create ?(expires=Time.seconds 5) now () =
212 let ic = get_cookie_string () in
213 let ec = get_cookie_string () in
214 let l = [(ec,Time.add now expires)] in
215 Hashtbl.add to_external ic l;
216 #<If>Logger.debug "create: add(to_external[%d])=%s -> %s" (Hashtbl.length to_external) (abbrev ic) (strexl ";" l)#<End>;
217 Hashtbl.add to_internal ec ic;
218 #<If>Logger.debug "create: add(to_internal[%d])=%s -> %s" (Hashtbl.length to_internal) (abbrev ec) (abbrev ic)#<End>;
219 ec, ic
220
221 exception Unknown_cookie
222
223 let get_resource_tracker ic =
224 try Hashtbl.find to_resource ic
225 with Not_found ->
226 if Hashtbl.mem to_external ic
227 then
228 let r = ResourceTracker.Default.resource rth () () in
229 Hashtbl.add to_resource ic r; r
230 else raise Unknown_cookie
231
232 let split_cookie str =
461365b [cleanup] Base.String: changed String.split to a much simpler String.sli...
Louis Gesbert authored
233 List.map (fun x -> let a, b = String.split_char '=' x in ((String.trim a), b)) (String.slice ';' str)
fccc685 Initial open-source release
MLstate authored
234
235 let collect_cookies (ics,ecs,ic_updts) =
236 List.iter (fun ec ->
237 #<If>Logger.debug "GC(ec): %s" (abbrev ec)#<End>;
238 return_dead_cookie ec;
239 Hashtbl.remove to_internal ec) ecs;
240 List.iter (fun ic ->
241 #<If>Logger.debug "GC(ic): %s" (abbrev ic)#<End>;
242 return_dead_cookie ic;
243 Hashtbl.remove to_external ic;
244 try
245 let r = Hashtbl.find to_resource ic in
246 ResourceTracker.Default.kill r `Expired
247 with Not_found -> ()) ics;
248 List.iter (fun (ic,ecs) -> #<If>Logger.debug "GC(ecs): %s(%d)" (abbrev ic) (List.length ecs)#<End>;
249 Hashtbl.replace to_external ic ecs) ic_updts
250
251 (* Garbage collect cookies: mark and sweep... *)
252 let gc_cookies now =
253 #<If$minlevel 20>Logger.debug "gc_cookies"#<End>;
254 collect_cookies
255 (Hashtbl.fold
256 (fun ic ecs (ic_exps,ec_exps,ic_updts) ->
257 match ecs with
258 | [] -> (ic::ic_exps,ec_exps,ic_updts)
259 | (ec1,last1)::lst ->
260 if now > last1
261 then
262 let ec_exps = List.fold_left (fun ec_exps (ec,last) -> if now > last then ec::ec_exps else ec_exps)
263 ec_exps lst in
264 (ic::ic_exps,ec1::ec_exps,ic_updts)
265 else
266 let altered,_,lst = remove_expired now lst "" in
267 let ic_updts = if altered then (ic,(ec1,last1)::lst)::ic_updts else ic_updts in
268 (ic_exps,ec_exps,ic_updts))
269 to_external ([],[],[]))
270 let _ = cookie_timer_functions := gc_cookies::!cookie_timer_functions
271
272 (* Return the internal cookie *)
273 let get_internal hr =
274 let now = Time.now () in
275 let ec = hr.HST.hr_ec in
276 try
277 let ic = Hashtbl.find to_internal ec in
278 if ic <> hr.HST.hr_ic then raise Not_found;
279 #<If$minlevel 10>Logger.debug "get_internal: ec=%s hr_ec=%s ic=%s hr_ic=%s" ec hr.HST.hr_ec ic hr.HST.hr_ic#<End>;
280 (None,(#<If>Logger.debug "get_internal: found ec=%s ic=%s" (abbrev ec) (abbrev ic)#<End>; (hr,true,(ec,ic))))
281 with Not_found ->
282 let new_ec, new_ic = create now () in
283 #<If>Logger.debug "get_internal: not found ec='%s' new_ic='%s'" (abbrev ec) (abbrev new_ic)#<End>;
284 let hr = { hr with HST.hr_ec = new_ec; hr_ic = new_ic } in
285 (None,(hr,false,(new_ec,new_ic)))
286
287 let llast l =
288 (* Not TR. *)
289 let rec aux =
290 function
291 | [] -> [], None
292 | [x] -> [], Some x
293 | h::t -> let l, sx = aux t in h::l, sx
294 in
295 aux l
296
297 let limit_list mx li =
298 if List.length li > mx
299 then
300 match llast li with
301 | li2, Some (ec,_) ->
302 #<If>Logger.debug "Limit(ec): %s" (abbrev ec)#<End>; return_dead_cookie ec; Hashtbl.remove to_internal ec; li2
303 | _, _ -> li
304 else li
305
306 let cookie_rotation_count = ref 0
307
308 (* Return the external cookie *)
309 let get_external ic =
310 try
311 let now = Time.now () in
312 let rnd = get_cookie_string () in
313 let max_age, (ec, ic) =
314 match Hashtbl.find to_external ic with
315 | [] -> Time.zero, ("", "")
316 | (ec, _) :: li ->
317 incr cookie_rotation_count;
318 let cookie_rotation_enable = !cookie_rotation_count >= !cookie_rotation_period in
319 if cookie_rotation_enable then cookie_rotation_count := 0;
320 if !cookie_rotate_cookies && cookie_rotation_enable
321 then
322 let expires_time = Time.add now !cookie_expires_long in
323 let li = (rnd, expires_time) :: (ec, expires_time) :: li in
324 let li = limit_list !cookie_max_external_cookies li in
325 Hashtbl.replace to_external ic li;
326 #<If>Logger.debug "get_external(to_external[%d])=%s -> %s"
327 (Hashtbl.length to_external) (abbrev ic)
328 (strexl ";\n " li)#<End>;
329 Hashtbl.add to_internal rnd ic;
330 #<If>Logger.debug "get_external(to_internal[%d])=%s -> %s"
331 (Hashtbl.length to_internal) (abbrev rnd) (abbrev ic)#<End>;
332 !cookie_expires_long, (rnd,ic)
333 else
334 let expires_time = Time.add now !cookie_expires_long in
335 let li = (ec, expires_time) :: li in
336 Hashtbl.replace to_external ic li;
337 #<If>Logger.debug "get_external(reuse to_internal[%d])=%s -> %s"
338 (Hashtbl.length to_internal) (abbrev ec) (abbrev ic)#<End>;
339 !cookie_expires_long, (ec,ic)
340 in
341 max_age, "ec="^ec, "ic="^ic
342 with
343 | Not_found -> Time.zero, "", ""
344 | exn -> Logger.warning "Cookie2.get_external: Unknown exception %s" (Printexc.to_string exn); Time.zero, "", ""
345
346 let init_cookies ~sched
347 ?(gc_period=100) ?(pool_min=100) ?(pool_max=10000) ?(timer_interval=1)
348 ?(rate_max=5.0) ?(period_max=5) ?(rate_ultimate=10.0) ?(period_ultimate=100)
349 ?(expires_short=Time.seconds 5) ?(expires_long=Time.seconds 50) ?(dt1=Time.days 10) ?(dt2=Time.infinity)
350 ?(max_external_cookies=25) ?(rotate_cookies=true) ?(cookies_filename="")
351 () =
352 let _, _, _ = dt1, dt2, cookies_filename in
353 cookie_gc_period := gc_period;
354 cookie_pool_size_min := pool_min;
355 cookie_pool_size_max := pool_max;
356 cookie_timer_interval := timer_interval;
357 cookie_rotation_connection_rate_max := rate_max;
358 cookie_rotation_period_max := period_max;
359 cookie_rotation_connection_rate_ultimate := rate_ultimate;
360 cookie_rotation_period_ultimate := period_ultimate;
361 cookie_expires_short := expires_short;
362 cookie_expires_long := expires_long;
363 cookie_max_external_cookies := max_external_cookies;
364 cookie_rotate_cookies := rotate_cookies;
365 last_cookie_check_time := Time.now();
366 cookie_timer_stop := false;
367 populate_cookie_dead pool_max;
368 populate_cookie_pool pool_max;
369 Scheduler.timer sched (Time.seconds timer_interval) check_cookie_timer
Something went wrong with that request. Please try again.