(*
* <COPYRIGHT>
* Copyright 2002 Joachim Schrod Network and Publication Consultance GmbH, Gerd Stolpmann
*
* <GPL>
* This file is part of WDialog.
*
* WDialog is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* WDialog is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with WDialog; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
* </>
*)
(* $Id: wd_dialog.ml,v 3.12 2005-06-11 14:24:14 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types
open Wd_serialize
let revision_dialog = "$Revision: 3.12 $" ;;
(* intentionally the CVS revision string *)
let serialize_interactor f b ia =
let b' = Buffer.create 100 in
Wd_interactor.serialize f b' ia;
let l = Buffer.length b' in
Buffer.add_string b "I(";
Buffer.add_string b (string_of_int l);
Buffer.add_string b ")";
Buffer.add_buffer b b'
;;
let serialize_string_option_interactor =
serialize_interactor
(function
| None -> "0"
| Some s -> "S(" ^ string_of_int(String.length s) ^ ")" ^ s
)
;;
let serialize_unit_interactor =
serialize_interactor
(fun () -> "0")
;;
let serialize_enumvars b l =
Buffer.add_string b "L(3,";
Buffer.add_string b (string_of_int (List.length l));
Buffer.add_string b ")";
List.iter
(fun (s1,s2_opt,s3) ->
serialize_string b s1;
( match s2_opt with
| None -> Buffer.add_string b "0"
| Some s2 -> serialize_string b s2
);
serialize_string b s3;
)
l
;;
let unserialize_interactor f buf =
let tok = ds_scan_token buf in
match tok with
| I_tok n ->
let e = buf.ds_pos + n in
if e > buf.ds_end then failwith "unserialize_interactor";
let buf' = { buf with ds_end = e } in
let ia = Wd_interactor.unserialize f buf' in
if buf'.ds_pos <> e then failwith "unserialize_interactor";
buf.ds_pos <- e;
ia
| _ ->
failwith "unserialize_interactor"
;;
let unserialize_string_option_interactor =
unserialize_interactor unserialize_string_option
;;
let unserialize_unit_interactor =
unserialize_interactor unserialize_unit
;;
let unserialize_enumvars buf =
let tok = ds_scan_token buf in
match tok with
| L_tok(3,n) ->
ds_make_list n
(fun () ->
let s1 = unserialize_string buf in
let s2_opt = unserialize_string_option buf in
let s3 = unserialize_string buf in
(s1,s2_opt,s3))
| _ -> failwith "unserialize_enumvars"
;;
let dump_interactors out ia =
let dump_goto_ia ia =
Wd_interactor.iter
(fun id name index value ->
let v = match value with
None -> "None"
| Some s -> "Some " ^ s
in
Format.fprintf out " id='%s' name='%s' index='%s' goto='%s'@\n"
id name index v)
ia
in
let dump_unit_ia ia =
Wd_interactor.iter
(fun id name index value ->
Format.fprintf out " id='%s' name='%s' index='%s'@\n"
id name index)
ia
in
Format.fprintf out "Buttons:@\n";
dump_goto_ia ia.ui_buttons;
Format.fprintf out "Imagebuttons:@\n";
dump_goto_ia ia.ui_imagebuttons;
Format.fprintf out "Anchors:@\n";
dump_goto_ia ia.ui_anchors;
Format.fprintf out "Indexed buttons:@\n";
dump_goto_ia ia.ui_indexed_buttons;
Format.fprintf out "Indexed imagebuttons:@\n";
dump_goto_ia ia.ui_indexed_imagebuttons;
Format.fprintf out "Indexed anchors:@\n";
dump_goto_ia ia.ui_indexed_anchors;
Format.fprintf out "Variables:@\n";
dump_unit_ia ia.ui_vars;
Format.fprintf out "Uploads:@\n";
dump_unit_ia ia.ui_uploads;
Format.fprintf out "Enumerated values:@\n";
List.iter
(function
(name, None, pg) -> Format.fprintf out " name='%s' page='%s'@\n"
name pg;
| (name, Some index, pg) -> Format.fprintf out " name='%s' index='%s' page='%s'@\n"
name index pg
)
ia.ui_enumvars
;;
let dot_re = Netstring_pcre.regexp "[.]";;
exception Check_dot;;
class virtual dialog
init_universe init_dlg_name init_env =
object (self : 'self)
val environment = init_env
val dialog_name = init_dlg_name
val universe = (init_universe : universe_type)
val application = init_universe # application
val declaration =
try init_universe # application # dialog_declaration init_dlg_name
with Not_found ->
raise(Runtime_error ("Dialog not found: " ^ init_dlg_name))
val mutable page_name = ""
val mutable next_page = ""
val mutable variables = (Wd_dictionary.empty : var_value dict)
val mutable last_event = No_event
val mutable server_popup_request = false
val mutable interactors =
{ ui_buttons = Wd_interactor.create None;
ui_imagebuttons = Wd_interactor.create None;
ui_anchors = Wd_interactor.create None;
ui_indexed_buttons = Wd_interactor.create None;
ui_indexed_imagebuttons = Wd_interactor.create None;
ui_indexed_anchors = Wd_interactor.create None;
ui_vars = Wd_interactor.create ();
ui_uploads = Wd_interactor.create ();
ui_enumvars = [];
};
val mutable upload_manager = lazy ( assert false )
val mutable session = None
initializer
self # init (declaration # start_page);
method copy =
( Oo.copy self : #dialog_type :> dialog_type )
method private init_defaults =
(* Add the default values to 'variables' *)
(* NOTE: As object variables do not allow to specify defaults, these
* are left out.
*)
List.iter
(fun name ->
let v = declaration # variable name in
if not (Wd_dictionary.mem v.var_name variables) then begin
match v.var_default with
Some default ->
self # set_variable v.var_name default
| None ->
if v.var_associative then
self # set_variable v.var_name (Alist_value [])
else begin
match v.var_type with
String_type ->
self # set_variable v.var_name (String_value "")
| Enum_type _ ->
self # set_variable v.var_name (Enum_value [])
| Dyn_enum_type ->
self # set_variable v.var_name (Dyn_enum_value [])
| Dialog_type ->
self # set_variable v.var_name (Dialog_value None)
end
end
)
(declaration # variable_names)
method init pg =
(* Go to page 'pg' *)
if not (List.mem pg (declaration # page_names)) then
raise (Runtime_error ("Page `" ^ pg ^ "' does not exist"));
page_name <- pg;
next_page <- pg;
(* last_event <- No_event; *)
(* Call Wd_interactor.clear now to delete all interactors. The
* sequence generators for the automatically generated IDs remain
* intact.
*)
Wd_interactor.clear interactors.ui_buttons;
Wd_interactor.clear interactors.ui_imagebuttons;
Wd_interactor.clear interactors.ui_anchors;
Wd_interactor.clear interactors.ui_indexed_buttons;
Wd_interactor.clear interactors.ui_indexed_imagebuttons;
Wd_interactor.clear interactors.ui_indexed_anchors;
Wd_interactor.clear interactors.ui_vars;
Wd_interactor.clear interactors.ui_uploads;
interactors.ui_enumvars <- [];
upload_manager <- lazy (raise(Runtime_error("Cannot access uploaded files at this stage of request processing")));
self # init_defaults;
method page_names =
declaration # page_names
method name =
dialog_name
method page_name =
page_name
method next_page =
next_page
method set_next_page pgname =
if not (List.mem pgname (declaration # page_names)) then
raise (Runtime_error ("Page `" ^ pgname ^ "' does not exist"));
next_page <- pgname;
method interactors = interactors
method variable name =
let rec descend dlg dn =
match dn with
[] -> assert false
| [n] -> dlg # variable n
| n::dn' ->
( match dlg # dialog_variable n with
None ->
raise (Runtime_error ("Dialog `" ^ n ^ "' is empty"))
| Some dlg' ->
descend dlg' dn'
)
in
try
Wd_dictionary.find name variables
with
Not_found ->
(* Maybe the dot notation is used: *)
let names = Netstring_pcre.split dot_re name in
match names with
[] -> raise (No_such_variable name)
| [_] -> raise (No_such_variable name)
| _ -> descend (self :> dialog_type) names
method string_variable name =
match self # variable name with
String_value s -> s
| _ ->
raise (Runtime_error ("Variable `" ^ name ^ "' accessed as string"))
method enum_variable name =
match self # variable name with
Enum_value s -> s
| _ ->
raise (Runtime_error ("Variable `" ^ name ^ "' accessed as enum"))
method dyn_enum_variable name =
(* it is possible to read an "enum_variable" also as "dyn_enum_variable"*)
self # read_dyn_enum name (self # variable name)
method variable_decl name =
let rec descend dlg dn =
match dn with
[] -> assert false
| [n] -> dlg # declaration # variable n
| n::dn' ->
( match dlg # dialog_variable n with
None ->
raise (Runtime_error ("Dialog `" ^ n ^ "' is empty"))
| Some dlg' ->
descend dlg' dn'
)
in
try declaration # variable name
with
Not_found ->
(* Maybe the dot notation is used: *)
let names = Netstring_pcre.split dot_re name in
match names with
[] -> raise Not_found
| [_] -> raise Not_found
| _ -> descend (self :> dialog_type) names
method private read_dyn_enum name value =
match value with
Dyn_enum_value s -> s
| Enum_value s ->
(* 's' contains only the internal values *)
let vt =
try
(self # variable_decl name).var_type
with
Not_found ->
raise (Runtime_error ("Cannot read non-declared variable `" ^
name ^ "'"))
in
begin match vt with
Enum_type e ->
List.map
(fun internal ->
try internal, List.assoc internal e.enum_definition
with Not_found -> assert false)
s
| _ -> assert false
end
| _ ->
raise (Runtime_error ("Variable `" ^ name ^ "' accessed as dyn enum"))
method dialog_variable name =
match self # variable name with
Dialog_value s -> s
| _ ->
raise (Runtime_error ("Variable `" ^ name ^ "' accessed as dialog"))
method alist_variable name =
match self # variable name with
Alist_value s -> s
| _ ->
raise (Runtime_error ("Variable `" ^ name ^ "' accessed as alist"))
method lookup_string_variable name index =
let al = self # alist_variable name in
match List.assoc index al with
String_value s -> s
| _ ->
raise (Runtime_error ("Variable `" ^ name ^ "' accessed as string"))
method lookup_enum_variable name index =
let al = self # alist_variable name in
match List.assoc index al with
Enum_value s -> s
| _ ->
raise (Runtime_error ("Variable `" ^ name ^ "' accessed as enum"))
method lookup_dyn_enum_variable name index =
let al = self # alist_variable name in
match List.assoc index al with
(Dyn_enum_value _ | Enum_value _) as v ->
self # read_dyn_enum name v
| _ ->
raise (Runtime_error ("Variable `" ^ name ^ "' accessed as dyn enum"))
method lookup_dialog_variable name index =
let al = self # alist_variable name in
match List.assoc index al with
Dialog_value s -> s
| _ ->
raise (Runtime_error ("Variable `" ^ name ^ "' accessed as dialog"))
method set_variable name value =
let rec descend dlg dn =
match dn with
[] -> assert false
| [n] -> dlg # set_variable n value
| n::dn' ->
( match dlg # dialog_variable n with
None ->
raise (Runtime_error ("Dialog `" ^ n ^ "' is empty"))
| Some dlg' ->
descend dlg' dn'
)
in
try
let var =
try
declaration # variable name
with
Not_found ->
(* Maybe the dot notation is used: *)
raise Check_dot
in
begin try
self # check_type value var false
with
Runtime_error s ->
raise (Runtime_error ("While setting variable `" ^ name ^ "':" ^
s))
end;
(* Set variable: *)
variables <- Wd_dictionary.add name value variables
with
Check_dot ->
let names = Netstring_pcre.split dot_re name in
match names with
[] -> raise (No_such_variable name)
| [_] -> raise (No_such_variable name)
| _ -> descend (self :> dialog_type) names
method private check_type value var inner_check =
(* Check type: *)
let vt = var.var_type in
let assoc = var.var_associative in
begin match value with
String_value _ ->
if assoc & not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
if vt <> String_type then
raise (Runtime_error ("Cannot put a string into variable"))
| Dialog_value _ ->
if assoc & not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
if vt <> Dialog_type then
raise (Runtime_error ("Cannot put a dialog into variable"));
| Dyn_enum_value v ->
if assoc & not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
if vt <> Dyn_enum_type then
raise (Runtime_error ("Cannot put a dynamic enumeration into variable"));
| Enum_value evals ->
if assoc & not inner_check then
raise (Runtime_error ("Cannot put plain value into associative variable without index"));
begin match vt with
Enum_type e ->
if List.exists
(fun v -> not (List.mem_assoc v e.enum_definition))
evals
then
raise (Runtime_error ("Values are not compatible with variable"));
| _ ->
raise (Runtime_error ("Cannot put an enumeration into variable"));
end
| Alist_value al ->
if not assoc then
raise (Runtime_error ("Cannot put an Alist value into a plain variable"));
List.iter
(fun (n,v) ->
self # check_type v var true)
al;
end;
method private t_get =
Wd_template.get application
method private t_apply =
Wd_template.apply (self : #dialog_type :> dialog_type)
method private t_apply_byname =
Wd_template.apply_byname (self : #dialog_type :> dialog_type)
method private t_apply_lazily =
Wd_template.apply_lazily (self : #dialog_type :> dialog_type)
method private t_concat =
Wd_template.concat application
method private t_empty =
Wd_template.empty application
method private t_text =
Wd_template.text application
method private t_html =
Wd_template.html application
method private t_to_string =
Wd_template.to_string (self : #dialog_type :> dialog_type)
method private put_tree n t =
self # set_variable n
(String_value
(Wd_template.to_string (self : #dialog_type :> dialog_type) t))
method unset_variable name =
let rec descend dlg dn =
match dn with
[] -> assert false
| [n] -> dlg # unset_variable n
| n::dn' ->
( match dlg # dialog_variable n with
None ->
raise (Runtime_error ("Dialog `" ^ n ^ "' is empty"))
| Some dlg' ->
descend dlg' dn'
)
in
(* Sets the value of 'name' to the default value. *)
if List.mem name (declaration # variable_names) then begin
variables <- Wd_dictionary.remove name variables;
self # init_defaults;
end
else begin
(* Maybe the dot notation is used: *)
let names = Netstring_pcre.split dot_re name in
match names with
[] -> raise (No_such_variable name)
| [_] -> raise (No_such_variable name)
| _ -> descend (self :> dialog_type) names
end
method lookup_uploaded_file name =
let arg = Wd_upload.get (Lazy.force upload_manager) name in
(* or raise Not_found *)
let fn = arg # filename in
if fn = None or fn = Some "" then
None
else
Some arg
method event =
last_event
method set_event ev =
last_event <- ev
method is_server_popup_request =
server_popup_request
method set_server_popup_request() =
server_popup_request <- true
method serialize m b =
(* Do not serialize temporary variables. *)
let persistent_variables =
List.filter
(fun (name,value) ->
try
not (declaration # variable name).var_temporary
with
Not_found -> assert false)
(Wd_dictionary.to_alist variables) in
let cgienv = environment.cgi # environment in
serialize_string b page_name;
serialize_string b next_page;
serialize_event b last_event;
serialize_string b (cgienv # cgi_remote_addr); (* IP address *)
serialize_alist m b persistent_variables;
serialize_string_option_interactor b interactors.ui_buttons;
serialize_string_option_interactor b interactors.ui_imagebuttons;
serialize_string_option_interactor b interactors.ui_anchors;
serialize_string_option_interactor b interactors.ui_indexed_buttons;
serialize_string_option_interactor b interactors.ui_indexed_imagebuttons;
serialize_string_option_interactor b interactors.ui_indexed_anchors;
serialize_unit_interactor b interactors.ui_vars;
serialize_enumvars b interactors.ui_enumvars;
serialize_unit_interactor b interactors.ui_uploads;
method unserialize buf =
let s_page_name = unserialize_string buf in
let s_next_page = unserialize_string buf in
let s_last_event = unserialize_event buf in
let last_peer = unserialize_string buf in
let serialized_variables = unserialize_alist buf in
let s_ui_buttons = unserialize_string_option_interactor buf in
let s_ui_imagebuttons = unserialize_string_option_interactor buf in
let s_ui_anchors = unserialize_string_option_interactor buf in
let s_ui_indexed_buttons = unserialize_string_option_interactor buf in
let s_ui_indexed_imagebuttons = unserialize_string_option_interactor buf in
let s_ui_indexed_anchors = unserialize_string_option_interactor buf in
let s_ui_vars = unserialize_unit_interactor buf in
let s_ui_enumvars = unserialize_enumvars buf in
let s_ui_uploads = unserialize_unit_interactor buf in
let cgienv = environment.cgi # environment in
let peer = cgienv # cgi_remote_addr in (* IP address *)
if peer <> last_peer then
failwith "Session includes the wrong IP address";
page_name <- s_page_name;
next_page <- s_next_page;
last_event <- s_last_event;
interactors <- { ui_buttons = s_ui_buttons;
ui_imagebuttons = s_ui_imagebuttons;
ui_anchors = s_ui_anchors;
ui_indexed_buttons = s_ui_indexed_buttons;
ui_indexed_imagebuttons = s_ui_indexed_imagebuttons;
ui_indexed_anchors = s_ui_indexed_anchors;
ui_vars = s_ui_vars;
ui_enumvars = s_ui_enumvars;
ui_uploads = s_ui_uploads };
upload_manager <- lazy ( Wd_upload.init environment interactors );
variables <- Wd_dictionary.of_alist serialized_variables;
self # init_defaults
method dump (f:Format.formatter) =
Format.fprintf f "<dialog-value page=\"%s\" name=\"%s\">@\n @[<v 0>"
(Wd_transform.escape_html page_name)
(Wd_transform.escape_html dialog_name);
let rec print_value value =
match value with
String_value u ->
Format.fprintf f "<string-value>%s</string-value>"
(Wd_transform.escape_html u)
| Enum_value l ->
Format.fprintf f "<enum-value>@\n @[<v 0>";
let is_first = ref true in
List.iter
(fun item ->
if not !is_first then Format.fprintf f "@\n";
is_first := false;
Format.fprintf f "<enum-item internal=\"%s\"/>"
(Wd_transform.escape_html item);
)
l;
Format.fprintf f "@]@\n</enum-value>";
| Dyn_enum_value e ->
Format.fprintf f "<dyn-enum-value>@\n @[<v 0>";
let is_first = ref true in
List.iter
(fun (int_item, ext_item) ->
if not !is_first then Format.fprintf f "@\n";
is_first := false;
Format.fprintf f
"<dyn-enum-item internal=\"%s\" external=\"%s\"/>"
(Wd_transform.escape_html int_item)
(Wd_transform.escape_html ext_item);
)
e;
Format.fprintf f "@]@\n</dyn-enum-value>";
| Dialog_value None ->
Format.fprintf f "<no-dialog-value/>"
| Dialog_value (Some o) ->
o # dump f
| Alist_value a ->
Format.fprintf f "<alist-value>@\n @[<v 0>";
let is_first = ref true in
List.iter
(fun (item, value) ->
if not !is_first then Format.fprintf f "@\n";
is_first := false;
Format.fprintf f
"<alist-item index=\"%s\">@\n @[<v 0>"
(Wd_transform.escape_html item);
print_value value;
Format.fprintf f "@]@\n</alist-item>";
)
a;
Format.fprintf f "@]@\n</alist-value>";
in
Wd_dictionary.iter
(fun name var ->
Format.fprintf f "<variable name=\"%s\">@\n @[<v 0>"
(Wd_transform.escape_html name);
print_value var;
Format.fprintf f "@]@\n</variable>@\n";
)
variables;
let s = match last_event with
No_event -> "no event"
| Button u -> "button " ^ u ^ " pressed"
| Image_button (u,x,y) ->
Printf.sprintf "image button %s pressed at (%d,%d)" u x y
| Indexed_button(u,index) -> "button " ^ u ^ "," ^ index ^ " pressed"
| Indexed_image_button (u,index,x,y) ->
Printf.sprintf "image button %s,%s pressed at (%d,%d)" u index x y
| Popup_request s ->
Printf.sprintf "popup request `%s'" s
in
Format.fprintf f "<interactors>@\n @[<v 0>";
let ia_raw_string =
Marshal.to_string interactors [] in
let ia_string =
Netencoding.Base64.encode
~linelength:72
ia_raw_string
in
let ia_lines =
Netstring_str.split (Netstring_str.regexp "\n") ia_string in
let is_first = ref true in
List.iter
(fun line ->
if not !is_first then Format.fprintf f "@\n";
is_first := false;
Format.pp_print_string f line;
)
ia_lines;
Format.fprintf f "@]@\n</interactors>@\n";
Format.fprintf f "<!--@\n";
dump_interactors f interactors;
Format.fprintf f "-->@\n";
Format.fprintf f "<!-- Last event: %s -->" (Wd_transform.escape_html s);
(* TODO: interactors *)
Format.fprintf f "@]@\n</dialog-value>";
method enter_session_scope s =
session <- Some s
method leave_session_scope () =
session <- None
method session =
match session with
Some s -> s
| None -> failwith "Session-related function called, but the dialog is currently outside the scope of a session"
method environment = environment
method declaration = declaration
method application = application
method universe = universe
method virtual prepare_page : unit -> unit
method virtual handle : unit -> unit
end
;;
let revision_hash =
Netencoding.Base64.encode
(Digest.string
(Wd_ocamlversion.revision_ocaml ^ "/" ^
Wd_types.revision_types ^ "/" ^
Wd_interactor.revision_interactor ^ "/" ^
revision_dialog))
;;
(* [revision_hash] changes when any of the components changes the version
* number. This ensures that format incompatibilities can safely detected.
* This scheme is even a bit overly strict.
*)
class instant_session init_dialog : session_type =
object (self)
val mutable dialog = (init_dialog : dialog_type)
val mutable dialog_name = init_dialog # name
val mutable encoded_session =
let b = Buffer.create 1000 in
init_dialog # serialize (Hashtbl.create 10) b;
Buffer.contents b
method dialog_name = dialog # name (* sic! *)
method dialog = dialog
method commit_changes() =
let b = Buffer.create 1000 in
dialog # serialize (Hashtbl.create 10) b;
encoded_session <- Buffer.contents b;
dialog_name <- dialog # name;
method serialize =
Netencoding.Base64.encode dialog_name ^ ":" ^
revision_hash ^ ":" ^
Netencoding.Base64.encode ~linelength:64 encoded_session
method change_dialog dlg =
dialog <- dlg;
method session_id =
failwith "The instant session manager does not provide session IDs"
end
;;
class instant_session_manager () : session_manager_type =
object (self)
method create dlg =
new instant_session dlg
method unserialize universe env serialized_session =
let dlg_name_b64, revision, encoded_session_b64 =
try
let l = String.length serialized_session in
let k1 = String.index serialized_session ':' in (* or Not_found *)
let k2 = String.index_from serialized_session (k1+1) ':' in
(* or Not_found *)
(String.sub serialized_session 0 k1,
String.sub serialized_session (k1+1) (k2-k1-1),
String.sub serialized_session (k2+1) (l-k2-1))
with
Not_found ->
failwith "Wd_dialog.instant_session_manager: Cannot decode session data"
in
if revision <> revision_hash then
failwith "Wd_dialog.instant_session_manager: Cannot decode a session string with an unknown format (bad revision number)";
let dlg_name =
Netencoding.Base64.decode ~accept_spaces:true dlg_name_b64 in
let encoded_session =
Netencoding.Base64.decode ~accept_spaces:true encoded_session_b64 in
let ds_buf =
{ ds_str = encoded_session;
ds_pos = 0;
ds_end = String.length encoded_session;
ds_universe = universe;
ds_environment = env;
ds_dialogs = Hashtbl.create 10
} in
let dlg =
try
universe # create env dlg_name
with
Not_found ->
raise(Runtime_error("Current dialog `" ^ dlg_name ^
"' is not registered in universe"))
in
dlg # unserialize ds_buf;
new instant_session dlg
end
;;
exception Invalid_session_checksum
exception Session_not_found
;;
let crlf_re = Netstring_pcre.regexp "[\r\n]";;
class database_session ~update id key (inst_session : session_type) =
object (self)
val update = update
val id = id
val key = key
val inst_session = inst_session
val mutable checksum = ""
method dialog_name = inst_session # dialog_name
method dialog = inst_session # dialog
method commit_changes () =
inst_session # commit_changes();
let value = inst_session # serialize in
(* Remove all LFs and CRs, they lead to problems *)
let value' = Netstring_pcre.global_replace crlf_re "" value in
checksum <- Digest.to_hex (Digest.string value);
let () = update id key value' checksum in
()
method serialize =
if checksum = "" then
checksum <- Digest.to_hex (Digest.string inst_session#serialize);
string_of_int id ^ ":" ^ key ^ ":" ^ checksum
method session_id =
string_of_int id ^ ":" ^ key
method change_dialog dlg =
inst_session # change_dialog dlg
end
;;
let id_key_cs_re = Netstring_pcre.regexp "^([0-9]+):([^:]*):([^:]*)$"
;;
class database_session_manager ?(private_key = "")
?(enable_checksum = true)
~allocate ~insert ~update ~lookup () =
object (self)
inherit instant_session_manager () as super
val private_key = private_key
val allocate = allocate
val insert = insert
val update = update
val lookup = lookup
method create dlg =
let instant_session = super # create dlg in
let id = allocate() in
let cgienv = (dlg # environment).cgi # environment in
let peer = cgienv # cgi_remote_addr in (* IP address *)
let key =
(* Generate a key that is "random enough": *)
Digest.to_hex
(Digest.string
(string_of_int id ^ ":" ^
private_key ^ ":" ^
string_of_float (Unix.gettimeofday()) ^ ":" ^
string_of_int (Unix.getpid()) ^ ":" ^
peer)) in
let () = insert id key in
new database_session ~update id key instant_session
method unserialize universe env id_key_cs =
let (id, key, cs) =
match Netstring_pcre.string_match id_key_cs_re id_key_cs 0 with
None ->
failwith "Wd_dialog.database_session_manager: Session identifier has wrong format"
| Some r ->
(int_of_string (Netstring_pcre.matched_group r 1 id_key_cs),
Netstring_pcre.matched_group r 2 id_key_cs,
Netstring_pcre.matched_group r 3 id_key_cs)
in
let value, checksum = lookup id key in
if enable_checksum && cs <> checksum then raise Invalid_session_checksum;
new database_session ~update id key (super # unserialize universe env value)
end
;;
(* ======================================================================
* History:
*
* $Log: wd_dialog.ml,v $
* Revision 3.12 2005-06-11 14:24:14 stolpmann
* Extension of bracket expressions: many new functions.
* Functions in bracket expressions may now lazily evaluate their arguments.
* ui:if and ui:ifvar may refer to any functions defined for bracket
* expressions.
* New: ui:ifexpr
* Parsing of bracket expressions is now done with ulex. Private interfaces
* of PXP are no longer used for this purpose.
* Serialization has been rewritten, and it is now safe.
* Fix: In ui:context there may now be macro references at any location.
* Also documented all these changes.
*
* Revision 3.11 2004/12/12 17:57:32 stolpmann
* Added <q:wd-link> and <q:wd-xlink> to generate links for
* applications that cannot use Javascript. Limited functionality, however.
* See stdlib.xml for details.
*
* Revision 3.10 2003/03/10 23:23:27 stolpmann
* Another security improvement: The checksum now changes after
* every web request
*
* Revision 3.9 2003/03/10 22:46:34 stolpmann
* the session contains now the IP number of the browser
*
* Revision 3.8 2003/03/09 17:08:29 stolpmann
* New class database_session_manager
*
* Revision 3.7 2002/11/09 11:41:19 stolpmann
* Fix: ui:select accepts dot notation. A new method
* variable_decl needs to be defined for dialogs. This method
* returns the var_decl record and interprets the dot notation.
*
* Revision 3.6 2002/10/18 20:17:50 stolpmann
* New feature: dot notation to access contents of dialog
* variables
*
* Revision 3.5 2002/04/10 21:27:52 stolpmann
* New scheme for automatically generated interactor IDs. There
* are now two parts: <base>_<seq> where <base> is the base number
* (currently derived from the system clock), and where <seq> is the
* sequence number. Sequence numbers are no longer reset to 0 after
* "handle". (The reason for the new ID scheme are buggy browsers that
* try to remember old form values. It is now very unlikely that a
* name for a form field is reused before the page expires.)
*
* Revision 3.4 2002/04/10 21:08:33 stolpmann
* Fix
*
* Revision 3.3 2002/04/10 20:08:31 stolpmann
* There is now some protection against incompatible changes of
* the format of the session records. Previously, such changes could
* even crash WDialog processes, because the sessions are serialized by
* the Marshal module. Now a hash key for the version (both WDialog
* and OCaml) is prepended to the serialized session string.
*
* Revision 3.2 2002/02/14 16:15:21 stolpmann
* Added copyright notice.
*
* Revision 3.1 2002/02/12 20:28:59 stolpmann
* Initial release at sourceforge.
*
* Revision 1.13 2002/02/11 11:14:21 gerd
* Fix: It is now possible to change the dialog of sessions (required
* for the Change_dialog exception)
*
* Revision 1.12 2002/02/06 00:14:00 gerd
* Updates to ocamlnet-0.92
*
* Revision 1.11 2002/02/05 18:44:16 gerd
* New: class instant_session_manager
*
* Revision 1.10 2002/01/14 15:03:24 gerd
* Major change: Typing has been completely revised, and almost
* every tiny thing has now a new type. Also renamed a lot.
*
* Revision 1.9 2000/12/21 15:00:37 gerd
* Server popups: The generated "open" function has now a second
* parameter which is passed back to the application. The Popup_request
* event gets this parameter. The parameter can be used freely by the
* application.
*
* Revision 1.8 2000/12/04 18:28:02 gerd
* Update
*
* Revision 1.7 2000/12/04 12:00:26 gerd
* dump_interactors
*
* Revision 1.6 2000/11/30 18:41:49 gerd
* See uiobject.mli rev 1.5
*
* Revision 1.5 2000/07/03 12:28:10 gerd
* Improved debugging support: The interactor structure
* is included as descriprive text on demand.
*
* Revision 1.4 2000/05/15 11:46:33 gerd
* Necessary changes for uidebugger.
*
* Revision 1.3 2000/05/08 15:31:26 gerd
* New methods: exn_object_declaration and exn_default_context.
*
* Revision 1.2 2000/04/17 10:10:52 gerd
* New Cgi module.
* File upload strongly improved.
*
* Revision 1.1 2000/04/13 17:42:58 gerd
* Initial revision.
*
*
*)
