open Wd_dialog open Wd_types open Unix let random_char () = if Random.bool () then Char.chr ((Random.int 26) + 65) else Char.chr ((Random.int 26) + 97) let make_session_id () = let length = 128 + (Random.int 128) in let id = String.create length in for i=0 to length - 1 do id.[i] <- random_char () done; id let rec make_unique_session_id tbl = let id = make_session_id () in try ignore (Hashtbl.find tbl id);make_unique_session_id tbl;id with Not_found -> id let copy_dialog universe env dlg = let new_dlg = universe#create env (dlg#name) in let b = Buffer.create 1000 in dlg # serialize (Hashtbl.create 10) b; let ds_buf = { ds_str = Buffer.contents b; ds_pos = 0; ds_end = Buffer.length b; ds_universe = universe; ds_environment = env; ds_dialogs = Hashtbl.create 10; } in new_dlg # unserialize ds_buf; new_dlg exception Session_not_found class memory_session (id: string) (dlg : dialog_type) : session_type = object (self) val id = id val mutable dialog = dlg method commit_changes () = () method serialize = id method change_dialog dlg = dialog <- dlg method dialog = dialog method dialog_name = dialog#name method session_id = id end;; type session = {created:Int32.t; mutable last_used:Int32.t; session:memory_session} class memory_session_manager timeout sweep_time : session_manager_type = object (self) val sessions = Hashtbl.create 50000 val mutable previous_sweep = Int32.of_float (gettimeofday ()) method create (dlg: dialog_type) = let id = make_unique_session_id sessions in let memses = new memory_session id dlg in let now = Int32.of_float (gettimeofday()) in self#check_sweep now; Hashtbl.add sessions id {session=memses; created=now; last_used=now}; memses method private check_sweep current_time = if (Int32.compare (Int32.sub current_time previous_sweep) sweep_time) = 1 then (self#sweep; previous_sweep <- current_time) method private sweep = let now = Int32.of_float (gettimeofday ()) in Hashtbl.iter (fun id s -> if (Int32.compare (Int32.sub now s.last_used) timeout) = 1 then Hashtbl.remove sessions id) sessions; method unserialize (universe: universe_type) env id = try let s = Hashtbl.find sessions id in let now = Int32.of_float (gettimeofday()) in self#check_sweep now; if (Int32.compare (Int32.sub now s.last_used) timeout) = 1 then (Hashtbl.remove sessions id; raise Session_not_found) else self#create (copy_dialog universe env s.session#dialog) with _ -> raise Session_not_found end;;