Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 357 lines (320 sloc) 14.591 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 (* Long-term cookies:
24 * - we retain the ic/ec cookie names in order to avoid rewriting OPA's cookie parser.
25 *)
26
27 let sprintf = Printf.sprintf
28
29 module List = Base.List
30 module String = Base.String
31
32 module HST = HttpServerTypes
33
34 (* Configuration parameters *)
35 (* Note: the rotation paramters have not been deleted in case they are needed later. *)
36 let cookie_gc_period = ref 100
37 let cookie_pool_size_min = ref 100
38 let cookie_pool_size_max = ref 10000
39 let cookie_connection_count = ref 0
40 let cookie_timer_stop = ref false
41 let cookie_timer_interval = ref 1
42 let cookie_gc_blocksize = ref 1
43 (*let cookie_rotation_period = ref 1
44 let cookie_rotation_period_max = ref 5
45 let cookie_rotation_period_ultimate = ref 10*)
46 let cookie_rotation_connection_rate_max = ref 5.0
47 (*let cookie_rotation_connection_rate_ultimate = ref 10.0*)
48 (*let cookie_expires_short = ref (Time.seconds 5)*)
49 (*let cookie_expires_long = ref (Time.seconds 50)*)
50 let cookie_dt1 = ref (Time.days 10) (* Variable expiration *)
51 let cookie_dt2 = ref Time.infinity (* Fixed deadline *)
52 (*let cookie_max_external_cookies = ref 25*)
53 (*let cookie_rotate_cookies = ref true*)
54 let cookies_txt_filename = ref ""
55
56 type expiration_callback = (string -> string -> unit)
57 let cookie_expiration_callback =
58 ref ((fun _ec _ic ->
59 #<If$minlevel 10>Logger.debug "cookie_expiration_callback: (ec,ic)=(%s,%s)" _ec _ic#<End>;
60 ()
61 ):expiration_callback)
62
63 let cookie_timer_functions = ref []
64
65 (* The hash table *)
66 (* We now have a single hash table: (ec,ic) -> expiry time *)
67 let to_longcook = ((Hashtbl.create 1000):((string * string), (Time.t * Time.t)) Hashtbl.t)
68
69 let chars = "abcdefghijklmnopqrstuvwxyz0123456789"
70 let nchars = String.length chars
71 let chars256 = String.init 256 (fun i -> chars.[i mod nchars])
72 let rand4 () =
73 let r = Random.bits () in
74 (chars256.[r land 0x7f],
75 chars256.[(r lsr 7) land 0x7f],
76 chars256.[(r lsr 14) land 0x7f],
77 chars256.[(r lsr 21) land 0x7f])
78 let cookie_len = 32
79 let random _ = String.init cookie_len (fun _ -> chars.[Random.int nchars])
80 let randomd str =
81 let rec aux = function
82 | n when n < 0 -> str
83 (*| n -> String.unsafe_set str n (String.unsafe_get chars (Random.int nchars)); aux (n-1)*)
84 | 0 ->
85 let (c1,_,_,_) = rand4 () in
86 String.unsafe_set str 0 c1;
87 aux (-1)
88 | 1 ->
89 let (c1,c2,_,_) = rand4 () in
90 String.unsafe_set str 0 c1;
91 String.unsafe_set str 1 c2;
92 aux (-1)
93 | 2 ->
94 let (c1,c2,c3,_) = rand4 () in
95 String.unsafe_set str 0 c1;
96 String.unsafe_set str 1 c2;
97 String.unsafe_set str 2 c3;
98 aux (-1)
99 | n ->
100 let (c1,c2,c3,c4) = rand4 () in
101 String.unsafe_set str n c1;
102 String.unsafe_set str (n-1) c2;
103 String.unsafe_set str (n-2) c3;
104 String.unsafe_set str (n-3) c4;
105 aux (n-4)
106 in
107 aux (cookie_len - 1)
108
109 let cookie_pool = ref ([]:string list)
110 let cookie_dead = ref ([]:string list)
111 let cookie_pool_size = ref 0
112 let cookie_dead_size = ref 0
113
114 let get_dead_cookie () =
115 match !cookie_dead with
116 | str::rest -> cookie_dead := rest; decr cookie_dead_size; str
117 | [] -> String.create cookie_len
118
119 let return_dead_cookie str =
120 #<If$minlevel 10>Logger.debug "return_dead_cookie: %s" str#<End>;
121 cookie_dead := str::!cookie_dead; incr cookie_dead_size
122
123 let populate_cookie_dead cnt =
124 while !cookie_dead_size < cnt do
125 cookie_dead := (String.create cookie_len)::!cookie_dead;
126 incr cookie_dead_size
127 done
128
129 let populate_cookie_pool cnt =
130 while !cookie_pool_size < cnt do
131 cookie_pool := (randomd (get_dead_cookie()))::!cookie_pool;
132 incr cookie_pool_size
133 done
134
135 let get_cookie_string () =
136 match !cookie_pool with
137 | cookie_string::rest ->
138 (#<If$minlevel 10>Logger.debug "get_cookie_string: pool"#<End>;
139 cookie_pool := rest; decr cookie_pool_size; cookie_string)
140 | [] -> (#<If$minlevel 10>Logger.debug "get_cookie_string: random"#<End>; random ())
141
142 let last_cookie_check_time = ref Time.zero
143 let cookie_connect_rate = ref 0.0
144 (*let last_cookie_rotation_period = ref 0*)
145
146 let check_cookie_pool now =
147 let dT = Time.to_unix_time (Time.difference !last_cookie_check_time now) in
148 last_cookie_check_time := now;
149 if dT <= 0.0
150 then
151 (cookie_connection_count := 0;
152 (*cookie_rotation_period := 1;*)
153 #<If$minlevel 10>Logger.debug "check_cookie_pool: dT=%f <= 0.0" dT#<End>)
154 else
155 (cookie_connect_rate := (float_of_int !cookie_connection_count) /. dT;
156 #<If$minlevel 10>Logger.debug "check_cookie_pool: dT=%f cookie_connection_count=%d cookie_connect_rate=%f"
157 dT !cookie_connection_count !cookie_connect_rate#<End>;
158 cookie_connection_count := 0;
159 (*cookie_rotation_period := (if !cookie_connect_rate <= !cookie_rotation_connection_rate_max
160 then 1
161 else if !cookie_connect_rate <= !cookie_rotation_connection_rate_ultimate
162 then !cookie_rotation_period_max
163 else !cookie_rotation_period_ultimate);*)
164 (*if !last_cookie_rotation_period <> !cookie_rotation_period
165 then (#<If>Logger.debug "check_cookie_pool: setting cookie rotation to %d" !cookie_rotation_period#<End>;
166 last_cookie_rotation_period := !cookie_rotation_period);*)
167 if !cookie_pool_size < !cookie_pool_size_min && !cookie_connect_rate <= !cookie_rotation_connection_rate_max
168 then
169 (let cnt = max !cookie_pool_size_min (!cookie_pool_size_max - !cookie_pool_size) in
170 #<If$minlevel 10>Logger.debug "check_cookie_pool: repopulating %d" cnt#<End>;
171 populate_cookie_pool cnt))
172
173 let update_current_time now =
174 let lc = Time.localtime now in
175 HST.current_time_string :=
176 sprintf "%02d/%02d/%02d:%02d:%02d:%02d %s" lc.Unix.tm_mday (lc.Unix.tm_mon + 1) (lc.Unix.tm_year + 1900)
177 lc.Unix.tm_hour lc.Unix.tm_min lc.Unix.tm_sec !(HST.time_diff);
178 #<If$minlevel 10>Logger.debug "update_current_time: current_time_string=%s" !(HST.current_time_string)#<End>
179
180 let check_cookie_timer () =
181 if !cookie_timer_stop
182 then raise Scheduler.StopTimer
183 else
184 let now = Time.now () in
185 List.iter (fun f -> f now) !cookie_timer_functions
186
187 let abbrev s = if String.length s < 5 then s else String.sub s 0 5
188
189 let create hr =
190 let ic = get_cookie_string () in
191 let ec = get_cookie_string () in
192 let dt1 = Time.add hr.HST.hr_timestamp !cookie_dt1 in
193 let dt2 = Time.add hr.HST.hr_timestamp !cookie_dt2 in
194 Hashtbl.add to_longcook (ec,ic) (dt1,dt2);
195 #<If$minlevel 10>Logger.debug "create: add(to_longcook[%d])=%s.%s -> (%7.0f,%7.0f)"
196 (Hashtbl.length to_longcook) (abbrev ic) (abbrev ec)
197 (Time.in_seconds dt1) (Time.in_seconds dt2)#<End>;
198 { hr with HST.hr_ec = ec; hr_ic = ic; hr_dt2 = dt2; }
199
200 let split_cookie str =
461365b [cleanup] Base.String: changed String.split to a much simpler String.sli...
Louis Gesbert authored
201 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
202
203 let collect_cookies sched (_,expired) =
204 List.iteri
205 (fun (ec,ic) i ->
206 if i mod !cookie_gc_blocksize = 0 then Scheduler.push sched (fun () -> ());
207 (!cookie_expiration_callback) ec ic;
208 #<If$minlevel 10>Logger.debug "GC(ec,ic): (%s,%s) deleted" ec ic#<End>;
209 return_dead_cookie ec;
210 return_dead_cookie ic;
211 Hashtbl.remove to_longcook (ec,ic)) expired
212
213 let gc_cookies sched now =
214 #<If$minlevel 20>Logger.debug "gc_cookies"#<End>;
215 collect_cookies sched
216 (Hashtbl.fold
217 (fun ecic (dt1,dt2) (i,expired) ->
218 if i mod !cookie_gc_blocksize = 0 then Scheduler.push sched (fun () -> ());
219 if now > dt1 || now > dt2 then ((i+1),(ecic::expired)) else ((i+1),expired))
220 to_longcook (0,[]))
221
222 (* Check the cookie given by the browser *)
223 (* Return the internal cookie *)
224 let get_internal hr =
225 try
226 if String.length hr.HST.hr_ec <> cookie_len || String.length hr.HST.hr_ic <> cookie_len then raise Not_found;
227 let (dt1,dt2) = Hashtbl.find to_longcook (hr.HST.hr_ec,hr.HST.hr_ic) in
228 if hr.HST.hr_timestamp > dt1 || hr.HST.hr_timestamp > dt2
229 then
230 let hr = create hr in
231 #<If$minlevel 10>Logger.debug "get_internal: expired new={ec='%s' ic='%s'}"
232 (abbrev hr.HST.hr_ec) (abbrev hr.HST.hr_ic)#<End>;
233 hr
234 else
235 (#<If$minlevel 10>Logger.debug "get_internal: found ec=%s ic=%s"
236 (abbrev hr.HST.hr_ec) (abbrev hr.HST.hr_ic)#<End>;
237 { hr with HST.hr_dt2 = dt2 })
238 with Not_found ->
239 let hr = create hr in
240 #<If$minlevel 10>Logger.debug "get_internal: not found new={ec='%s' ic='%s'}"
241 (abbrev hr.HST.hr_ec) (abbrev hr.HST.hr_ic)#<End>;
242 hr
243
244 (* Return the external cookie *)
245 let get_external hr =
246 let id = (hr.HST.hr_ec,hr.HST.hr_ic) in
247 try
248 (* Note that if dt1 = dt2 = infinity then cookies will last forever. *)
249 let max_age = Time.min !cookie_dt1 hr.HST.hr_dt2 in
250 let dt1 = Time.add hr.HST.hr_timestamp max_age in
251 Hashtbl.replace to_longcook id (dt1,hr.HST.hr_dt2);
252 #<If$minlevel 10>Logger.debug "get_external(%s.%s) max_age=%f"
253 (abbrev hr.HST.hr_ec) (abbrev hr.HST.hr_ic) (Time.in_seconds max_age)#<End>;
254 max_age, "ec="^hr.HST.hr_ec, "ic="^hr.HST.hr_ic
255 with
256 | Not_found -> Time.zero, "", ""
257 | exn -> Logger.warning "CookieLong.get_external: Unknown exception %s" (Printexc.to_string exn); Time.zero, "", ""
258
259 let save_cookies () =
260 if !cookies_txt_filename <> ""
261 then begin
262 Logger.info "Saving cookies ...";
263 try
264 let oc = open_out !cookies_txt_filename in
265 Hashtbl.iter (fun (ec,ic) (dt1,dt2) ->
266 Printf.fprintf oc "%s %s (%f) (%f)\n"
267 ec ic (Time.in_seconds dt1) (Time.in_seconds dt2)) to_longcook;
268 close_out oc;
269 Logger.info "... saved cookies."
270 with exn ->
271 Logger.error "save_cookies: exn=%s" (Printexc.to_string exn)
272 end
273
274 let cookre = Str.regexp "[ \t]*\\([a-z0-9]+\\)[ \t]+\\([a-z0-9]+\\)[ \t]+(\\([0-9.eE+-]+\\))[ \t]+(\\([0-9.eE+-]+\\))"
275 let load_cookies () =
276 if !cookies_txt_filename <> "" && File.exists !cookies_txt_filename
277 then begin
278 Logger.info "Loading cookies ...";
279 let now = Time.now() in
280 try
281 let ic = open_in !cookies_txt_filename in
282 let rec aux () =
283 try
284 (match input_line ic with
285 | "" -> ()
286 | str ->
287 if String.length str < (cookie_len*2+3)
288 then aux ()
289 else
290 if Str.string_match cookre str 0
291 then
292 let ec = Str.matched_group 1 str in
293 let ic = Str.matched_group 2 str in
294 let dt1str = Str.matched_group 3 str in
295 let dt2str = Str.matched_group 4 str in
296 if String.length ec = cookie_len && String.length ic = cookie_len
297 then
298 (try
299 let dt1 = Time.of_unix_time_inf (float_of_string dt1str) in
300 let dt2 = Time.of_unix_time_inf (float_of_string dt2str) in
301 if now > dt1 || now > dt2
302 then (#<If$minlevel 10>Logger.debug "expired cookie: ec=%s ic=%s dt1=%7.0f dt2=%7.0f"
303 ec ic (Time.in_seconds dt1) (Time.in_seconds dt2)#<End>;
304 ())
305 else (#<If$minlevel 10>Logger.debug "loading cookie: ec=%s ic=%s dt1=%7.0f dt2=%7.0f"
306 ec ic (Time.in_seconds dt1) (Time.in_seconds dt2)#<End>;
307 Hashtbl.replace to_longcook (ec,ic) (dt1,dt2));
308 aux ()
309 with | Failure "float_of_string" -> aux ())
310 else aux ()
311 else aux ())
312 with | End_of_file -> ()
313 in
314 aux ();
315 close_in ic;
316 Logger.info "Loaded cookies.txt file"
317 with exn ->
318 Logger.error "load_cookies: exn=%s" (Printexc.to_string exn)
319 end
320
321 let init_cookies ~sched
322 ?(gc_period=100) ?(pool_min=100) ?(pool_max=10000) ?(timer_interval=1)
323 ?(rate_max=5.0) ?(period_max=5) ?(rate_ultimate=10.0) ?(period_ultimate=100)
324 ?(expires_short=Time.seconds 5) ?(expires_long=Time.seconds 50) ?(dt1=Time.days 10) ?(dt2=Time.infinity)
325 ?(max_external_cookies=25) ?(rotate_cookies=true) ?(cookies_filename="")
326 () =
327 Random.self_init();
328 let _, _, _, _, _, _, _ =
329 period_max, rate_ultimate, period_ultimate, expires_short, expires_long, max_external_cookies, rotate_cookies in
330 cookie_gc_period := gc_period;
331 cookie_pool_size_min := pool_min;
332 cookie_pool_size_max := pool_max;
333 cookie_timer_interval := timer_interval;
334 cookie_rotation_connection_rate_max := rate_max;
335 (*cookie_rotation_period_max := period_max;
336 cookie_rotation_connection_rate_ultimate := rate_ultimate;
337 cookie_rotation_period_ultimate := period_ultimate;*)
338 (*cookie_expires_short := expires_short;*)
339 (*cookie_expires_long := expires_long;*)
340 cookie_dt1 := dt1;
341 cookie_dt2 := dt2;
342 (*cookie_max_external_cookies := max_external_cookies;*)
343 (*cookie_rotate_cookies := rotate_cookies;*)
344 cookies_txt_filename := cookies_filename;
345 last_cookie_check_time := Time.now();
346 cookie_timer_stop := false;
347 populate_cookie_dead pool_max;
348 populate_cookie_pool pool_max;
349 cookie_timer_functions := check_cookie_pool::!cookie_timer_functions;
350 cookie_timer_functions := update_current_time::!cookie_timer_functions;
351 cookie_timer_functions := (gc_cookies sched)::!cookie_timer_functions;
352 Scheduler.timer sched (Time.seconds timer_interval) check_cookie_timer;
353 if !cookies_txt_filename <> "" then (load_cookies(); at_exit save_cookies)
354
355
356
Something went wrong with that request. Please try again.